module CmdLineOpts (
CoreToDo(..),
- SimplifierSwitch(..),
+ SimplifierSwitch(..), isAmongSimpl,
StgToDo(..),
SwitchResult(..),
HscLang(..),
- DynFlag(..), -- needed non-abstractly by Main
+ DynFlag(..), -- needed non-abstractly by DriverFlags
+ DynFlags(..),
intSwitchSet,
switchIsOn,
+ isStaticHscFlag,
-- debugging opts
dopt_D_dump_absC,
import GlaExts
import Argv
import Constants -- Default values for some flags
+import DriverUtil
import Maybes ( firstJust )
import Panic ( panic )
| CoreDoCPResult
| CoreDoGlomBinds
| CoreCSE
+
+ | CoreDoNothing -- useful when building up lists of these things
\end{code}
\begin{code}
%************************************************************************
%* *
+\subsection{List of static hsc flags}
+%* *
+%************************************************************************
+
+\begin{code}
+isStaticHscFlag f =
+ f `elem` [
+ "-fwarn-duplicate-exports",
+ "-fwarn-hi-shadowing",
+ "-fwarn-incomplete-patterns",
+ "-fwarn-missing-fields",
+ "-fwarn-missing-methods",
+ "-fwarn-missing-signatures",
+ "-fwarn-name-shadowing",
+ "-fwarn-overlapping-patterns",
+ "-fwarn-simple-patterns",
+ "-fwarn-type-defaults",
+ "-fwarn-unused-binds",
+ "-fwarn-unused-imports",
+ "-fwarn-unused-matches",
+ "-fwarn-deprecations",
+ "-fauto-sccs-on-all-toplevs",
+ "-fauto-sccs-on-exported-toplevs",
+ "-fauto-sccs-on-individual-cafs",
+ "-fauto-sccs-on-dicts",
+ "-fscc-profiling",
+ "-fticky-ticky",
+ "-fall-strict",
+ "-fdicts-strict",
+ "-fgenerics",
+ "-firrefutable-tuples",
+ "-fnumbers-strict",
+ "-fparallel",
+ "-fsmp",
+ "-fsemi-tagging",
+ "-ffoldr-build-on",
+ "-flet-no-escape",
+ "-funfold-casms-in-hi-file",
+ "-fusagesp-on",
+ "-funbox-strict-fields",
+ "-femit-extern-decls",
+ "-fglobalise-toplev-names",
+ "-fgransim",
+ "-fignore-asserts",
+ "-fignore-interface-pragmas",
+ "-fno-hi-version-check",
+ "-fno-implicit-prelude",
+ "-dno-black-holing",
+ "-fomit-interface-pragmas",
+ "-fno-pre-inlining",
+ "-fdo-eta-reduction",
+ "-fdo-lambda-eta-expansion",
+ "-fcase-of-case",
+ "-fcase-merge",
+ "-fpedantic-bottoms",
+ "-fexcess-precision",
+ "-funfolding-update-in-place",
+ "-freport-compile",
+ "-fno-prune-decls",
+ "-fno-prune-tydecls",
+ "-static",
+ "-funregisterised",
+ "-v" ]
+ || any (flip prefixMatch f) [
+ "-fcontext-stack",
+ "-fliberate-case-threshold",
+ "-fhi-version=",
+ "-fhistory-size",
+ "-funfolding-interface-threshold",
+ "-funfolding-creation-threshold",
+ "-funfolding-use-threshold",
+ "-funfolding-fun-discount",
+ "-funfolding-keeness-factor"
+ ]
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Switch ordering}
%* *
%************************************************************************
-In spite of the @Produce*@ constructor, these things behave just like
-enumeration types.
+These things behave just like enumeration types.
\begin{code}
instance Eq SimplifierSwitch where
\begin{code}
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
-
isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
-- in the list; defaults right at the end.
= let
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: DriverFlags.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+--
+-- Driver flags
+--
+-- (c) Simon Marlow 2000
+--
+-----------------------------------------------------------------------------
+
+module DriverFlags where
+
+#include "HsVersions.h"
+
+import PackageMaintenance
+import DriverState
+import DriverUtil
+import CmdLineOpts
+import Config
+import Util
+import CmdLineOpts
+
+import Exception
+import IOExts
+import IO
+import System
+import Char
+
+-----------------------------------------------------------------------------
+-- Flags
+
+-- Flag parsing is now done in stages:
+--
+-- * parse the initial list of flags and remove any flags understood
+-- by the driver only. Determine whether we're in multi-compilation
+-- or single-compilation mode.
+--
+-- * gather the list of "static" hsc flags, and assign them to the global
+-- static hsc flags variable.
+--
+-- * build the inital DynFlags from the remaining flags.
+--
+-- * complain if we've got any flags left over.
+--
+-- * for each source file: grab the OPTIONS, and build a new DynFlags
+-- to pass to the compiler.
+
+-----------------------------------------------------------------------------
+-- Process command-line
+
+data OptKind
+ = NoArg (IO ()) -- flag with no argument
+ | HasArg (String -> IO ()) -- flag has an argument (maybe prefix)
+ | SepArg (String -> IO ()) -- flag has a separate argument
+ | Prefix (String -> IO ()) -- flag is a prefix only
+ | OptPrefix (String -> IO ()) -- flag may be a prefix
+ | AnySuffix (String -> IO ()) -- flag is a prefix, pass whole arg to fn
+ | PassFlag (String -> IO ()) -- flag with no arg, pass flag to fn
+ | PrefixPred (String -> Bool) (String -> IO ())
+ | AnySuffixPred (String -> Bool) (String -> IO ())
+
+processArgs :: [(String,OptKind)] -> [String] -> [String]
+ -> IO [String] -- returns spare args
+processArgs _spec [] spare = return (reverse spare)
+processArgs spec args@(arg@('-':_):args') spare = do
+ case findArg spec arg of
+ Just (rest,action) ->
+ do args' <- processOneArg action rest args
+ processArgs spec args' spare
+ Nothing ->
+ processArgs spec args' (arg:spare)
+processArgs spec (arg:args) spare =
+ processArgs spec args (arg:spare)
+
+processOneArg :: OptKind -> String -> [String] -> IO [String]
+processOneArg action rest (dash_arg@('-':arg):args) =
+ case action of
+ NoArg io ->
+ if rest == ""
+ then io >> return args
+ else unknownFlagErr dash_arg
+
+ HasArg fio ->
+ if rest /= ""
+ then fio rest >> return args
+ else case args of
+ [] -> unknownFlagErr dash_arg
+ (arg1:args1) -> fio arg1 >> return args1
+
+ SepArg fio ->
+ case args of
+ [] -> unknownFlagErr dash_arg
+ (arg1:args1) -> fio arg1 >> return args1
+
+ Prefix fio ->
+ if rest /= ""
+ then fio rest >> return args
+ else unknownFlagErr dash_arg
+
+ PrefixPred p fio ->
+ if rest /= ""
+ then fio rest >> return args
+ else unknownFlagErr dash_arg
+
+ OptPrefix fio -> fio rest >> return args
+
+ AnySuffix fio -> fio dash_arg >> return args
+
+ AnySuffixPred p fio -> fio dash_arg >> return args
+
+ PassFlag fio ->
+ if rest /= ""
+ then unknownFlagErr dash_arg
+ else fio dash_arg >> return args
+
+findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind)
+findArg spec arg
+ = case [ (remove_spaces rest, k)
+ | (pat,k) <- spec, Just rest <- [my_prefix_match pat arg],
+ arg_ok k arg rest ]
+ of
+ [] -> Nothing
+ (one:_) -> Just one
+
+arg_ok (NoArg _) rest arg = null rest
+arg_ok (HasArg _) rest arg = True
+arg_ok (SepArg _) rest arg = null rest
+arg_ok (Prefix _) rest arg = not (null rest)
+arg_ok (PrefixPred p _) rest arg = not (null rest) && p rest
+arg_ok (OptPrefix _) rest arg = True
+arg_ok (PassFlag _) rest arg = null rest
+arg_ok (AnySuffix _) rest arg = not (null rest)
+arg_ok (AnySuffixPred p _) rest arg = not (null rest) && p arg
+
+-----------------------------------------------------------------------------
+-- Static flags
+
+-- note that ordering is important in the following list: any flag which
+-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
+-- flags further down the list with the same prefix.
+
+static_flags =
+ [ ------- help -------------------------------------------------------
+ ( "?" , NoArg long_usage)
+ , ( "-help" , NoArg long_usage)
+
+
+ ------- version ----------------------------------------------------
+ , ( "-version" , NoArg (do hPutStrLn stdout (cProjectName
+ ++ ", version " ++ version_str)
+ exitWith ExitSuccess))
+ , ( "-numeric-version", NoArg (do hPutStrLn stdout version_str
+ exitWith ExitSuccess))
+
+ ------- verbosity ----------------------------------------------------
+ , ( "v" , NoArg (writeIORef verbose True) )
+ , ( "n" , NoArg (writeIORef dry_run True) )
+
+ ------- recompilation checker --------------------------------------
+ , ( "recomp" , NoArg (writeIORef recomp True) )
+ , ( "no-recomp" , NoArg (writeIORef recomp False) )
+
+ ------- ways --------------------------------------------------------
+ , ( "prof" , NoArg (addNoDups ways WayProf) )
+ , ( "unreg" , NoArg (addNoDups ways WayUnreg) )
+ , ( "dll" , NoArg (addNoDups ways WayDll) )
+ , ( "ticky" , NoArg (addNoDups ways WayTicky) )
+ , ( "parallel" , NoArg (addNoDups ways WayPar) )
+ , ( "gransim" , NoArg (addNoDups ways WayGran) )
+ , ( "smp" , NoArg (addNoDups ways WaySMP) )
+ , ( "debug" , NoArg (addNoDups ways WayDebug) )
+ -- ToDo: user ways
+
+ ------ Debugging ----------------------------------------------------
+ , ( "dppr-noprags", PassFlag (add opt_C) )
+ , ( "dppr-debug", PassFlag (add opt_C) )
+ , ( "dppr-user-length", AnySuffix (add opt_C) )
+ -- rest of the debugging flags are dynamic
+
+ ------- Interface files ---------------------------------------------
+ , ( "hi" , NoArg (writeIORef produceHi True) )
+ , ( "nohi" , NoArg (writeIORef produceHi False) )
+
+ --------- Profiling --------------------------------------------------
+ , ( "auto-dicts" , NoArg (add opt_C "-fauto-sccs-on-dicts") )
+ , ( "auto-all" , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") )
+ , ( "auto" , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") )
+ , ( "caf-all" , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") )
+ -- "ignore-sccs" doesn't work (ToDo)
+
+ , ( "no-auto-dicts" , NoArg (add anti_opt_C "-fauto-sccs-on-dicts") )
+ , ( "no-auto-all" , NoArg (add anti_opt_C "-fauto-sccs-on-all-toplevs") )
+ , ( "no-auto" , NoArg (add anti_opt_C "-fauto-sccs-on-exported-toplevs") )
+ , ( "no-caf-all" , NoArg (add anti_opt_C "-fauto-sccs-on-individual-cafs") )
+
+ ------- Miscellaneous -----------------------------------------------
+ , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat
+
+ ------- Output Redirection ------------------------------------------
+ , ( "odir" , HasArg (writeIORef output_dir . Just) )
+ , ( "o" , SepArg (writeIORef output_file . Just) )
+ , ( "osuf" , HasArg (writeIORef output_suf . Just) )
+ , ( "hisuf" , HasArg (writeIORef hi_suf) )
+ , ( "tmpdir" , HasArg (writeIORef v_TmpDir . (++ "/")) )
+ , ( "ohi" , HasArg (\s -> case s of
+ "-" -> writeIORef hi_on_stdout True
+ _ -> writeIORef output_hi (Just s)) )
+ -- -odump?
+
+ , ( "keep-hc-file" , AnySuffix (\_ -> writeIORef keep_hc_files True) )
+ , ( "keep-s-file" , AnySuffix (\_ -> writeIORef keep_s_files True) )
+ , ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files True) )
+ , ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
+
+ , ( "split-objs" , NoArg (if can_split
+ then do writeIORef split_object_files True
+ add opt_C "-fglobalise-toplev-names"
+-- TODO!!!!! add opt_c "-DUSE_SPLIT_MARKERS"
+ else hPutStrLn stderr
+ "warning: don't know how to split \
+ \object files on this architecture"
+ ) )
+
+ ------- Include/Import Paths ----------------------------------------
+ , ( "i" , OptPrefix (addToDirList import_paths) )
+ , ( "I" , Prefix (addToDirList include_paths) )
+
+ ------- Libraries ---------------------------------------------------
+ , ( "L" , Prefix (addToDirList library_paths) )
+ , ( "l" , Prefix (add cmdline_libraries) )
+
+ ------- Packages ----------------------------------------------------
+ , ( "package-name" , HasArg (\s -> add opt_C ("-inpackage="++s)) )
+
+ , ( "package" , HasArg (addPackage) )
+ , ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
+
+ , ( "-list-packages" , NoArg (listPackages) )
+ , ( "-add-package" , NoArg (newPackage) )
+ , ( "-delete-package" , SepArg (deletePackage) )
+
+ ------- Specific phases --------------------------------------------
+ , ( "pgmL" , HasArg (writeIORef pgm_L) )
+ , ( "pgmP" , HasArg (writeIORef pgm_P) )
+ , ( "pgmC" , HasArg (writeIORef pgm_C) )
+ , ( "pgmc" , HasArg (writeIORef pgm_c) )
+ , ( "pgmm" , HasArg (writeIORef pgm_m) )
+ , ( "pgms" , HasArg (writeIORef pgm_s) )
+ , ( "pgma" , HasArg (writeIORef pgm_a) )
+ , ( "pgml" , HasArg (writeIORef pgm_l) )
+
+ , ( "optdep" , HasArg (add opt_dep) )
+ , ( "optl" , HasArg (add opt_l) )
+ , ( "optdll" , HasArg (add opt_dll) )
+
+ ------ Warning opts -------------------------------------------------
+ , ( "W" , NoArg (writeIORef warning_opt W_) )
+ , ( "Wall" , NoArg (writeIORef warning_opt W_all) )
+ , ( "Wnot" , NoArg (writeIORef warning_opt W_not) )
+ , ( "w" , NoArg (writeIORef warning_opt W_not) )
+
+ ----- Linker --------------------------------------------------------
+ , ( "static" , NoArg (writeIORef static True) )
+
+ ------ Compiler flags -----------------------------------------------
+ , ( "O2-for-C" , NoArg (writeIORef opt_minus_o2_for_C True) )
+ , ( "O" , OptPrefix (setOptLevel) )
+
+ , ( "fasm" , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
+
+ , ( "fvia-c" , NoArg (writeIORef hsc_lang HscC) )
+ , ( "fvia-C" , NoArg (writeIORef hsc_lang HscC) )
+
+ , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling False) )
+
+ , ( "fmax-simplifier-iterations",
+ Prefix (writeIORef opt_MaxSimplifierIterations . read) )
+
+ , ( "fusagesp" , NoArg (do writeIORef opt_UsageSPInf True
+ add opt_C "-fusagesp-on") )
+
+ , ( "fexcess-precision" , NoArg (do writeIORef excess_precision True
+ add opt_C "-fexcess-precision"))
+
+ -- flags that are "active negatives"
+ , ( "fno-implicit-prelude" , PassFlag (add opt_C) )
+ , ( "fno-prune-tydecls" , PassFlag (add opt_C) )
+ , ( "fno-prune-instdecls" , PassFlag (add opt_C) )
+ , ( "fno-pre-inlining" , PassFlag (add opt_C) )
+
+ -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
+ , ( "fno-", PrefixPred (\s -> isStaticHscFlag ("f"++s))
+ (\s -> add anti_opt_C ("-f"++s)) )
+
+ -- Pass all remaining "-f<blah>" options to hsc
+ , ( "f", AnySuffixPred (isStaticHscFlag) (add opt_C) )
+ ]
+
+-----------------------------------------------------------------------------
+-- parse the dynamic arguments
+
+GLOBAL_VAR(dynFlags, error "no dynFlags", DynFlags)
+
+setDynFlag f = do
+ dfs <- readIORef dynFlags
+ writeIORef dynFlags dfs{ flags = f : flags dfs }
+
+unSetDynFlag f = do
+ dfs <- readIORef dynFlags
+ writeIORef dynFlags dfs{ flags = filter (/= f) (flags dfs) }
+
+dynamic_flags = [
+
+ ( "cpp", NoArg (updateState (\s -> s{ cpp_flag = True })) )
+ , ( "#include", HasArg (addCmdlineHCInclude) )
+
+ , ( "optL", HasArg (addOpt_L) )
+ , ( "optP", HasArg (addOpt_P) )
+ , ( "optc", HasArg (addOpt_c) )
+ , ( "optm", HasArg (addOpt_m) )
+ , ( "opta", HasArg (addOpt_a) )
+
+ ------ HsCpp opts ---------------------------------------------------
+ , ( "D", Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
+ , ( "U", Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )
+
+ ------ Debugging ----------------------------------------------------
+ , ( "dstg-stats", NoArg (writeIORef opt_StgStats True) )
+
+ , ( "ddump_all", NoArg (setDynFlag Opt_D_dump_all) )
+ , ( "ddump_most", NoArg (setDynFlag Opt_D_dump_most) )
+ , ( "ddump_absC", NoArg (setDynFlag Opt_D_dump_absC) )
+ , ( "ddump_asm", NoArg (setDynFlag Opt_D_dump_asm) )
+ , ( "ddump_cpranal", NoArg (setDynFlag Opt_D_dump_cpranal) )
+ , ( "ddump_deriv", NoArg (setDynFlag Opt_D_dump_deriv) )
+ , ( "ddump_ds", NoArg (setDynFlag Opt_D_dump_ds) )
+ , ( "ddump_flatC", NoArg (setDynFlag Opt_D_dump_flatC) )
+ , ( "ddump_foreign", NoArg (setDynFlag Opt_D_dump_foreign) )
+ , ( "ddump_inlinings", NoArg (setDynFlag Opt_D_dump_inlinings) )
+ , ( "ddump_occur_anal", NoArg (setDynFlag Opt_D_dump_occur_anal) )
+ , ( "ddump_parsed", NoArg (setDynFlag Opt_D_dump_parsed) )
+ , ( "ddump_realC", NoArg (setDynFlag Opt_D_dump_realC) )
+ , ( "ddump_rn", NoArg (setDynFlag Opt_D_dump_rn) )
+ , ( "ddump_simpl", NoArg (setDynFlag Opt_D_dump_simpl) )
+ , ( "ddump_simpl_iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) )
+ , ( "ddump_spec", NoArg (setDynFlag Opt_D_dump_spec) )
+ , ( "ddump_stg", NoArg (setDynFlag Opt_D_dump_stg) )
+ , ( "ddump_stranal", NoArg (setDynFlag Opt_D_dump_stranal) )
+ , ( "ddump_tc", NoArg (setDynFlag Opt_D_dump_tc) )
+ , ( "ddump_types", NoArg (setDynFlag Opt_D_dump_types) )
+ , ( "ddump_rules", NoArg (setDynFlag Opt_D_dump_rules) )
+ , ( "ddump_usagesp", NoArg (setDynFlag Opt_D_dump_usagesp) )
+ , ( "ddump_cse", NoArg (setDynFlag Opt_D_dump_cse) )
+ , ( "ddump_worker_wrapper", NoArg (setDynFlag Opt_D_dump_worker_wrapper) )
+ , ( "dshow_passes", NoArg (setDynFlag Opt_D_show_passes) )
+ , ( "ddump_rn_trace", NoArg (setDynFlag Opt_D_dump_rn_trace) )
+ , ( "ddump_rn_stats", NoArg (setDynFlag Opt_D_dump_rn_stats) )
+ , ( "ddump_stix", NoArg (setDynFlag Opt_D_dump_stix) )
+ , ( "ddump_simpl_stats", NoArg (setDynFlag Opt_D_dump_simpl_stats) )
+ , ( "dsource_stats", NoArg (setDynFlag Opt_D_source_stats) )
+ , ( "dverbose_core2core", NoArg (setDynFlag Opt_D_verbose_core2core) )
+ , ( "dverbose_stg2stg", NoArg (setDynFlag Opt_D_verbose_stg2stg) )
+ , ( "ddump_hi_diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs) )
+ , ( "ddump_minimal_imports", NoArg (setDynFlag Opt_D_dump_minimal_imports) )
+ , ( "DoCoreLinting", NoArg (setDynFlag Opt_DoCoreLinting) )
+ , ( "DoStgLinting", NoArg (setDynFlag Opt_DoStgLinting) )
+ , ( "DoUSPLinting", NoArg (setDynFlag Opt_DoUSPLinting) )
+
+ ------ Machine dependant (-m<blah>) stuff ---------------------------
+
+ , ( "monly-2-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 2}) ))
+ , ( "monly-3-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 3}) ))
+ , ( "monly-4-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 4}) ))
+
+ ------ Compiler flags -----------------------------------------------
+
+ , ( "fglasgow-exts", NoArg (setDynFlag Opt_GlasgowExts) )
+
+ , ( "fallow-overlapping-instances",
+ NoArg (setDynFlag Opt_AllowOverlappingInstances) )
+
+ , ( "fallow-undecidable-instances",
+ NoArg (setDynFlag Opt_AllowUndecidableInstances) )
+ ]
+
+-----------------------------------------------------------------------------
+-- convert sizes like "3.5M" into integers
+
+decodeSize :: String -> Integer
+decodeSize str
+ | c == "" = truncate n
+ | c == "K" || c == "k" = truncate (n * 1000)
+ | c == "M" || c == "m" = truncate (n * 1000 * 1000)
+ | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
+ | otherwise = throwDyn (OtherError ("can't decode size: " ++ str))
+ where (m, c) = span pred str
+ n = read m :: Double
+ pred c = isDigit c || c == '.'
+
+floatOpt :: IORef Double -> String -> IO ()
+floatOpt ref str
+ = writeIORef ref (read str :: Double)
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: DriverState.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+--
+-- Settings for the driver
+--
+-- (c) The University of Glasgow 2000
+--
+-----------------------------------------------------------------------------
+
+module DriverState where
+
+#include "HsVersions.h"
+
+import CmStaticInfo
+import CmdLineOpts
+import DriverUtil
+import Util
+import Config
+import Array
+
+import Exception
+import IOExts
+
+import System
+import IO
+import List
+import Char
+import Monad
+
+-----------------------------------------------------------------------------
+-- Driver state
+
+-- certain flags can be specified on a per-file basis, in an OPTIONS
+-- pragma at the beginning of the source file. This means that when
+-- compiling mulitple files, we have to restore the global option
+-- settings before compiling a new file.
+--
+-- The DriverState record contains the per-file-mutable state.
+
+data DriverState = DriverState {
+
+ -- are we runing cpp on this file?
+ cpp_flag :: Bool,
+
+ -- misc
+ stolen_x86_regs :: Int,
+ cmdline_hc_includes :: [String],
+
+ -- options for a particular phase
+ opt_L :: [String],
+ opt_P :: [String],
+ opt_c :: [String],
+ opt_a :: [String],
+ opt_m :: [String]
+ }
+
+initDriverState = DriverState {
+ cpp_flag = False,
+ stolen_x86_regs = 4,
+ cmdline_hc_includes = [],
+ opt_L = [],
+ opt_P = [],
+ opt_c = [],
+ opt_a = [],
+ opt_m = [],
+ }
+
+GLOBAL_VAR(driver_state, initDriverState, DriverState)
+
+readState :: (DriverState -> a) -> IO a
+readState f = readIORef driver_state >>= return . f
+
+updateState :: (DriverState -> DriverState) -> IO ()
+updateState f = readIORef driver_state >>= writeIORef driver_state . f
+
+addOpt_L a = updateState (\s -> s{opt_L = a : opt_L s})
+addOpt_P a = updateState (\s -> s{opt_P = a : opt_P s})
+addOpt_c a = updateState (\s -> s{opt_c = a : opt_c s})
+addOpt_a a = updateState (\s -> s{opt_a = a : opt_a s})
+addOpt_m a = updateState (\s -> s{opt_m = a : opt_m s})
+
+addCmdlineHCInclude a =
+ updateState (\s -> s{cmdline_hc_includes = a : cmdline_hc_includes s})
+
+ -- we add to the options from the front, so we need to reverse the list
+getOpts :: (DriverState -> [a]) -> IO [a]
+getOpts opts = readState opts >>= return . reverse
+
+-----------------------------------------------------------------------------
+-- non-configured things
+
+cHaskell1Version = "5" -- i.e., Haskell 98
+
+-----------------------------------------------------------------------------
+-- Global compilation flags
+
+-- Cpp-related flags
+hs_source_cpp_opts = global
+ [ "-D__HASKELL1__="++cHaskell1Version
+ , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
+ , "-D__HASKELL98__"
+ , "-D__CONCURRENT_HASKELL__"
+ ]
+
+-- Verbose
+GLOBAL_VAR(verbose, False, Bool)
+is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
+
+-- where to keep temporary files
+GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
+
+-- Keep output from intermediate phases
+GLOBAL_VAR(keep_hi_diffs, False, Bool)
+GLOBAL_VAR(keep_hc_files, False, Bool)
+GLOBAL_VAR(keep_s_files, False, Bool)
+GLOBAL_VAR(keep_raw_s_files, False, Bool)
+GLOBAL_VAR(keep_tmp_files, False, Bool)
+
+-- Misc
+GLOBAL_VAR(scale_sizes_by, 1.0, Double)
+GLOBAL_VAR(dry_run, False, Bool)
+#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
+GLOBAL_VAR(static, True, Bool)
+#else
+GLOBAL_VAR(static, False, Bool)
+#endif
+GLOBAL_VAR(recomp, True, Bool)
+GLOBAL_VAR(collect_ghc_timing, False, Bool)
+GLOBAL_VAR(do_asm_mangling, True, Bool)
+GLOBAL_VAR(excess_precision, False, Bool)
+
+-----------------------------------------------------------------------------
+-- Splitting object files (for libraries)
+
+GLOBAL_VAR(split_object_files, False, Bool)
+GLOBAL_VAR(split_prefix, "", String)
+GLOBAL_VAR(n_split_files, 0, Int)
+
+can_split :: Bool
+can_split = prefixMatch "i386" cTARGETPLATFORM
+ || prefixMatch "alpha" cTARGETPLATFORM
+ || prefixMatch "hppa" cTARGETPLATFORM
+ || prefixMatch "m68k" cTARGETPLATFORM
+ || prefixMatch "mips" cTARGETPLATFORM
+ || prefixMatch "powerpc" cTARGETPLATFORM
+ || prefixMatch "rs6000" cTARGETPLATFORM
+ || prefixMatch "sparc" cTARGETPLATFORM
+
+-----------------------------------------------------------------------------
+-- Compiler output options
+
+GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
+ (prefixMatch "i386" cTARGETPLATFORM ||
+ prefixMatch "sparc" cTARGETPLATFORM)
+ then HscAsm
+ else HscC,
+ HscLang)
+
+GLOBAL_VAR(output_dir, Nothing, Maybe String)
+GLOBAL_VAR(output_suf, Nothing, Maybe String)
+GLOBAL_VAR(output_file, Nothing, Maybe String)
+GLOBAL_VAR(output_hi, Nothing, Maybe String)
+
+GLOBAL_VAR(ld_inputs, [], [String])
+
+odir_ify :: String -> IO String
+odir_ify f = do
+ odir_opt <- readIORef output_dir
+ case odir_opt of
+ Nothing -> return f
+ Just d -> return (newdir d f)
+
+osuf_ify :: String -> IO String
+osuf_ify f = do
+ osuf_opt <- readIORef output_suf
+ case osuf_opt of
+ Nothing -> return f
+ Just s -> return (newsuf s f)
+
+-----------------------------------------------------------------------------
+-- Hi Files
+
+GLOBAL_VAR(produceHi, True, Bool)
+GLOBAL_VAR(hi_on_stdout, False, Bool)
+GLOBAL_VAR(hi_suf, "hi", String)
+
+-----------------------------------------------------------------------------
+-- Warnings & sanity checking
+
+-- Warning packages that are controlled by -W and -Wall. The 'standard'
+-- warnings that you get all the time are
+--
+-- -fwarn-overlapping-patterns
+-- -fwarn-missing-methods
+-- -fwarn-missing-fields
+-- -fwarn-deprecations
+-- -fwarn-duplicate-exports
+--
+-- these are turned off by -Wnot.
+
+
+standardWarnings = [ "-fwarn-overlapping-patterns"
+ , "-fwarn-missing-methods"
+ , "-fwarn-missing-fields"
+ , "-fwarn-deprecations"
+ , "-fwarn-duplicate-exports"
+ ]
+minusWOpts = standardWarnings ++
+ [ "-fwarn-unused-binds"
+ , "-fwarn-unused-matches"
+ , "-fwarn-incomplete-patterns"
+ , "-fwarn-unused-imports"
+ ]
+minusWallOpts = minusWOpts ++
+ [ "-fwarn-type-defaults"
+ , "-fwarn-name-shadowing"
+ , "-fwarn-missing-signatures"
+ , "-fwarn-hi-shadowing"
+ ]
+
+data WarningState = W_default | W_ | W_all | W_not
+GLOBAL_VAR(warning_opt, W_default, WarningState)
+
+-----------------------------------------------------------------------------
+-- Compiler optimisation options
+
+GLOBAL_VAR(opt_level, 0, Int)
+
+setOptLevel :: String -> IO ()
+setOptLevel "" = do { writeIORef opt_level 1; go_via_C }
+setOptLevel "not" = writeIORef opt_level 0
+setOptLevel [c] | isDigit c = do
+ let level = ord c - ord '0'
+ writeIORef opt_level level
+ when (level >= 1) go_via_C
+setOptLevel s = unknownFlagErr ("-O"++s)
+
+go_via_C = do
+ l <- readIORef hsc_lang
+ case l of { HscAsm -> writeIORef hsc_lang HscC;
+ _other -> return () }
+
+GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
+
+GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
+GLOBAL_VAR(opt_StgStats, False, Bool)
+GLOBAL_VAR(opt_UsageSPInf, False, Bool) -- Off by default
+GLOBAL_VAR(opt_Strictness, True, Bool)
+GLOBAL_VAR(opt_CPR, True, Bool)
+
+hsc_minusO2_flags = hsc_minusO_flags -- for now
+
+hsc_minusNoO_flags = do
+ iter <- readIORef opt_MaxSimplifierIterations
+ return [
+ "-fignore-interface-pragmas",
+ "-fomit-interface-pragmas"
+ ]
+
+hsc_minusO_flags = do
+ stgstats <- readIORef opt_StgStats
+
+ return [
+ "-ffoldr-build-on",
+ "-fdo-eta-reduction",
+ "-fdo-lambda-eta-expansion",
+ "-fcase-of-case",
+ "-fcase-merge",
+ "-flet-to-case"
+ ]
+
+build_CoreToDo
+ :: Int -- opt level
+ -> Int -- max iterations
+ -> Bool -- do usageSP
+ -> Bool -- do strictness
+ -> Bool -- do CPR
+ -> Bool -- do CSE
+ -> [CoreToDo]
+
+build_CoreToDo level max_iter usageSP strictness cpr cse
+ | level == 0 = [
+ CoreDoSimplify (isAmongSimpl [
+ MaxSimplifierIterations max_iter
+ ])
+ ]
+
+ | level >= 1 = [
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ CoreDoSimplify (isAmongSimpl [
+ SimplInlinePhase 0,
+ -- Don't inline anything till full laziness has bitten
+ -- In particular, inlining wrappers inhibits floating
+ -- e.g. ...(case f x of ...)...
+ -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ -- ==> ...(case x of I# x# -> case fw x# of ...)...
+ -- and now the redex (f x) isn't floatable any more
+ DontApplyRules,
+ -- Similarly, don't apply any rules until after full
+ -- laziness. Notably, list fusion can prevent floating.
+ NoCaseOfCase,
+ -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
+ MaxSimplifierIterations max_iter
+ ]),
+
+ -- Specialisation is best done before full laziness
+ -- so that overloaded functions have all their dictionary lambdas manifest
+ CoreDoSpecialising,
+
+ CoreDoFloatOutwards False{-not full-},
+ CoreDoFloatInwards,
+
+ CoreDoSimplify (isAmongSimpl [
+ SimplInlinePhase 1,
+ -- Want to run with inline phase 1 after the specialiser to give
+ -- maximum chance for fusion to work before we inline build/augment
+ -- in phase 2. This made a difference in 'ansi' where an
+ -- overloaded function wasn't inlined till too late.
+ MaxSimplifierIterations max_iter
+ ]),
+
+ -- infer usage information here in case we need it later.
+ -- (add more of these where you need them --KSW 1999-04)
+ if usageSP then CoreDoUSPInf else CoreDoNothing,
+
+ CoreDoSimplify (isAmongSimpl [
+ -- Need inline-phase2 here so that build/augment get
+ -- inlined. I found that spectral/hartel/genfft lost some useful
+ -- strictness in the function sumcode' if augment is not inlined
+ -- before strictness analysis runs
+ SimplInlinePhase 2,
+ MaxSimplifierIterations max_iter
+ ]),
+
+ CoreDoSimplify (isAmongSimpl [
+ MaxSimplifierIterations 2
+ -- No -finline-phase: allow all Ids to be inlined now
+ -- This gets foldr inlined before strictness analysis
+ ]),
+
+ if strictness then CoreDoStrictness else CoreDoNothing,
+ if cpr then CoreDoCPResult else CoreDoNothing,
+ CoreDoWorkerWrapper,
+ CoreDoGlomBinds,
+
+ CoreDoSimplify (isAmongSimpl [
+ MaxSimplifierIterations max_iter
+ -- No -finline-phase: allow all Ids to be inlined now
+ ]),
+
+ CoreDoFloatOutwards False{-not full-},
+ -- nofib/spectral/hartel/wang doubles in speed if you
+ -- do full laziness late in the day. It only happens
+ -- after fusion and other stuff, so the early pass doesn't
+ -- catch it. For the record, the redex is
+ -- f_el22 (f_el21 r_midblock)
+
+-- Leave out lambda lifting for now
+-- "-fsimplify", -- Tidy up results of full laziness
+-- "[",
+-- "-fmax-simplifier-iterations2",
+-- "]",
+-- "-ffloat-outwards-full",
+
+ -- We want CSE to follow the final full-laziness pass, because it may
+ -- succeed in commoning up things floated out by full laziness.
+ --
+ -- CSE must immediately follow a simplification pass, because it relies
+ -- on the no-shadowing invariant. See comments at the top of CSE.lhs
+ -- So it must NOT follow float-inwards, which can give rise to shadowing,
+ -- even if its input doesn't have shadows. Hence putting it between
+ -- the two passes.
+ if cse then CoreCSE else CoreDoNothing,
+
+ CoreDoFloatInwards,
+
+-- Case-liberation for -O2. This should be after
+-- strictness analysis and the simplification which follows it.
+
+-- ( ($OptLevel != 2)
+-- ? ""
+-- : "-fliberate-case -fsimplify [ $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MaxSimplifierIterations $Oopt_ShowSimplifierProgress ]" ),
+--
+-- "-fliberate-case",
+
+ -- Final clean-up simplification:
+ CoreDoSimplify (isAmongSimpl [
+ MaxSimplifierIterations max_iter
+ -- No -finline-phase: allow all Ids to be inlined now
+ ])
+ ]
+
+-----------------------------------------------------------------------------
+-- Paths & Libraries
+
+split_marker = ':' -- not configurable (ToDo)
+
+import_paths, include_paths, library_paths :: IORef [String]
+GLOBAL_VAR(import_paths, ["."], [String])
+GLOBAL_VAR(include_paths, ["."], [String])
+GLOBAL_VAR(library_paths, [], [String])
+
+GLOBAL_VAR(cmdline_libraries, [], [String])
+
+addToDirList :: IORef [String] -> String -> IO ()
+addToDirList ref path
+ = do paths <- readIORef ref
+ writeIORef ref (paths ++ split split_marker path)
+
+-----------------------------------------------------------------------------
+-- Packages
+
+GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
+
+-- package list is maintained in dependency order
+packages = global ["std", "rts", "gmp"] :: IORef [String]
+-- comma in value, so can't use macro, grrr
+{-# NOINLINE packages #-}
+
+addPackage :: String -> IO ()
+addPackage package
+ = do pkg_details <- readIORef package_details
+ case lookupPkg package pkg_details of
+ Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
+ Just details -> do
+ ps <- readIORef packages
+ unless (package `elem` ps) $ do
+ mapM_ addPackage (package_deps details)
+ ps <- readIORef packages
+ writeIORef packages (package:ps)
+
+getPackageImportPath :: IO [String]
+getPackageImportPath = do
+ ps <- readIORef packages
+ ps' <- getPackageDetails ps
+ return (nub (concat (map import_dirs ps')))
+
+getPackageIncludePath :: IO [String]
+getPackageIncludePath = do
+ ps <- readIORef packages
+ ps' <- getPackageDetails ps
+ return (nub (filter (not.null) (concatMap include_dirs ps')))
+
+ -- includes are in reverse dependency order (i.e. rts first)
+getPackageCIncludes :: IO [String]
+getPackageCIncludes = do
+ ps <- readIORef packages
+ ps' <- getPackageDetails ps
+ return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
+
+getPackageLibraryPath :: IO [String]
+getPackageLibraryPath = do
+ ps <- readIORef packages
+ ps' <- getPackageDetails ps
+ return (nub (concat (map library_dirs ps')))
+
+getPackageLibraries :: IO [String]
+getPackageLibraries = do
+ ps <- readIORef packages
+ ps' <- getPackageDetails ps
+ tag <- readIORef build_tag
+ let suffix = if null tag then "" else '_':tag
+ return (concat (
+ map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
+ ))
+
+getPackageExtraGhcOpts :: IO [String]
+getPackageExtraGhcOpts = do
+ ps <- readIORef packages
+ ps' <- getPackageDetails ps
+ return (concatMap extra_ghc_opts ps')
+
+getPackageExtraCcOpts :: IO [String]
+getPackageExtraCcOpts = do
+ ps <- readIORef packages
+ ps' <- getPackageDetails ps
+ return (concatMap extra_cc_opts ps')
+
+getPackageExtraLdOpts :: IO [String]
+getPackageExtraLdOpts = do
+ ps <- readIORef packages
+ ps' <- getPackageDetails ps
+ return (concatMap extra_ld_opts ps')
+
+getPackageDetails :: [String] -> IO [Package]
+getPackageDetails ps = do
+ pkg_details <- readIORef package_details
+ return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
+
+GLOBAL_VAR(package_details, (error "package_details"), [Package])
+
+lookupPkg :: String -> [Package] -> Maybe Package
+lookupPkg nm ps
+ = case [p | p <- ps, name p == nm] of
+ [] -> Nothing
+ (p:_) -> Just p
+-----------------------------------------------------------------------------
+-- Ways
+
+-- The central concept of a "way" is that all objects in a given
+-- program must be compiled in the same "way". Certain options change
+-- parameters of the virtual machine, eg. profiling adds an extra word
+-- to the object header, so profiling objects cannot be linked with
+-- non-profiling objects.
+
+-- After parsing the command-line options, we determine which "way" we
+-- are building - this might be a combination way, eg. profiling+ticky-ticky.
+
+-- We then find the "build-tag" associated with this way, and this
+-- becomes the suffix used to find .hi files and libraries used in
+-- this compilation.
+
+GLOBAL_VAR(build_tag, "", String)
+
+data WayName
+ = WayProf
+ | WayUnreg
+ | WayDll
+ | WayTicky
+ | WayPar
+ | WayGran
+ | WaySMP
+ | WayDebug
+ | WayUser_a
+ | WayUser_b
+ | WayUser_c
+ | WayUser_d
+ | WayUser_e
+ | WayUser_f
+ | WayUser_g
+ | WayUser_h
+ | WayUser_i
+ | WayUser_j
+ | WayUser_k
+ | WayUser_l
+ | WayUser_m
+ | WayUser_n
+ | WayUser_o
+ | WayUser_A
+ | WayUser_B
+ deriving (Eq,Ord)
+
+GLOBAL_VAR(ways, [] ,[WayName])
+
+-- ToDo: allow WayDll with any other allowed combination
+
+allowed_combinations =
+ [ [WayProf,WayUnreg],
+ [WayProf,WaySMP] -- works???
+ ]
+
+findBuildTag :: IO [String] -- new options
+findBuildTag = do
+ way_names <- readIORef ways
+ case sort way_names of
+ [] -> do writeIORef build_tag ""
+ return []
+
+ [w] -> do let details = lkupWay w
+ writeIORef build_tag (wayTag details)
+ return (wayOpts details)
+
+ ws -> if ws `notElem` allowed_combinations
+ then throwDyn (OtherError $
+ "combination not supported: " ++
+ foldr1 (\a b -> a ++ '/':b)
+ (map (wayName . lkupWay) ws))
+ else let stuff = map lkupWay ws
+ tag = concat (map wayTag stuff)
+ flags = map wayOpts stuff
+ in do
+ writeIORef build_tag tag
+ return (concat flags)
+
+lkupWay w =
+ case lookup w way_details of
+ Nothing -> error "findBuildTag"
+ Just details -> details
+
+data Way = Way {
+ wayTag :: String,
+ wayName :: String,
+ wayOpts :: [String]
+ }
+
+way_details :: [ (WayName, Way) ]
+way_details =
+ [ (WayProf, Way "p" "Profiling"
+ [ "-fscc-profiling"
+ , "-DPROFILING"
+ , "-optc-DPROFILING"
+ , "-fvia-C" ]),
+
+ (WayTicky, Way "t" "Ticky-ticky Profiling"
+ [ "-fticky-ticky"
+ , "-DTICKY_TICKY"
+ , "-optc-DTICKY_TICKY"
+ , "-fvia-C" ]),
+
+ (WayUnreg, Way "u" "Unregisterised"
+ [ "-optc-DNO_REGS"
+ , "-optc-DUSE_MINIINTERPRETER"
+ , "-fno-asm-mangling"
+ , "-funregisterised"
+ , "-fvia-C" ]),
+
+ (WayDll, Way "dll" "DLLized"
+ [ ]),
+
+ (WayPar, Way "mp" "Parallel"
+ [ "-fparallel"
+ , "-D__PARALLEL_HASKELL__"
+ , "-optc-DPAR"
+ , "-package concurrent"
+ , "-fvia-C" ]),
+
+ (WayGran, Way "mg" "Gransim"
+ [ "-fgransim"
+ , "-D__GRANSIM__"
+ , "-optc-DGRAN"
+ , "-package concurrent"
+ , "-fvia-C" ]),
+
+ (WaySMP, Way "s" "SMP"
+ [ "-fsmp"
+ , "-optc-pthread"
+ , "-optl-pthread"
+ , "-optc-DSMP"
+ , "-fvia-C" ]),
+
+ (WayUser_a, Way "a" "User way 'a'" ["$WAY_a_REAL_OPTS"]),
+ (WayUser_b, Way "b" "User way 'b'" ["$WAY_b_REAL_OPTS"]),
+ (WayUser_c, Way "c" "User way 'c'" ["$WAY_c_REAL_OPTS"]),
+ (WayUser_d, Way "d" "User way 'd'" ["$WAY_d_REAL_OPTS"]),
+ (WayUser_e, Way "e" "User way 'e'" ["$WAY_e_REAL_OPTS"]),
+ (WayUser_f, Way "f" "User way 'f'" ["$WAY_f_REAL_OPTS"]),
+ (WayUser_g, Way "g" "User way 'g'" ["$WAY_g_REAL_OPTS"]),
+ (WayUser_h, Way "h" "User way 'h'" ["$WAY_h_REAL_OPTS"]),
+ (WayUser_i, Way "i" "User way 'i'" ["$WAY_i_REAL_OPTS"]),
+ (WayUser_j, Way "j" "User way 'j'" ["$WAY_j_REAL_OPTS"]),
+ (WayUser_k, Way "k" "User way 'k'" ["$WAY_k_REAL_OPTS"]),
+ (WayUser_l, Way "l" "User way 'l'" ["$WAY_l_REAL_OPTS"]),
+ (WayUser_m, Way "m" "User way 'm'" ["$WAY_m_REAL_OPTS"]),
+ (WayUser_n, Way "n" "User way 'n'" ["$WAY_n_REAL_OPTS"]),
+ (WayUser_o, Way "o" "User way 'o'" ["$WAY_o_REAL_OPTS"]),
+ (WayUser_A, Way "A" "User way 'A'" ["$WAY_A_REAL_OPTS"]),
+ (WayUser_B, Way "B" "User way 'B'" ["$WAY_B_REAL_OPTS"])
+ ]
+
+-----------------------------------------------------------------------------
+-- Programs for particular phases
+
+GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String)
+GLOBAL_VAR(pgm_P, cRAWCPP, String)
+GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String)
+GLOBAL_VAR(pgm_c, cGCC, String)
+GLOBAL_VAR(pgm_m, findFile "ghc-asm" cGHC_MANGLER, String)
+GLOBAL_VAR(pgm_s, findFile "ghc-split" cGHC_SPLIT, String)
+GLOBAL_VAR(pgm_a, cGCC, String)
+GLOBAL_VAR(pgm_l, cGCC, String)
+
+GLOBAL_VAR(opt_dep, [], [String])
+GLOBAL_VAR(anti_opt_C, [], [String])
+GLOBAL_VAR(opt_C, [], [String])
+GLOBAL_VAR(opt_l, [], [String])
+GLOBAL_VAR(opt_dll, [], [String])
+
+-----------------------------------------------------------------------------
+-- Via-C compilation stuff
+
+-- flags returned are: ( all C compilations
+-- , registerised HC compilations
+-- )
+
+machdepCCOpts
+ | prefixMatch "alpha" cTARGETPLATFORM
+ = return ( ["-static"], [] )
+
+ | prefixMatch "hppa" cTARGETPLATFORM
+ -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
+ -- (very nice, but too bad the HP /usr/include files don't agree.)
+ = return ( ["-static", "-D_HPUX_SOURCE"], [] )
+
+ | prefixMatch "m68k" cTARGETPLATFORM
+ -- -fno-defer-pop : for the .hc files, we want all the pushing/
+ -- popping of args to routines to be explicit; if we let things
+ -- be deferred 'til after an STGJUMP, imminent death is certain!
+ --
+ -- -fomit-frame-pointer : *don't*
+ -- It's better to have a6 completely tied up being a frame pointer
+ -- rather than let GCC pick random things to do with it.
+ -- (If we want to steal a6, then we would try to do things
+ -- as on iX86, where we *do* steal the frame pointer [%ebp].)
+ = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
+
+ | prefixMatch "i386" cTARGETPLATFORM
+ -- -fno-defer-pop : basically the same game as for m68k
+ --
+ -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
+ -- the fp (%ebp) for our register maps.
+ = do n_regs <- readState stolen_x86_regs
+ sta <- readIORef static
+ return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
+ [ "-fno-defer-pop", "-fomit-frame-pointer",
+ "-DSTOLEN_X86_REGS="++show n_regs ]
+ )
+
+ | prefixMatch "mips" cTARGETPLATFORM
+ = return ( ["static"], [] )
+
+ | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
+ = return ( ["static"], ["-finhibit-size-directive"] )
+
+ | otherwise
+ = return ( [], [] )
+
+
+-----------------------------------------------------------------------------
+-- Running an external program
+
+run_something phase_name cmd
+ = do
+ verb <- readIORef verbose
+ when verb $ do
+ putStr phase_name
+ putStrLn ":"
+ putStrLn cmd
+ hFlush stdout
+
+ -- test for -n flag
+ n <- readIORef dry_run
+ unless n $ do
+
+ -- and run it!
+#ifndef mingw32_TARGET_OS
+ exit_code <- system cmd `catchAllIO`
+ (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+#else
+ tmp <- newTempName "sh"
+ h <- openFile tmp WriteMode
+ hPutStrLn h cmd
+ hClose h
+ exit_code <- system ("sh - " ++ tmp) `catchAllIO`
+ (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+ removeFile tmp
+#endif
+
+ if exit_code /= ExitSuccess
+ then throwDyn (PhaseFailed phase_name exit_code)
+ 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"
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: DriverUtil.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+--
+-- Utils for the driver
+--
+-- (c) The University of Glasgow 2000
+--
+-----------------------------------------------------------------------------
+
+module DriverUtil where
+
+#include "HsVersions.h"
+
+import Config
+import Util
+
+import IOExts
+import Exception
+import Dynamic
+
+import IO
+import System
+import Directory
+import List
+import Char
+import Monad
+
+-----------------------------------------------------------------------------
+-- Errors
+
+short_usage = "Usage: For basic information, try the `--help' option."
+
+long_usage = do
+ let usage_file = "ghc-usage.txt"
+ usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
+ usage <- readFile usage_path
+ dump usage
+ exitWith ExitSuccess
+ where
+ dump "" = return ()
+ dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
+ dump (c:s) = hPutChar stderr c >> dump s
+
+version_str = cProjectVersion
+
+data BarfKind
+ = PhaseFailed String ExitCode
+ | Interrupted
+ | UsageError String -- prints the short usage msg after the error
+ | OtherError String -- just prints the error message
+ deriving Eq
+
+GLOBAL_VAR(prog_name, "ghc", String)
+
+get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
+
+instance Show BarfKind where
+ showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
+
+showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
+showBarf (OtherError str) = showString str
+showBarf (PhaseFailed phase code) =
+ showString phase . showString " failed, code = " . shows code
+showBarf (Interrupted) = showString "interrupted"
+
+unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
+
+barfKindTc = mkTyCon "BarfKind"
+instance Typeable BarfKind where
+ typeOf _ = mkAppTy barfKindTc []
+
+-----------------------------------------------------------------------------
+-- Finding files in the installation
+
+GLOBAL_VAR(topDir, clibdir, String)
+
+ -- grab the last -B option on the command line, and
+ -- set topDir to its value.
+setTopDir :: [String] -> IO [String]
+setTopDir args = do
+ let (minusbs, others) = partition (prefixMatch "-B") args
+ (case minusbs of
+ [] -> writeIORef topDir clibdir
+ some -> writeIORef topDir (drop 2 (last some)))
+ return others
+
+findFile name alt_path = unsafePerformIO (do
+ top_dir <- readIORef topDir
+ let installed_file = top_dir ++ '/':name
+ let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
+ b <- doesFileExist inplace_file
+ if b then return inplace_file
+ else return installed_file
+ )
+
+-----------------------------------------------------------------------------
+-- Utils
+
+my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
+my_partition _ [] = ([],[])
+my_partition p (a:as)
+ = let (bs,cs) = my_partition p as in
+ case p a of
+ Nothing -> (bs,a:cs)
+ Just b -> ((a,b):bs,cs)
+
+my_prefix_match :: String -> String -> Maybe String
+my_prefix_match [] rest = Just rest
+my_prefix_match (_:_) [] = Nothing
+my_prefix_match (p:pat) (r:rest)
+ | p == r = my_prefix_match pat rest
+ | otherwise = Nothing
+
+prefixMatch :: Eq a => [a] -> [a] -> Bool
+prefixMatch [] _str = True
+prefixMatch _pat [] = False
+prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
+ | otherwise = False
+
+postfixMatch :: String -> String -> Bool
+postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
+
+later = flip finally
+
+handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
+handleDyn = flip catchDyn
+
+split :: Char -> String -> [String]
+split c s = case rest of
+ [] -> [chunk]
+ _:rest -> chunk : split c rest
+ where (chunk, rest) = break (==c) s
+
+add :: IORef [a] -> a -> IO ()
+add var x = do
+ xs <- readIORef var
+ writeIORef var (x:xs)
+
+addNoDups :: Eq a => IORef [a] -> a -> IO ()
+addNoDups var x = do
+ xs <- readIORef var
+ unless (x `elem` xs) $ writeIORef var (x:xs)
+
+remove_suffix :: Char -> String -> String
+remove_suffix c s
+ | null pre = reverse suf
+ | otherwise = reverse pre
+ where (suf,pre) = break (==c) (reverse s)
+
+drop_longest_prefix :: String -> Char -> String
+drop_longest_prefix s c = reverse suf
+ where (suf,_pre) = break (==c) (reverse s)
+
+take_longest_prefix :: String -> Char -> String
+take_longest_prefix s c = reverse pre
+ where (_suf,pre) = break (==c) (reverse s)
+
+newsuf :: String -> String -> String
+newsuf suf s = remove_suffix '.' s ++ suf
+
+-- getdir strips the filename off the input string, returning the directory.
+getdir :: String -> String
+getdir s = if null dir then "." else init dir
+ where dir = take_longest_prefix s '/'
+
+newdir :: String -> String -> String
+newdir dir s = dir ++ '/':drop_longest_prefix s '/'
+
+remove_spaces :: String -> String
+remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+booter_version
+ = case "\
+ \ __GLASGOW_HASKELL__" of
+ ' ':n:ns -> n:'.':ns
+ ' ':m -> m
+
\end{code}
\begin{code}
-compiler_version :: String
-compiler_version =
- case (show opt_HiVersion) of
- [x] -> ['0','.',x]
- ls@[x,y] -> "0." ++ ls
- ls -> go ls
- where
- -- 10232353 => 10232.53
- go ls@[x,y] = '.':ls
- go (x:xs) = x:go xs
-
-booter_version
- = case "\
- \ __GLASGOW_HASKELL__" of
- ' ':n:ns -> n:'.':ns
- ' ':m -> m
\end{code}
\begin{code}
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.1 2000/10/10 13:25:19 simonmar Exp $
+-- $Id: Main.hs,v 1.2 2000/10/11 11:54:58 simonmar Exp $
--
-- GHC Driver program
--
module Main (main) where
+#include "HsVersions.h"
+
import CmSummarise ( getImports )
import CmStaticInfo ( Package(..) )
import TmpFiles
import Config
+import CmdLineOpts
+import Util ( global )
import RegexString
import Concurrent
import Char
-----------------------------------------------------------------------------
+-- Changes:
+
+-- * -fglasgow-exts NO LONGER IMPLIES -package lang!!! (-fglasgow-exts is a
+-- dynamic flag whereas -package is a static flag.)
+
+-----------------------------------------------------------------------------
-- ToDo:
-- certain options in OPTIONS pragmas are persistent through subsequent compilations.
-- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
-- reading the package configuration file is too slow
-- -H, -K, -Rghc-timing
+-- hi-diffs
-----------------------------------------------------------------------------
-- Differences vs. old driver:
-- no -Ofile
-----------------------------------------------------------------------------
--- non-configured things
-
-cHaskell1Version = "5" -- i.e., Haskell 98
-
------------------------------------------------------------------------------
--- Usage Message
-
-short_usage = "Usage: For basic information, try the `--help' option."
-
-long_usage = do
- let usage_file = "ghc-usage.txt"
- usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
- usage <- readFile usage_path
- dump usage
- exitWith ExitSuccess
- where
- dump "" = return ()
- dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
- dump (c:s) = hPutChar stderr c >> dump s
-
-version_str = cProjectVersion
-
------------------------------------------------------------------------------
--- Driver state
-
--- certain flags can be specified on a per-file basis, in an OPTIONS
--- pragma at the beginning of the source file. This means that when
--- compiling mulitple files, we have to restore the global option
--- settings before compiling a new file.
---
--- The DriverState record contains the per-file-mutable state.
-
-data DriverState = DriverState {
-
- -- are we runing cpp on this file?
- cpp_flag :: Bool,
-
- -- heap/stack sizes
- specific_heap_size :: Integer,
- specific_stack_size :: Integer,
-
- -- misc
- stolen_x86_regs :: Int,
- excess_precision :: Bool,
- warning_opt :: WarningState,
- cmdline_hc_includes :: [String],
-
- -- options for a particular phase
- anti_opt_C :: [String],
- opt_dep :: [String],
- opt_L :: [String],
- opt_P :: [String],
- opt_C :: [String],
- opt_c :: [String],
- opt_a :: [String],
- opt_m :: [String],
- opt_l :: [String],
- opt_dll :: [String]
- }
-
-initDriverState = DriverState {
- cpp_flag = False,
- specific_heap_size = 6 * 1000 * 1000,
- specific_stack_size = 1000 * 1000,
- stolen_x86_regs = 4,
- excess_precision = False,
- warning_opt = W_default,
- cmdline_hc_includes = [],
- anti_opt_C = [],
- opt_dep = [],
- opt_L = [],
- opt_P = [],
- opt_C = [],
- opt_c = [],
- opt_a = [],
- opt_m = [],
- opt_l = [],
- opt_dll = []
- }
-
-GLOBAL_VAR(driver_state, initDriverState, DriverState)
-
-readState :: (DriverState -> a) -> IO a
-readState f = readIORef driver_state >>= return . f
-
-updateState :: (DriverState -> DriverState) -> IO ()
-updateState f = readIORef driver_state >>= writeIORef driver_state . f
-
-addAntiOpt_C a = updateState (\s -> s{anti_opt_C = a : anti_opt_C s})
-addOpt_dep a = updateState (\s -> s{opt_dep = a : opt_dep s})
-addOpt_L a = updateState (\s -> s{opt_L = a : opt_L s})
-addOpt_P a = updateState (\s -> s{opt_P = a : opt_P s})
-addOpt_C a = updateState (\s -> s{opt_C = a : opt_C s})
-addOpt_c a = updateState (\s -> s{opt_c = a : opt_c s})
-addOpt_a a = updateState (\s -> s{opt_a = a : opt_a s})
-addOpt_m a = updateState (\s -> s{opt_m = a : opt_m s})
-addOpt_l a = updateState (\s -> s{opt_l = a : opt_l s})
-addOpt_dll a = updateState (\s -> s{opt_dll = a : opt_dll s})
-
-addCmdlineHCInclude a =
- updateState (\s -> s{cmdline_hc_includes = a : cmdline_hc_includes s})
-
- -- we add to the options from the front, so we need to reverse the list
-getOpts :: (DriverState -> [a]) -> IO [a]
-getOpts opts = readState opts >>= return . reverse
-
-newHeapSize :: Integer -> IO ()
-newHeapSize new = updateState
- (\s -> let current = specific_heap_size s in
- s{ specific_heap_size = if new > current then new else current })
-
-newStackSize :: Integer -> IO ()
-newStackSize new = updateState
- (\s -> let current = specific_stack_size s in
- s{ specific_stack_size = if new > current then new else current })
-
------------------------------------------------------------------------------
-- Phases
{-
deriving (Eq)
-----------------------------------------------------------------------------
--- Errors
-
-data BarfKind
- = PhaseFailed String ExitCode
- | Interrupted
- | UsageError String -- prints the short usage msg after the error
- | OtherError String -- just prints the error message
- deriving Eq
-
-GLOBAL_VAR(prog_name, "ghc", String)
-
-get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
-
-instance Show BarfKind where
- showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
-
-showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
-showBarf (OtherError str) = showString str
-showBarf (PhaseFailed phase code) =
- showString phase . showString " failed, code = " . shows code
-showBarf (Interrupted) = showString "interrupted"
-
-unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
-
-barfKindTc = mkTyCon "BarfKind"
-instance Typeable BarfKind where
- typeOf _ = mkAppTy barfKindTc []
-
------------------------------------------------------------------------------
--- Global compilation flags
-
-
- -- Cpp-related flags
-hs_source_cpp_opts = global
- [ "-D__HASKELL1__="++cHaskell1Version
- , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
- , "-D__HASKELL98__"
- , "-D__CONCURRENT_HASKELL__"
- ]
-
- -- Verbose
-GLOBAL_VAR(verbose, False, Bool)
-is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
-
- -- Keep output from intermediate phases
-GLOBAL_VAR(keep_hi_diffs, False, Bool)
-GLOBAL_VAR(keep_hc_files, False, Bool)
-GLOBAL_VAR(keep_s_files, False, Bool)
-GLOBAL_VAR(keep_raw_s_files, False, Bool)
-GLOBAL_VAR(keep_tmp_files, False, Bool)
-
- -- Misc
-GLOBAL_VAR(scale_sizes_by, 1.0, Double)
-GLOBAL_VAR(dry_run, False, Bool)
-#if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
-GLOBAL_VAR(static, True, Bool)
-#else
-GLOBAL_VAR(static, False, Bool)
-#endif
-GLOBAL_VAR(collect_ghc_timing, False, Bool)
-GLOBAL_VAR(do_asm_mangling, True, Bool)
-
------------------------------------------------------------------------------
--- Splitting object files (for libraries)
-
-GLOBAL_VAR(split_object_files, False, Bool)
-GLOBAL_VAR(split_prefix, "", String)
-GLOBAL_VAR(n_split_files, 0, Int)
-
-can_split :: Bool
-can_split = prefixMatch "i386" cTARGETPLATFORM
- || prefixMatch "alpha" cTARGETPLATFORM
- || prefixMatch "hppa" cTARGETPLATFORM
- || prefixMatch "m68k" cTARGETPLATFORM
- || prefixMatch "mips" cTARGETPLATFORM
- || prefixMatch "powerpc" cTARGETPLATFORM
- || prefixMatch "rs6000" cTARGETPLATFORM
- || prefixMatch "sparc" cTARGETPLATFORM
-
------------------------------------------------------------------------------
--- Compiler output options
-
-data HscLang
- = HscC
- | HscAsm
- | HscJava
- deriving Eq
-
-GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
- (prefixMatch "i386" cTARGETPLATFORM ||
- prefixMatch "sparc" cTARGETPLATFORM)
- then HscAsm
- else HscC,
- HscLang)
-
-GLOBAL_VAR(output_dir, Nothing, Maybe String)
-GLOBAL_VAR(output_suf, Nothing, Maybe String)
-GLOBAL_VAR(output_file, Nothing, Maybe String)
-GLOBAL_VAR(output_hi, Nothing, Maybe String)
-
-GLOBAL_VAR(ld_inputs, [], [String])
-
-odir_ify :: String -> IO String
-odir_ify f = do
- odir_opt <- readIORef output_dir
- case odir_opt of
- Nothing -> return f
- Just d -> return (newdir d f)
-
-osuf_ify :: String -> IO String
-osuf_ify f = do
- osuf_opt <- readIORef output_suf
- case osuf_opt of
- Nothing -> return f
- Just s -> return (newsuf s f)
-
------------------------------------------------------------------------------
--- Hi Files
-
-GLOBAL_VAR(produceHi, True, Bool)
-GLOBAL_VAR(hi_on_stdout, False, Bool)
-GLOBAL_VAR(hi_with, "", String)
-GLOBAL_VAR(hi_suf, "hi", String)
-
-data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs
-GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag)
-
------------------------------------------------------------------------------
--- Warnings & sanity checking
-
--- Warning packages that are controlled by -W and -Wall. The 'standard'
--- warnings that you get all the time are
---
--- -fwarn-overlapping-patterns
--- -fwarn-missing-methods
--- -fwarn-missing-fields
--- -fwarn-deprecations
--- -fwarn-duplicate-exports
---
--- these are turned off by -Wnot.
-
-standardWarnings = [ "-fwarn-overlapping-patterns"
- , "-fwarn-missing-methods"
- , "-fwarn-missing-fields"
- , "-fwarn-deprecations"
- , "-fwarn-duplicate-exports"
- ]
-minusWOpts = standardWarnings ++
- [ "-fwarn-unused-binds"
- , "-fwarn-unused-matches"
- , "-fwarn-incomplete-patterns"
- , "-fwarn-unused-imports"
- ]
-minusWallOpts = minusWOpts ++
- [ "-fwarn-type-defaults"
- , "-fwarn-name-shadowing"
- , "-fwarn-missing-signatures"
- , "-fwarn-hi-shadowing"
- ]
-
-data WarningState = W_default | W_ | W_all | W_not
-
------------------------------------------------------------------------------
--- Compiler optimisation options
-
-GLOBAL_VAR(opt_level, 0, Int)
-
-setOptLevel :: String -> IO ()
-setOptLevel "" = do { writeIORef opt_level 1; go_via_C }
-setOptLevel "not" = writeIORef opt_level 0
-setOptLevel [c] | isDigit c = do
- let level = ord c - ord '0'
- writeIORef opt_level level
- when (level >= 1) go_via_C
-setOptLevel s = unknownFlagErr ("-O"++s)
-
-go_via_C = do
- l <- readIORef hsc_lang
- case l of { HscAsm -> writeIORef hsc_lang HscC;
- _other -> return () }
-
-GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
-
-GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
-GLOBAL_VAR(opt_StgStats, False, Bool)
-GLOBAL_VAR(opt_UsageSPInf, False, Bool) -- Off by default
-
-hsc_minusO2_flags = hsc_minusO_flags -- for now
-
-hsc_minusNoO_flags = do
- iter <- readIORef opt_MaxSimplifierIterations
- return [
- "-fignore-interface-pragmas",
- "-fomit-interface-pragmas",
- "-fsimplify",
- "[",
- "-fmax-simplifier-iterations" ++ show iter,
- "]"
- ]
-
-hsc_minusO_flags = do
- iter <- readIORef opt_MaxSimplifierIterations
- usageSP <- readIORef opt_UsageSPInf
- stgstats <- readIORef opt_StgStats
-
- return [
- "-ffoldr-build-on",
-
- "-fdo-eta-reduction",
- "-fdo-lambda-eta-expansion",
- "-fcase-of-case",
- "-fcase-merge",
- "-flet-to-case",
-
- -- initial simplify: mk specialiser happy: minimum effort please
-
- "-fsimplify",
- "[",
- "-finline-phase0",
- -- Don't inline anything till full laziness has bitten
- -- In particular, inlining wrappers inhibits floating
- -- e.g. ...(case f x of ...)...
- -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
- -- ==> ...(case x of I# x# -> case fw x# of ...)...
- -- and now the redex (f x) isn't floatable any more
-
- "-fno-rules",
- -- Similarly, don't apply any rules until after full
- -- laziness. Notably, list fusion can prevent floating.
-
- "-fno-case-of-case",
- -- Don't do case-of-case transformations.
- -- This makes full laziness work better
-
- "-fmax-simplifier-iterations2",
- "]",
-
- -- Specialisation is best done before full laziness
- -- so that overloaded functions have all their dictionary lambdas manifest
- "-fspecialise",
-
- "-ffloat-outwards",
- "-ffloat-inwards",
-
- "-fsimplify",
- "[",
- "-finline-phase1",
- -- Want to run with inline phase 1 after the specialiser to give
- -- maximum chance for fusion to work before we inline build/augment
- -- in phase 2. This made a difference in 'ansi' where an
- -- overloaded function wasn't inlined till too late.
- "-fmax-simplifier-iterations" ++ show iter,
- "]",
-
- -- infer usage information here in case we need it later.
- -- (add more of these where you need them --KSW 1999-04)
- if usageSP then "-fusagesp" else "",
-
- "-fsimplify",
- "[",
- -- Need inline-phase2 here so that build/augment get
- -- inlined. I found that spectral/hartel/genfft lost some useful
- -- strictness in the function sumcode' if augment is not inlined
- -- before strictness analysis runs
-
- "-finline-phase2",
- "-fmax-simplifier-iterations2",
- "]",
-
- "-fsimplify",
- "[",
- "-fmax-simplifier-iterations2",
- -- No -finline-phase: allow all Ids to be inlined now
- -- This gets foldr inlined before strictness analysis
- "]",
-
- "-fstrictness",
- "-fcpr-analyse",
- "-fworker-wrapper",
- "-fglom-binds",
-
- "-fsimplify",
- "[",
- "-fmax-simplifier-iterations" ++ show iter,
- -- No -finline-phase: allow all Ids to be inlined now
- "]",
-
- "-ffloat-outwards",
- -- nofib/spectral/hartel/wang doubles in speed if you
- -- do full laziness late in the day. It only happens
- -- after fusion and other stuff, so the early pass doesn't
- -- catch it. For the record, the redex is
- -- f_el22 (f_el21 r_midblock)
-
--- Leave out lambda lifting for now
--- "-fsimplify", -- Tidy up results of full laziness
--- "[",
--- "-fmax-simplifier-iterations2",
--- "]",
--- "-ffloat-outwards-full",
-
- -- We want CSE to follow the final full-laziness pass, because it may
- -- succeed in commoning up things floated out by full laziness.
- --
- -- CSE must immediately follow a simplification pass, because it relies
- -- on the no-shadowing invariant. See comments at the top of CSE.lhs
- -- So it must NOT follow float-inwards, which can give rise to shadowing,
- -- even if its input doesn't have shadows. Hence putting it between
- -- the two passes.
- "-fcse",
-
-
- "-ffloat-inwards",
-
--- Case-liberation for -O2. This should be after
--- strictness analysis and the simplification which follows it.
-
--- ( ($OptLevel != 2)
--- ? ""
--- : "-fliberate-case -fsimplify [ $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MaxSimplifierIterations $Oopt_ShowSimplifierProgress ]" ),
---
--- "-fliberate-case",
-
- -- Final clean-up simplification:
- "-fsimplify",
- "[",
- "-fmax-simplifier-iterations" ++ show iter,
- -- No -finline-phase: allow all Ids to be inlined now
- "]"
-
- ]
-
------------------------------------------------------------------------------
--- Paths & Libraries
-
-split_marker = ':' -- not configurable (ToDo)
-
-import_paths, include_paths, library_paths :: IORef [String]
-GLOBAL_VAR(import_paths, ["."], [String])
-GLOBAL_VAR(include_paths, ["."], [String])
-GLOBAL_VAR(library_paths, [], [String])
-
-GLOBAL_VAR(cmdline_libraries, [], [String])
-
-addToDirList :: IORef [String] -> String -> IO ()
-addToDirList ref path
- = do paths <- readIORef ref
- writeIORef ref (paths ++ split split_marker path)
-
------------------------------------------------------------------------------
--- Packages
-
-GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
-
-listPackages :: IO ()
-listPackages = do
- details <- readIORef package_details
- hPutStr stdout (listPkgs details)
- hPutChar stdout '\n'
- exitWith ExitSuccess
-
-newPackage :: IO ()
-newPackage = do
- checkConfigAccess
- details <- readIORef package_details
- hPutStr stdout "Reading package info from stdin... "
- stuff <- getContents
- let new_pkg = read stuff :: Package
- catchAll new_pkg
- (\_ -> throwDyn (OtherError "parse error in package info"))
- hPutStrLn stdout "done."
- if (name new_pkg `elem` map name details)
- then throwDyn (OtherError ("package `" ++ name new_pkg ++
- "' already installed"))
- else do
- conf_file <- readIORef package_config
- savePackageConfig conf_file
- maybeRestoreOldConfig conf_file $ do
- writeNewConfig conf_file ( ++ [new_pkg])
- exitWith ExitSuccess
-
-deletePackage :: String -> IO ()
-deletePackage pkg = do
- checkConfigAccess
- details <- readIORef package_details
- if (pkg `notElem` map name details)
- then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
- else do
- conf_file <- readIORef package_config
- savePackageConfig conf_file
- maybeRestoreOldConfig conf_file $ do
- writeNewConfig conf_file (filter ((/= pkg) . name))
- exitWith ExitSuccess
-
-checkConfigAccess :: IO ()
-checkConfigAccess = do
- conf_file <- readIORef package_config
- access <- getPermissions conf_file
- unless (writable access)
- (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
-
-maybeRestoreOldConfig :: String -> IO () -> IO ()
-maybeRestoreOldConfig conf_file io
- = catchAllIO io (\e -> do
- hPutStr stdout "\nWARNING: an error was encountered while the new \n\
- \configuration was being written. Attempting to \n\
- \restore the old configuration... "
- system ("cp " ++ conf_file ++ ".old " ++ conf_file)
- hPutStrLn stdout "done."
- throw e
- )
-
-writeNewConfig :: String -> ([Package] -> [Package]) -> IO ()
-writeNewConfig conf_file fn = do
- hPutStr stdout "Writing new package config file... "
- old_details <- readIORef package_details
- h <- openFile conf_file WriteMode
- hPutStr h (dumpPackages (fn old_details))
- hClose h
- hPutStrLn stdout "done."
-
-savePackageConfig :: String -> IO ()
-savePackageConfig conf_file = do
- hPutStr stdout "Saving old package config file... "
- -- mv rather than cp because we've already done an hGetContents
- -- on this file so we won't be able to open it for writing
- -- unless we move the old one out of the way...
- system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
- hPutStrLn stdout "done."
-
--- package list is maintained in dependency order
-packages = global ["std", "rts", "gmp"] :: IORef [String]
--- comma in value, so can't use macro, grrr
-{-# NOINLINE packages #-}
-
-addPackage :: String -> IO ()
-addPackage package
- = do pkg_details <- readIORef package_details
- case lookupPkg package pkg_details of
- Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
- Just details -> do
- ps <- readIORef packages
- unless (package `elem` ps) $ do
- mapM_ addPackage (package_deps details)
- ps <- readIORef packages
- writeIORef packages (package:ps)
-
-getPackageImportPath :: IO [String]
-getPackageImportPath = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (nub (concat (map import_dirs ps')))
-
-getPackageIncludePath :: IO [String]
-getPackageIncludePath = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (nub (filter (not.null) (concatMap include_dirs ps')))
-
- -- includes are in reverse dependency order (i.e. rts first)
-getPackageCIncludes :: IO [String]
-getPackageCIncludes = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
-
-getPackageLibraryPath :: IO [String]
-getPackageLibraryPath = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (nub (concat (map library_dirs ps')))
-
-getPackageLibraries :: IO [String]
-getPackageLibraries = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- tag <- readIORef build_tag
- let suffix = if null tag then "" else '_':tag
- return (concat (
- map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
- ))
-
-getPackageExtraGhcOpts :: IO [String]
-getPackageExtraGhcOpts = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (concatMap extra_ghc_opts ps')
-
-getPackageExtraCcOpts :: IO [String]
-getPackageExtraCcOpts = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (concatMap extra_cc_opts ps')
-
-getPackageExtraLdOpts :: IO [String]
-getPackageExtraLdOpts = do
- ps <- readIORef packages
- ps' <- getPackageDetails ps
- return (concatMap extra_ld_opts ps')
-
-getPackageDetails :: [String] -> IO [Package]
-getPackageDetails ps = do
- pkg_details <- readIORef package_details
- return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
-
-GLOBAL_VAR(package_details, (error "package_details"), [Package])
-
-lookupPkg :: String -> [Package] -> Maybe Package
-lookupPkg nm ps
- = case [p | p <- ps, name p == nm] of
- [] -> Nothing
- (p:_) -> Just p
-
------------------------------------------------------------------------------
--- Ways
-
--- The central concept of a "way" is that all objects in a given
--- program must be compiled in the same "way". Certain options change
--- parameters of the virtual machine, eg. profiling adds an extra word
--- to the object header, so profiling objects cannot be linked with
--- non-profiling objects.
-
--- After parsing the command-line options, we determine which "way" we
--- are building - this might be a combination way, eg. profiling+ticky-ticky.
-
--- We then find the "build-tag" associated with this way, and this
--- becomes the suffix used to find .hi files and libraries used in
--- this compilation.
-
-GLOBAL_VAR(build_tag, "", String)
-
-data WayName
- = WayProf
- | WayUnreg
- | WayDll
- | WayTicky
- | WayPar
- | WayGran
- | WaySMP
- | WayDebug
- | WayUser_a
- | WayUser_b
- | WayUser_c
- | WayUser_d
- | WayUser_e
- | WayUser_f
- | WayUser_g
- | WayUser_h
- | WayUser_i
- | WayUser_j
- | WayUser_k
- | WayUser_l
- | WayUser_m
- | WayUser_n
- | WayUser_o
- | WayUser_A
- | WayUser_B
- deriving (Eq,Ord)
-
-GLOBAL_VAR(ways, [] ,[WayName])
-
--- ToDo: allow WayDll with any other allowed combination
-
-allowed_combinations =
- [ [WayProf,WayUnreg],
- [WayProf,WaySMP] -- works???
- ]
-
-findBuildTag :: IO [String] -- new options
-findBuildTag = do
- way_names <- readIORef ways
- case sort way_names of
- [] -> do writeIORef build_tag ""
- return []
-
- [w] -> do let details = lkupWay w
- writeIORef build_tag (wayTag details)
- return (wayOpts details)
-
- ws -> if ws `notElem` allowed_combinations
- then throwDyn (OtherError $
- "combination not supported: " ++
- foldr1 (\a b -> a ++ '/':b)
- (map (wayName . lkupWay) ws))
- else let stuff = map lkupWay ws
- tag = concat (map wayTag stuff)
- flags = map wayOpts stuff
- in do
- writeIORef build_tag tag
- return (concat flags)
-
-lkupWay w =
- case lookup w way_details of
- Nothing -> error "findBuildTag"
- Just details -> details
-
-data Way = Way {
- wayTag :: String,
- wayName :: String,
- wayOpts :: [String]
- }
-
-way_details :: [ (WayName, Way) ]
-way_details =
- [ (WayProf, Way "p" "Profiling"
- [ "-fscc-profiling"
- , "-DPROFILING"
- , "-optc-DPROFILING"
- , "-fvia-C" ]),
-
- (WayTicky, Way "t" "Ticky-ticky Profiling"
- [ "-fticky-ticky"
- , "-DTICKY_TICKY"
- , "-optc-DTICKY_TICKY"
- , "-fvia-C" ]),
-
- (WayUnreg, Way "u" "Unregisterised"
- [ "-optc-DNO_REGS"
- , "-optc-DUSE_MINIINTERPRETER"
- , "-fno-asm-mangling"
- , "-funregisterised"
- , "-fvia-C" ]),
-
- (WayDll, Way "dll" "DLLized"
- [ ]),
-
- (WayPar, Way "mp" "Parallel"
- [ "-fparallel"
- , "-D__PARALLEL_HASKELL__"
- , "-optc-DPAR"
- , "-package concurrent"
- , "-fvia-C" ]),
-
- (WayGran, Way "mg" "Gransim"
- [ "-fgransim"
- , "-D__GRANSIM__"
- , "-optc-DGRAN"
- , "-package concurrent"
- , "-fvia-C" ]),
-
- (WaySMP, Way "s" "SMP"
- [ "-fsmp"
- , "-optc-pthread"
- , "-optl-pthread"
- , "-optc-DSMP"
- , "-fvia-C" ]),
-
- (WayUser_a, Way "a" "User way 'a'" ["$WAY_a_REAL_OPTS"]),
- (WayUser_b, Way "b" "User way 'b'" ["$WAY_b_REAL_OPTS"]),
- (WayUser_c, Way "c" "User way 'c'" ["$WAY_c_REAL_OPTS"]),
- (WayUser_d, Way "d" "User way 'd'" ["$WAY_d_REAL_OPTS"]),
- (WayUser_e, Way "e" "User way 'e'" ["$WAY_e_REAL_OPTS"]),
- (WayUser_f, Way "f" "User way 'f'" ["$WAY_f_REAL_OPTS"]),
- (WayUser_g, Way "g" "User way 'g'" ["$WAY_g_REAL_OPTS"]),
- (WayUser_h, Way "h" "User way 'h'" ["$WAY_h_REAL_OPTS"]),
- (WayUser_i, Way "i" "User way 'i'" ["$WAY_i_REAL_OPTS"]),
- (WayUser_j, Way "j" "User way 'j'" ["$WAY_j_REAL_OPTS"]),
- (WayUser_k, Way "k" "User way 'k'" ["$WAY_k_REAL_OPTS"]),
- (WayUser_l, Way "l" "User way 'l'" ["$WAY_l_REAL_OPTS"]),
- (WayUser_m, Way "m" "User way 'm'" ["$WAY_m_REAL_OPTS"]),
- (WayUser_n, Way "n" "User way 'n'" ["$WAY_n_REAL_OPTS"]),
- (WayUser_o, Way "o" "User way 'o'" ["$WAY_o_REAL_OPTS"]),
- (WayUser_A, Way "A" "User way 'A'" ["$WAY_A_REAL_OPTS"]),
- (WayUser_B, Way "B" "User way 'B'" ["$WAY_B_REAL_OPTS"])
- ]
-
------------------------------------------------------------------------------
--- Programs for particular phases
-
-GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String)
-GLOBAL_VAR(pgm_P, cRAWCPP, String)
-GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String)
-GLOBAL_VAR(pgm_c, cGCC, String)
-GLOBAL_VAR(pgm_m, findFile "ghc-asm" cGHC_MANGLER, String)
-GLOBAL_VAR(pgm_s, findFile "ghc-split" cGHC_SPLIT, String)
-GLOBAL_VAR(pgm_a, cGCC, String)
-GLOBAL_VAR(pgm_l, cGCC, String)
-
------------------------------------------------------------------------------
--- Via-C compilation stuff
-
--- flags returned are: ( all C compilations
--- , registerised HC compilations
--- )
-
-machdepCCOpts
- | prefixMatch "alpha" cTARGETPLATFORM
- = return ( ["-static"], [] )
-
- | prefixMatch "hppa" cTARGETPLATFORM
- -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
- -- (very nice, but too bad the HP /usr/include files don't agree.)
- = return ( ["-static", "-D_HPUX_SOURCE"], [] )
-
- | prefixMatch "m68k" cTARGETPLATFORM
- -- -fno-defer-pop : for the .hc files, we want all the pushing/
- -- popping of args to routines to be explicit; if we let things
- -- be deferred 'til after an STGJUMP, imminent death is certain!
- --
- -- -fomit-frame-pointer : *don't*
- -- It's better to have a6 completely tied up being a frame pointer
- -- rather than let GCC pick random things to do with it.
- -- (If we want to steal a6, then we would try to do things
- -- as on iX86, where we *do* steal the frame pointer [%ebp].)
- = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
-
- | prefixMatch "i386" cTARGETPLATFORM
- -- -fno-defer-pop : basically the same game as for m68k
- --
- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
- -- the fp (%ebp) for our register maps.
- = do n_regs <- readState stolen_x86_regs
- sta <- readIORef static
- return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
- [ "-fno-defer-pop", "-fomit-frame-pointer",
- "-DSTOLEN_X86_REGS="++show n_regs ]
- )
-
- | prefixMatch "mips" cTARGETPLATFORM
- = return ( ["static"], [] )
-
- | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
- = return ( ["static"], ["-finhibit-size-directive"] )
-
- | otherwise
- = return ( [], [] )
-
------------------------------------------------------------------------------
-- Build the Hsc command line
build_hsc_opts :: IO [String]
build_hsc_opts = do
opt_C_ <- getOpts opt_C -- misc hsc opts
+ -- take into account -fno-* flags by removing the equivalent -f*
+ -- flag from our list.
+ anti_flags <- getOpts anti_opt_C
+ let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
+ filtered_opts = filter (`notElem` anti_flags) basic_opts
+
-- warnings
- warn_level <- readState warning_opt
+ warn_level <- readIORef warning_opt
let warn_opts = case warn_level of
W_default -> standardWarnings
W_ -> minusWOpts
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
heap <- readState specific_heap_size
stack <- readState specific_stack_size
- -- take into account -fno-* flags by removing the equivalent -f*
- -- flag from our list.
- anti_flags <- getOpts anti_opt_C
- let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
- filtered_opts = filter (`notElem` anti_flags) basic_opts
-
return
(
filtered_opts
-- ToDo: C stub files
++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
- ++ rts_opts
)
makeHiMap
Interrupted -> exitWith (ExitFailure 1)
_ -> do hPutStrLn stderr (show (dyn :: BarfKind))
exitWith (ExitFailure 1)
- ) $
+ ) $ do
- -- make sure we clean up after ourselves
- later (do forget_it <- readIORef keep_tmp_files
- unless forget_it $ do
- verb <- readIORef verbose
- cleanTempFiles verb
+ -- make sure we clean up after ourselves
+ later (do forget_it <- readIORef keep_tmp_files
+ unless forget_it $ do
+ verb <- readIORef verbose
+ cleanTempFiles verb
)
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
-- signals.
- do
-- install signal handlers
main_thread <- myThreadId
installHandler sigINT sig_handler Nothing
#endif
- doIfSet opt_Verbose
- (hPutStr stderr "Glasgow Haskell Compiler, Version " >>
- hPutStr stderr compiler_version >>
- hPutStr stderr ", for Haskell 98, compiled by GHC version " >>
- hPutStr stderr booter_version >>
- hPutStr stderr "\n") >>
-
pgm <- getProgName
writeIORef prog_name pgm
writeIORef v_todo todo
-- process all the other arguments, and get the source files
- srcs <- processArgs driver_opts flags2 []
+ non_static <- processArgs static_flags flags2 []
-- find the build tag, and re-process the build-specific options
more_opts <- findBuildTag
- _ <- processArgs driver_opts more_opts []
+ _ <- processArgs static_opts more_opts []
+
+ -- give the static flags to hsc
+ build_hsc_opts
+
+ -- the rest of the arguments are "dynamic"
+ srcs <- processArgs dynamic_flags non_static []
+
+ -- complain about any unknown flags
+ let unknown_flags = [ f | ('-':f) <- srcs ]
+ mapM unknownFlagErr unknown_flags
-- get the -v flag
verb <- readIORef verbose
+ when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
+ hPutStr stderr version_str
+ hPutStr stderr ", for Haskell 98, compiled by GHC version "
+ hPutStr stderr booter_version
+ hPutStr stderr "\n")
+
when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
-- mkdependHS is special
--- the output suffix for a given phase is uniquely determined by
--- the input requirements of the next phase.
-phase_input_ext Unlit = "lhs"
-phase_input_ext Cpp = "lpp"
-phase_input_ext Hsc = "cpp"
-phase_input_ext HCc = "hc"
-phase_input_ext Cc = "c"
-phase_input_ext Mangle = "raw_s"
-phase_input_ext SplitMangle = "split_s" -- not really generated
-phase_input_ext As = "s"
-phase_input_ext SplitAs = "split_s" -- not really generated
-phase_input_ext Ln = "o"
-phase_input_ext MkDependHS = "dep"
-
run_pipeline
:: [ (Phase, IntermediateFileType, String) ] -- phases to run
-> String -- input file
else if keep == Persistent
then do f <- odir_ify (orig_basename ++ '.':suffix)
osuf_ify f
- else do filename <- newTempName suffix
- add files_to_clean filename
- return filename
+ else newTempName suffix
-------------------------------------------------------------------------------
-- mkdependHS
-- open a new temp file in which to stuff the dependency info
-- as we go along.
dep_file <- newTempName "dep"
- add files_to_clean dep_file
writeIORef dep_tmp_file dep_file
tmp_hdl <- openFile dep_file WriteMode
writeIORef dep_tmp_hdl tmp_hdl
search dir_contents
--------------------------------------------------------------------------------
--- Unlit phase
-
-run_phase Unlit _basename _suff input_fn output_fn
- = do 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 True
-
--------------------------------------------------------------------------------
--- Cpp phase
-
-run_phase Cpp _basename _suff input_fn output_fn
- = do src_opts <- getOptionsFromSource input_fn
- -- ToDo: this is *wrong* if we're processing more than one file:
- -- the OPTIONS will persist through the subsequent compilations.
- _ <- processArgs driver_opts src_opts []
-
- 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
-
-----------------------------------------------------------------------------
-- MkDependHS phase
doing_hi <- readIORef produceHi
tmp_hi_file <- if doing_hi
- then do fn <- newTempName "hi"
- add files_to_clean fn
- return fn
+ then newTempName "hi"
else return ""
-- tmp files for foreign export stub code
tmp_stub_h <- newTempName "stub_h"
tmp_stub_c <- newTempName "stub_c"
- add files_to_clean tmp_stub_h
- add files_to_clean tmp_stub_c
-- figure out where to put the .hi file
ohi <- readIORef output_hi
_ -> "#include \""++h_file++"\""
cc_help <- newTempName "c"
- add files_to_clean cc_help
h <- openFile cc_help WriteMode
hPutStr h cc_injects
hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
hClose h
ccout <- newTempName "ccout"
- add files_to_clean ccout
mangle <- readIORef do_asm_mangling
(md_c_flags, md_regd_c_flags) <- machdepCCOpts
x <- getProcessID
let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
writeIORef split_prefix split_s_prefix
- add files_to_clean (split_s_prefix ++ "__*") -- d:-)
+ addFilesToClean (split_s_prefix ++ "__*") -- d:-)
-- allocate a tmp file to put the no. of split .s files in (sigh)
n_files <- newTempName "n_files"
- add files_to_clean n_files
run_something "Split Assembly File"
(unwords [ splitter
)
-----------------------------------------------------------------------------
--- Running an external program
-
-run_something phase_name cmd
- = do
- verb <- readIORef verbose
- when verb $ do
- putStr phase_name
- putStrLn ":"
- putStrLn cmd
- hFlush stdout
-
- -- test for -n flag
- n <- readIORef dry_run
- unless n $ do
-
- -- and run it!
-#ifndef mingw32_TARGET_OS
- exit_code <- system cmd `catchAllIO`
- (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
-#else
- tmp <- newTempName "sh"
- h <- openFile tmp WriteMode
- hPutStrLn h cmd
- hClose h
- exit_code <- system ("sh - " ++ tmp) `catchAllIO`
- (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
- removeFile tmp
-#endif
-
- if exit_code /= ExitSuccess
- then throwDyn (PhaseFailed phase_name exit_code)
- else do when verb (putStr "\n")
- return ()
-
------------------------------------------------------------------------------
--- Flags
-
-data OptKind
- = NoArg (IO ()) -- flag with no argument
- | HasArg (String -> IO ()) -- flag has an argument (maybe prefix)
- | SepArg (String -> IO ()) -- flag has a separate argument
- | Prefix (String -> IO ()) -- flag is a prefix only
- | OptPrefix (String -> IO ()) -- flag may be a prefix
- | AnySuffix (String -> IO ()) -- flag is a prefix, pass whole arg to fn
- | PassFlag (String -> IO ()) -- flag with no arg, pass flag to fn
-
--- note that ordering is important in the following list: any flag which
--- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
--- flags further down the list with the same prefix.
-
-driver_opts =
- [ ------- help -------------------------------------------------------
- ( "?" , NoArg long_usage)
- , ( "-help" , NoArg long_usage)
-
-
- ------- version ----------------------------------------------------
- , ( "-version" , NoArg (do hPutStrLn stdout (cProjectName
- ++ ", version " ++ version_str)
- exitWith ExitSuccess))
- , ( "-numeric-version", NoArg (do hPutStrLn stdout version_str
- exitWith ExitSuccess))
-
- ------- verbosity ----------------------------------------------------
- , ( "v" , NoArg (writeIORef verbose True) )
- , ( "n" , NoArg (writeIORef dry_run True) )
-
- ------- recompilation checker --------------------------------------
- , ( "recomp" , NoArg (writeIORef recomp True) )
- , ( "no-recomp" , NoArg (writeIORef recomp False) )
-
- ------- ways --------------------------------------------------------
- , ( "prof" , NoArg (addNoDups ways WayProf) )
- , ( "unreg" , NoArg (addNoDups ways WayUnreg) )
- , ( "dll" , NoArg (addNoDups ways WayDll) )
- , ( "ticky" , NoArg (addNoDups ways WayTicky) )
- , ( "parallel" , NoArg (addNoDups ways WayPar) )
- , ( "gransim" , NoArg (addNoDups ways WayGran) )
- , ( "smp" , NoArg (addNoDups ways WaySMP) )
- , ( "debug" , NoArg (addNoDups ways WayDebug) )
- -- ToDo: user ways
-
- ------- Interface files ---------------------------------------------
- , ( "hi" , NoArg (writeIORef produceHi True) )
- , ( "nohi" , NoArg (writeIORef produceHi False) )
- , ( "hi-diffs" , NoArg (writeIORef hi_diffs NormalHiDiffs) )
- , ( "no-hi-diffs" , NoArg (writeIORef hi_diffs NoHiDiffs) )
- , ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
- , ( "keep-hi-diffs" , NoArg (writeIORef keep_hi_diffs True) )
- --"hi-with-*" -> hiw <- readIORef hi_with (ToDo)
-
- --------- Profiling --------------------------------------------------
- , ( "auto-dicts" , NoArg (addOpt_C "-fauto-sccs-on-dicts") )
- , ( "auto-all" , NoArg (addOpt_C "-fauto-sccs-on-all-toplevs") )
- , ( "auto" , NoArg (addOpt_C "-fauto-sccs-on-exported-toplevs") )
- , ( "caf-all" , NoArg (addOpt_C "-fauto-sccs-on-individual-cafs") )
- -- "ignore-sccs" doesn't work (ToDo)
-
- , ( "no-auto-dicts" , NoArg (addAntiOpt_C "-fauto-sccs-on-dicts") )
- , ( "no-auto-all" , NoArg (addAntiOpt_C "-fauto-sccs-on-all-toplevs") )
- , ( "no-auto" , NoArg (addAntiOpt_C "-fauto-sccs-on-exported-toplevs") )
- , ( "no-caf-all" , NoArg (addAntiOpt_C "-fauto-sccs-on-individual-cafs") )
-
- ------- Miscellaneous -----------------------------------------------
- , ( "cpp" , NoArg (updateState (\s -> s{ cpp_flag = True })) )
- , ( "#include" , HasArg (addCmdlineHCInclude) )
- , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat
-
- ------- Output Redirection ------------------------------------------
- , ( "odir" , HasArg (writeIORef output_dir . Just) )
- , ( "o" , SepArg (writeIORef output_file . Just) )
- , ( "osuf" , HasArg (writeIORef output_suf . Just) )
- , ( "hisuf" , HasArg (writeIORef hi_suf) )
- , ( "tmpdir" , HasArg (writeIORef tmpdir . (++ "/")) )
- , ( "ohi" , HasArg (\s -> case s of
- "-" -> writeIORef hi_on_stdout True
- _ -> writeIORef output_hi (Just s)) )
- -- -odump?
-
- , ( "keep-hc-file" , AnySuffix (\_ -> writeIORef keep_hc_files True) )
- , ( "keep-s-file" , AnySuffix (\_ -> writeIORef keep_s_files True) )
- , ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files True) )
- , ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
-
- , ( "split-objs" , NoArg (if can_split
- then do writeIORef split_object_files True
- addOpt_C "-fglobalise-toplev-names"
- addOpt_c "-DUSE_SPLIT_MARKERS"
- else hPutStrLn stderr
- "warning: don't know how to split \
- \object files on this architecture"
- ) )
-
- ------- Include/Import Paths ----------------------------------------
- , ( "i" , OptPrefix (addToDirList import_paths) )
- , ( "I" , Prefix (addToDirList include_paths) )
-
- ------- Libraries ---------------------------------------------------
- , ( "L" , Prefix (addToDirList library_paths) )
- , ( "l" , Prefix (add cmdline_libraries) )
-
- ------- Packages ----------------------------------------------------
- , ( "package-name" , HasArg (\s -> addOpt_C ("-inpackage="++s)) )
-
- , ( "package" , HasArg (addPackage) )
- , ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
-
- , ( "-list-packages" , NoArg (listPackages) )
- , ( "-add-package" , NoArg (newPackage) )
- , ( "-delete-package" , SepArg (deletePackage) )
-
- ------- Specific phases --------------------------------------------
- , ( "pgmL" , HasArg (writeIORef pgm_L) )
- , ( "pgmP" , HasArg (writeIORef pgm_P) )
- , ( "pgmC" , HasArg (writeIORef pgm_C) )
- , ( "pgmc" , HasArg (writeIORef pgm_c) )
- , ( "pgmm" , HasArg (writeIORef pgm_m) )
- , ( "pgms" , HasArg (writeIORef pgm_s) )
- , ( "pgma" , HasArg (writeIORef pgm_a) )
- , ( "pgml" , HasArg (writeIORef pgm_l) )
-
- , ( "optdep" , HasArg (addOpt_dep) )
- , ( "optL" , HasArg (addOpt_L) )
- , ( "optP" , HasArg (addOpt_P) )
- , ( "optC" , HasArg (addOpt_C) )
- , ( "optc" , HasArg (addOpt_c) )
- , ( "optm" , HasArg (addOpt_m) )
- , ( "opta" , HasArg (addOpt_a) )
- , ( "optl" , HasArg (addOpt_l) )
- , ( "optdll" , HasArg (addOpt_dll) )
-
- ------ HsCpp opts ---------------------------------------------------
- , ( "D" , Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
- , ( "U" , Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )
-
- ------ Warning opts -------------------------------------------------
- , ( "W" , NoArg (updateState (\s -> s{ warning_opt = W_ })))
- , ( "Wall" , NoArg (updateState (\s -> s{ warning_opt = W_all })))
- , ( "Wnot" , NoArg (updateState (\s -> s{ warning_opt = W_not })))
- , ( "w" , NoArg (updateState (\s -> s{ warning_opt = W_not })))
-
- ----- Linker --------------------------------------------------------
- , ( "static" , NoArg (writeIORef static True) )
-
- ------ Compiler RTS options -----------------------------------------
- , ( "H" , HasArg (newHeapSize . decodeSize) )
- , ( "K" , HasArg (newStackSize . decodeSize) )
- , ( "Rscale-sizes" , HasArg (floatOpt scale_sizes_by) )
-
- ------ Debugging ----------------------------------------------------
- , ( "dstg-stats" , NoArg (writeIORef opt_StgStats True) )
-
- , ( "dno-" , Prefix (\s -> addAntiOpt_C ("-d"++s)) )
- , ( "d" , AnySuffix (addOpt_C) )
-
- ------ Machine dependant (-m<blah>) stuff ---------------------------
-
- , ( "monly-2-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 2}) ))
- , ( "monly-3-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 3}) ))
- , ( "monly-4-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 4}) ))
-
- ------ Compiler flags -----------------------------------------------
- , ( "O2-for-C" , NoArg (writeIORef opt_minus_o2_for_C True) )
- , ( "O" , OptPrefix (setOptLevel) )
-
- , ( "fglasgow-exts-no-lang", NoArg ( do addOpt_C "-fglasgow-exts") )
-
- , ( "fglasgow-exts" , NoArg (do addOpt_C "-fglasgow-exts"
- addPackage "lang"))
-
- , ( "fasm" , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
-
- , ( "fvia-c" , NoArg (writeIORef hsc_lang HscC) )
- , ( "fvia-C" , NoArg (writeIORef hsc_lang HscC) )
-
- , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling False) )
-
- , ( "fmax-simplifier-iterations",
- Prefix (writeIORef opt_MaxSimplifierIterations . read) )
-
- , ( "fusagesp" , NoArg (do writeIORef opt_UsageSPInf True
- addOpt_C "-fusagesp-on") )
-
- , ( "fexcess-precision" , NoArg (do updateState
- (\s -> s{ excess_precision = True })
- addOpt_C "-fexcess-precision"))
-
- -- flags that are "active negatives"
- , ( "fno-implicit-prelude" , PassFlag (addOpt_C) )
- , ( "fno-prune-tydecls" , PassFlag (addOpt_C) )
- , ( "fno-prune-instdecls" , PassFlag (addOpt_C) )
- , ( "fno-pre-inlining" , PassFlag (addOpt_C) )
-
- -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
- , ( "fno-", Prefix (\s -> addAntiOpt_C ("-f"++s)) )
-
- -- Pass all remaining "-f<blah>" options to hsc
- , ( "f", AnySuffix (addOpt_C) )
- ]
-
------------------------------------------------------------------------------
--- Process command-line
-
-processArgs :: [(String,OptKind)] -> [String] -> [String]
- -> IO [String] -- returns spare args
-processArgs _spec [] spare = return (reverse spare)
-processArgs spec args@(('-':_):_) spare = do
- args' <- processOneArg spec args
- processArgs spec args' spare
-processArgs spec (arg:args) spare =
- processArgs spec args (arg:spare)
-
-processOneArg :: [(String,OptKind)] -> [String] -> IO [String]
-processOneArg spec (('-':arg):args) = do
- let (rest,action) = findArg spec arg
- dash_arg = '-':arg
- case action of
-
- NoArg io ->
- if rest == ""
- then io >> return args
- else unknownFlagErr dash_arg
-
- HasArg fio ->
- if rest /= ""
- then fio rest >> return args
- else case args of
- [] -> unknownFlagErr dash_arg
- (arg1:args1) -> fio arg1 >> return args1
-
- SepArg fio ->
- case args of
- [] -> unknownFlagErr dash_arg
- (arg1:args1) -> fio arg1 >> return args1
-
- Prefix fio ->
- if rest /= ""
- then fio rest >> return args
- else unknownFlagErr dash_arg
-
- OptPrefix fio -> fio rest >> return args
-
- AnySuffix fio -> fio ('-':arg) >> return args
-
- PassFlag fio ->
- if rest /= ""
- then unknownFlagErr dash_arg
- else fio ('-':arg) >> return args
-
-findArg :: [(String,OptKind)] -> String -> (String,OptKind)
-findArg spec arg
- = case [ (remove_spaces rest, k) | (pat,k) <- spec,
- Just rest <- [my_prefix_match pat arg],
- is_prefix k || null rest ] of
- [] -> unknownFlagErr ('-':arg)
- (one:_) -> one
-
-is_prefix (NoArg _) = False
-is_prefix (SepArg _) = False
-is_prefix (PassFlag _) = False
-is_prefix _ = True
-
------------------------------------------------------------------------------
--- convert sizes like "3.5M" into integers
-
-decodeSize :: String -> Integer
-decodeSize str
- | c == "" = truncate n
- | c == "K" || c == "k" = truncate (n * 1000)
- | c == "M" || c == "m" = truncate (n * 1000 * 1000)
- | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
- | otherwise = throwDyn (OtherError ("can't decode size: " ++ str))
- where (m, c) = span pred str
- n = read m :: Double
- pred c = isDigit c || c == '.'
-
-floatOpt :: IORef Double -> String -> IO ()
-floatOpt ref str
- = writeIORef ref (read str :: Double)
-
------------------------------------------------------------------------------
--- Finding files in the installation
-
-GLOBAL_VAR(topDir, clibdir, String)
-
- -- grab the last -B option on the command line, and
- -- set topDir to its value.
-setTopDir :: [String] -> IO [String]
-setTopDir args = do
- let (minusbs, others) = partition (prefixMatch "-B") args
- (case minusbs of
- [] -> writeIORef topDir clibdir
- some -> writeIORef topDir (drop 2 (last some)))
- return others
-
-findFile name alt_path = unsafePerformIO (do
- top_dir <- readIORef topDir
- let installed_file = top_dir ++ '/':name
- let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
- b <- doesFileExist inplace_file
- if b then return inplace_file
- else return installed_file
- )
-
------------------------------------------------------------------------------
--- Utils
-
-my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
-my_partition _ [] = ([],[])
-my_partition p (a:as)
- = let (bs,cs) = my_partition p as in
- case p a of
- Nothing -> (bs,a:cs)
- Just b -> ((a,b):bs,cs)
-
-my_prefix_match :: String -> String -> Maybe String
-my_prefix_match [] rest = Just rest
-my_prefix_match (_:_) [] = Nothing
-my_prefix_match (p:pat) (r:rest)
- | p == r = my_prefix_match pat rest
- | otherwise = Nothing
-
-prefixMatch :: Eq a => [a] -> [a] -> Bool
-prefixMatch [] _str = True
-prefixMatch _pat [] = False
-prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
- | otherwise = False
-
-postfixMatch :: String -> String -> Bool
-postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
-
-later = flip finally
-
-my_catchDyn = flip catchDyn
-
-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
-
-suffixOf :: String -> String
-suffixOf s = drop_longest_prefix s '.'
-
-split :: Char -> String -> [String]
-split c s = case rest of
- [] -> [chunk]
- _:rest -> chunk : split c rest
- where (chunk, rest) = break (==c) s
-
-add :: IORef [a] -> a -> IO ()
-add var x = do
- xs <- readIORef var
- writeIORef var (x:xs)
-
-addNoDups :: Eq a => IORef [a] -> a -> IO ()
-addNoDups var x = do
- xs <- readIORef var
- unless (x `elem` xs) $ writeIORef var (x:xs)
-
-remove_suffix :: Char -> String -> String
-remove_suffix c s
- | null pre = reverse suf
- | otherwise = reverse pre
- where (suf,pre) = break (==c) (reverse s)
-
-drop_longest_prefix :: String -> Char -> String
-drop_longest_prefix s c = reverse suf
- where (suf,_pre) = break (==c) (reverse s)
-
-take_longest_prefix :: String -> Char -> String
-take_longest_prefix s c = reverse pre
- where (_suf,pre) = break (==c) (reverse s)
-
-newsuf :: String -> String -> String
-newsuf suf s = remove_suffix '.' s ++ suf
-
--- getdir strips the filename off the input string, returning the directory.
-getdir :: String -> String
-getdir s = if null dir then "." else init dir
- where dir = take_longest_prefix s '/'
-
-newdir :: String -> String -> String
-newdir dir s = dir ++ '/':drop_longest_prefix s '/'
-
-remove_spaces :: String -> String
-remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
-
------------------------------------------------------------------------------
-- compatibility code
#if __GLASGOW_HASKELL__ <= 408
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: PackageMaintenance.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+--
+-- GHC Driver program
+--
+-- (c) Simon Marlow 2000
+--
+-----------------------------------------------------------------------------
+
+module PackageMaintenance where
+
+import CmStaticInfo
+import DriverState
+import DriverUtil
+
+import Exception
+import IOExts
+import Pretty
+
+import IO
+import Directory
+import System
+import Monad
+
+-----------------------------------------------------------------------------
+-- Package maintenance
+
+listPackages :: IO ()
+listPackages = do
+ details <- readIORef package_details
+ hPutStr stdout (listPkgs details)
+ hPutChar stdout '\n'
+ exitWith ExitSuccess
+
+newPackage :: IO ()
+newPackage = do
+ checkConfigAccess
+ details <- readIORef package_details
+ hPutStr stdout "Reading package info from stdin... "
+ stuff <- getContents
+ let new_pkg = read stuff :: Package
+ catchAll new_pkg
+ (\_ -> throwDyn (OtherError "parse error in package info"))
+ hPutStrLn stdout "done."
+ if (name new_pkg `elem` map name details)
+ then throwDyn (OtherError ("package `" ++ name new_pkg ++
+ "' already installed"))
+ else do
+ conf_file <- readIORef package_config
+ savePackageConfig conf_file
+ maybeRestoreOldConfig conf_file $ do
+ writeNewConfig conf_file ( ++ [new_pkg])
+ exitWith ExitSuccess
+
+deletePackage :: String -> IO ()
+deletePackage pkg = do
+ checkConfigAccess
+ details <- readIORef package_details
+ if (pkg `notElem` map name details)
+ then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
+ else do
+ conf_file <- readIORef package_config
+ savePackageConfig conf_file
+ maybeRestoreOldConfig conf_file $ do
+ writeNewConfig conf_file (filter ((/= pkg) . name))
+ exitWith ExitSuccess
+
+checkConfigAccess :: IO ()
+checkConfigAccess = do
+ conf_file <- readIORef package_config
+ access <- getPermissions conf_file
+ unless (writable access)
+ (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
+
+maybeRestoreOldConfig :: String -> IO () -> IO ()
+maybeRestoreOldConfig conf_file io
+ = catchAllIO io (\e -> do
+ hPutStr stdout "\nWARNING: an error was encountered while the new \n\
+ \configuration was being written. Attempting to \n\
+ \restore the old configuration... "
+ system ("cp " ++ conf_file ++ ".old " ++ conf_file)
+ hPutStrLn stdout "done."
+ throw e
+ )
+
+writeNewConfig :: String -> ([Package] -> [Package]) -> IO ()
+writeNewConfig conf_file fn = do
+ hPutStr stdout "Writing new package config file... "
+ old_details <- readIORef package_details
+ h <- openFile conf_file WriteMode
+ hPutStr h (dumpPackages (fn old_details))
+ hClose h
+ hPutStrLn stdout "done."
+
+savePackageConfig :: String -> IO ()
+savePackageConfig conf_file = do
+ hPutStr stdout "Saving old package config file... "
+ -- mv rather than cp because we've already done an hGetContents
+ -- on this file so we won't be able to open it for writing
+ -- unless we move the old one out of the way...
+ system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
+ hPutStrLn stdout "done."
+
+-----------------------------------------------------------------------------
+-- Pretty printing package info
+
+listPkgs :: [Package] -> String
+listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs)))
+
+dumpPackages :: [Package] -> String
+dumpPackages pkgs =
+ render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs))))
+
+dumpPkgGuts :: Package -> Doc
+dumpPkgGuts pkg =
+ text "Package" $$ nest 3 (braces (
+ sep (punctuate comma [
+ text "name = " <> text (show (name pkg)),
+ dumpField "import_dirs" (import_dirs pkg),
+ dumpField "library_dirs" (library_dirs pkg),
+ dumpField "hs_libraries" (hs_libraries pkg),
+ dumpField "extra_libraries" (extra_libraries pkg),
+ dumpField "include_dirs" (include_dirs pkg),
+ dumpField "c_includes" (c_includes pkg),
+ dumpField "package_deps" (package_deps pkg),
+ dumpField "extra_ghc_opts" (extra_ghc_opts pkg),
+ dumpField "extra_cc_opts" (extra_cc_opts pkg),
+ dumpField "extra_ld_opts" (extra_ld_opts pkg)
+ ])))
+
+dumpField :: String -> [String] -> Doc
+dumpField name val =
+ hang (text name <+> equals) 2
+ (brackets (sep (punctuate comma (map (text . show) val))))
--- /dev/null
+-----------------------------------------------------------------------------
+-- $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
+
-----------------------------------------------------------------------------
--- $Id: TmpFiles.hs,v 1.1 2000/10/10 13:21:10 simonmar Exp $
+-- $Id: TmpFiles.hs,v 1.2 2000/10/11 11:54:58 simonmar Exp $
--
-- Temporary file management
--
Suffix,
initTempFileStorage, -- :: IO ()
cleanTempFiles, -- :: IO ()
- newTempName -- :: Suffix -> IO FilePath
+ newTempName, -- :: Suffix -> IO FilePath
+ addFilesToClean -- :: [FilePath] -> IO ()
) where
-- main
+import DriverState
import Config
import Util
#include "HsVersions.h"
-GLOBAL_VAR( v_FilesToClean, [], [String] )
-GLOBAL_VAR( v_TmpDir, cDEFAULT_TMPDIR, String )
+GLOBAL_VAR(v_FilesToClean, [], [String] )
initTempFileStorage = do
-- check whether TMPDIR is set in the environment
IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
- writeIORef tmpdir dir)
+ writeIORef v_TmpDir dir)
cleanTempFiles :: Bool -> IO ()
let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
b <- doesFileExist filename
if b then findTempName tmp_dir (x+1)
- else return filename
+ else do add v_FilesToClean filename -- clean it up later
+ return filename
+
+addFilesToClean :: [FilePath] -> IO ()
+addFilesToClean files = mapM_ (add v_FilesToClean) files
+
+add :: IORef [a] -> a -> IO ()
+add var x = do
+ xs <- readIORef var
+ writeIORef var (x:xs)
projects / ghc-hetmet.git / commitdiff