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 -- Driver flags
-- --
...@@ -399,3 +399,95 @@ decodeSize str ...@@ -399,3 +399,95 @@ decodeSize str
floatOpt :: IORef Double -> String -> IO () floatOpt :: IORef Double -> String -> IO ()
floatOpt ref str floatOpt ref str
= writeIORef ref (read str :: Double) = 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 -- Settings for the driver
-- --
...@@ -671,6 +671,9 @@ GLOBAL_VAR(opt_C, [], [String]) ...@@ -671,6 +671,9 @@ GLOBAL_VAR(opt_C, [], [String])
GLOBAL_VAR(opt_l, [], [String]) GLOBAL_VAR(opt_l, [], [String])
GLOBAL_VAR(opt_dll, [], [String]) GLOBAL_VAR(opt_dll, [], [String])
getStaticOpts :: IORef [String] -> IO [String]
getStaticOpts ref = readIORef ref >>= return . reverse
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Via-C compilation stuff -- Via-C compilation stuff
...@@ -756,17 +759,3 @@ run_something phase_name cmd ...@@ -756,17 +759,3 @@ run_something phase_name cmd
else do when verb (putStr "\n") else do when verb (putStr "\n")
return () 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 -- Utils for the driver
-- --
...@@ -21,7 +21,6 @@ import RegexString ...@@ -21,7 +21,6 @@ import RegexString
import IO import IO
import System import System
import Directory
import List import List
import Char import Char
import Monad import Monad
...@@ -133,6 +132,12 @@ addNoDups var x = do ...@@ -133,6 +132,12 @@ addNoDups var x = do
xs <- readIORef var xs <- readIORef var
unless (x `elem` xs) $ writeIORef var (x:xs) 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 :: Char -> String -> String
remove_suffix c s remove_suffix c s
| null pre = reverse suf | 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 -- GHC Driver program
-- --
...@@ -46,7 +46,7 @@ newPackage = do ...@@ -46,7 +46,7 @@ newPackage = do
then throwDyn (OtherError ("package `" ++ name new_pkg ++ then throwDyn (OtherError ("package `" ++ name new_pkg ++
"' already installed")) "' already installed"))
else do else do
conf_file <- readIORef package_config conf_file <- readIORef path_package_config
savePackageConfig conf_file savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do maybeRestoreOldConfig conf_file $ do
writeNewConfig conf_file ( ++ [new_pkg]) writeNewConfig conf_file ( ++ [new_pkg])
...@@ -59,7 +59,7 @@ deletePackage pkg = do ...@@ -59,7 +59,7 @@ deletePackage pkg = do
if (pkg `notElem` map name details) if (pkg `notElem` map name details)
then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed")) then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
else do else do
conf_file <- readIORef package_config conf_file <- readIORef path_package_config
savePackageConfig conf_file savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do maybeRestoreOldConfig conf_file $ do
writeNewConfig conf_file (filter ((/= pkg) . name)) writeNewConfig conf_file (filter ((/= pkg) . name))
...@@ -67,7 +67,7 @@ deletePackage pkg = do ...@@ -67,7 +67,7 @@ deletePackage pkg = do
checkConfigAccess :: IO () checkConfigAccess :: IO ()
checkConfigAccess = do checkConfigAccess = do
conf_file <- readIORef package_config conf_file <- readIORef path_package_config
access <- getPermissions conf_file access <- getPermissions conf_file
unless (writable access) unless (writable access)
(throwDyn (OtherError "you don't have permission to modify the package configuration file")) (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