Commit 1211c4e5 authored by simonmar's avatar simonmar
Browse files

[project @ 2000-10-11 15:26:18 by simonmar]

all compiles now; not quite hooked up to hscMain yet though.
parent 0cb8c786
-----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
-- $Id: DriverFlags.hs,v 1.2 2000/10/11 15:26:18 simonmar Exp $
--
-- Driver flags
--
......@@ -399,3 +399,95 @@ decodeSize str
floatOpt :: IORef Double -> String -> IO ()
floatOpt ref str
= writeIORef ref (read str :: Double)
-----------------------------------------------------------------------------
-- Build the Hsc static command line opts
build_hsc_opts :: IO [String]
build_hsc_opts = do
opt_C_ <- getStaticOpts opt_C -- misc hsc opts
-- warnings
warn_level <- readIORef warning_opt
let warn_opts = case warn_level of
W_default -> standardWarnings
W_ -> minusWOpts
W_all -> minusWallOpts
W_not -> []
-- optimisation
minus_o <- readIORef opt_level
optimisation_opts <-
case minus_o of
0 -> hsc_minusNoO_flags
1 -> hsc_minusO_flags
2 -> hsc_minusO2_flags
_ -> error "unknown opt level"
-- ToDo: -Ofile
-- STG passes
ways_ <- readIORef ways
let stg_massage | WayProf `elem` ways_ = "-fmassage-stg-for-profiling"
| otherwise = ""
stg_stats <- readIORef opt_StgStats
let stg_stats_flag | stg_stats = "-dstg-stats"
| otherwise = ""
let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
-- let-no-escape always on for now
-- take into account -fno-* flags by removing the equivalent -f*
-- flag from our list.
anti_flags <- getStaticOpts anti_opt_C
let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
filtered_opts = filter (`notElem` anti_flags) basic_opts
verb <- is_verbose
let hi_vers = "-fhi-version="++cProjectVersionInt
static <- (do s <- readIORef static; if s then return "-static" else return "")
l <- readIORef hsc_lang
let lang = case l of
HscC -> "-olang=C"
HscAsm -> "-olang=asm"
HscJava -> "-olang=java"
-- get hi-file suffix
hisuf <- readIORef hi_suf
-- hi-suffix for packages depends on the build tag.
package_hisuf <-
do tag <- readIORef build_tag
if null tag
then return "hi"
else return (tag ++ "_hi")
import_dirs <- readIORef import_paths
package_import_dirs <- getPackageImportPath
let hi_map = "-himap=" ++
makeHiMap import_dirs hisuf
package_import_dirs package_hisuf
split_marker
hi_map_sep = "-himap-sep=" ++ [split_marker]
return
(
filtered_opts
++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
)
makeHiMap
(import_dirs :: [String])
(hi_suffix :: String)
(package_import_dirs :: [String])
(package_hi_suffix :: String)
(split_marker :: Char)
= foldr (add_dir hi_suffix)
(foldr (add_dir package_hi_suffix) "" package_import_dirs)
import_dirs
where
add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
This diff is collapsed.
-----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.2 2000/10/11 14:08:52 simonmar Exp $
-- $Id: DriverState.hs,v 1.3 2000/10/11 15:26:18 simonmar Exp $
--
-- Settings for the driver
--
......@@ -671,6 +671,9 @@ GLOBAL_VAR(opt_C, [], [String])
GLOBAL_VAR(opt_l, [], [String])
GLOBAL_VAR(opt_dll, [], [String])
getStaticOpts :: IORef [String] -> IO [String]
getStaticOpts ref = readIORef ref >>= return . reverse
-----------------------------------------------------------------------------
-- Via-C compilation stuff
......@@ -756,17 +759,3 @@ run_something phase_name cmd
else do when verb (putStr "\n")
return ()
-----------------------------------------------------------------------------
-- File suffixes & things
-- the output suffix for a given phase is uniquely determined by
-- the input requirements of the next phase.
unlitInputExt = "lhs"
cppInputExt = "lpp"
hscInputExt = "cpp"
hccInputExt = "hc"
ccInputExt = "c"
mangleInputExt = "raw_s"
asInputExt = "s"
lnInputExt = "o"
-----------------------------------------------------------------------------
-- $Id: DriverUtil.hs,v 1.2 2000/10/11 14:08:52 simonmar Exp $
-- $Id: DriverUtil.hs,v 1.3 2000/10/11 15:26:18 simonmar Exp $
--
-- Utils for the driver
--
......@@ -21,7 +21,6 @@ import RegexString
import IO
import System
import Directory
import List
import Char
import Monad
......@@ -133,6 +132,12 @@ addNoDups var x = do
xs <- readIORef var
unless (x `elem` xs) $ writeIORef var (x:xs)
splitFilename :: String -> (String,String)
splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
stripDot ('.':xs) = xs
stripDot xs = xs
remove_suffix :: Char -> String -> String
remove_suffix c s
| null pre = reverse suf
......
This diff is collapsed.
-----------------------------------------------------------------------------
-- $Id: PackageMaintenance.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
-- $Id: PackageMaintenance.hs,v 1.2 2000/10/11 15:26:18 simonmar Exp $
--
-- GHC Driver program
--
......@@ -46,7 +46,7 @@ newPackage = do
then throwDyn (OtherError ("package `" ++ name new_pkg ++
"' already installed"))
else do
conf_file <- readIORef package_config
conf_file <- readIORef path_package_config
savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do
writeNewConfig conf_file ( ++ [new_pkg])
......@@ -59,7 +59,7 @@ deletePackage pkg = do
if (pkg `notElem` map name details)
then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
else do
conf_file <- readIORef package_config
conf_file <- readIORef path_package_config
savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do
writeNewConfig conf_file (filter ((/= pkg) . name))
......@@ -67,7 +67,7 @@ deletePackage pkg = do
checkConfigAccess :: IO ()
checkConfigAccess = do
conf_file <- readIORef package_config
conf_file <- readIORef path_package_config
access <- getPermissions conf_file
unless (writable access)
(throwDyn (OtherError "you don't have permission to modify the package configuration file"))
......
-----------------------------------------------------------------------------
-- $Id: PreProcess.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
--
-- Pre-process source files
--
-- (c) The University of Glasgow 2000
--
-----------------------------------------------------------------------------
module PreProcess (
preprocess -- :: FilePath -> IO FilePath
) where
import TmpFiles
import DriverState
import DriverUtil
import IOExts
-----------------------------------------------------------------------------
-- preprocess takes a haskell source file and generates a raw .hs
-- file. This involves passing the file through 'unlit', 'cpp', or both.
preprocess :: FilePath -> IO FilePath
preprocess filename = do
let (basename, suffix) = splitFilename filename
unlit_file <- unlit filename
cpp_file <- cpp unlit_file
return cpp_file
-------------------------------------------------------------------------------
-- Unlit phase
unlit :: FilePath -> IO FilePath
unlit input_fn
| suffix /= unlitInputExt = return input_fn
| otherwise =
do output_fn <- newTempName cppInputExt
unlit <- readIORef pgm_L
unlit_flags <- getOpts opt_L
run_something "Literate pre-processor"
("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
return output_fn
where
(filename, suffix) = splitFilename input_fn
-------------------------------------------------------------------------------
-- Cpp phase
cpp :: FilePath -> IO FilePath
cpp input_fn
= do src_opts <- getOptionsFromSource input_fn
_ <- processArgs dynamic_flags src_opts []
output_fn <- newTempName hscInputExt
do_cpp <- readState cpp_flag
if do_cpp
then do
cpp <- readIORef pgm_P
hscpp_opts <- getOpts opt_P
hs_src_cpp_opts <- readIORef hs_source_cpp_opts
cmdline_include_paths <- readIORef include_paths
pkg_include_dirs <- getPackageIncludePath
let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
++ pkg_include_dirs)
verb <- is_verbose
run_something "C pre-processor"
(unwords
(["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
cpp, verb]
++ include_paths
++ hs_src_cpp_opts
++ hscpp_opts
++ [ "-x", "c", input_fn, ">>", output_fn ]
))
else do
run_something "Ineffective C pre-processor"
("echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}' > "
++ output_fn ++ " && cat " ++ input_fn
++ " >> " ++ output_fn)
return True
-----------------------------------------------------------------------------
-- utils
splitFilename :: String -> (String,String)
splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
stripDot ('.':xs) = xs
stripDot xs = xs
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment