From 60bf710865eff2ac5a497aad66c2bccc66a70215 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 11 Oct 2000 11:54:58 +0000 Subject: [PATCH] [project @ 2000-10-11 11:54:58 by simonmar] Some progress: - driver is split up into slightly more managable parts - PreProces interface for use by the summariser - flags stuff is taking shape --- ghc/compiler/main/CmdLineOpts.lhs | 91 +- ghc/compiler/main/DriverFlags.hs | 401 +++++++++ ghc/compiler/main/DriverState.hs | 768 +++++++++++++++++ ghc/compiler/main/DriverUtil.hs | 177 ++++ ghc/compiler/main/HscMain.lhs | 16 - ghc/compiler/main/Main.hs | 1422 +------------------------------ ghc/compiler/main/PackageMaintenance.hs | 134 +++ ghc/compiler/main/PreProcess.hs | 97 +++ ghc/compiler/main/TmpFiles.hs | 22 +- 9 files changed, 1726 insertions(+), 1402 deletions(-) create mode 100644 ghc/compiler/main/DriverFlags.hs create mode 100644 ghc/compiler/main/DriverState.hs create mode 100644 ghc/compiler/main/DriverUtil.hs create mode 100644 ghc/compiler/main/PackageMaintenance.hs create mode 100644 ghc/compiler/main/PreProcess.hs diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 3a4b1e5..9d6b18d 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -7,14 +7,16 @@ 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, @@ -158,6 +160,7 @@ import Array ( array, (//) ) import GlaExts import Argv import Constants -- Default values for some flags +import DriverUtil import Maybes ( firstJust ) import Panic ( panic ) @@ -236,6 +239,8 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoCPResult | CoreDoGlomBinds | CoreCSE + + | CoreDoNothing -- useful when building up lists of these things \end{code} \begin{code} @@ -550,12 +555,89 @@ opt_UseLongRegs | opt_Unregisterised = 0 %************************************************************************ %* * +\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 @@ -585,7 +667,6 @@ lAST_SIMPL_SWITCH_TAG = 5 \begin{code} isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult - isAmongSimpl on_switches -- Switches mentioned later occur *earlier* -- in the list; defaults right at the end. = let diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs new file mode 100644 index 0000000..8369191 --- /dev/null +++ b/ghc/compiler/main/DriverFlags.hs @@ -0,0 +1,401 @@ +----------------------------------------------------------------------------- +-- $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-" options cancel out "-f" on the hsc cmdline + , ( "fno-", PrefixPred (\s -> isStaticHscFlag ("f"++s)) + (\s -> add anti_opt_C ("-f"++s)) ) + + -- Pass all remaining "-f" 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) 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) diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs new file mode 100644 index 0000000..15d630d --- /dev/null +++ b/ghc/compiler/main/DriverState.hs @@ -0,0 +1,768 @@ +----------------------------------------------------------------------------- +-- $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" diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs new file mode 100644 index 0000000..75cda59 --- /dev/null +++ b/ghc/compiler/main/DriverUtil.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- +-- $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 + diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index bdc62ed..e13368f 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -356,22 +356,6 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) \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} diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index dee1e11..9d82e36 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# 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 -- @@ -13,10 +13,14 @@ 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 @@ -36,6 +40,12 @@ import Maybe 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. @@ -49,6 +59,7 @@ import Char -- 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: @@ -60,123 +71,6 @@ import Char -- 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 {- @@ -206,742 +100,20 @@ data Phase 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 @@ -972,6 +144,7 @@ build_hsc_opts = do 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 @@ -1004,18 +177,11 @@ build_hsc_opts = do 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 @@ -1064,19 +230,18 @@ main = 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 @@ -1087,13 +252,6 @@ main = 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 @@ -1112,15 +270,31 @@ main = 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 @@ -1347,20 +521,6 @@ genPipeline todo stop_flag filename --- 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 @@ -1404,9 +564,7 @@ run_pipeline ((phase, keep, o_suffix):phases) 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 @@ -1448,7 +606,6 @@ beginMkDependHS = do -- 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 @@ -1587,55 +744,6 @@ findDependency mod imp = do 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 @@ -1712,16 +820,12 @@ run_phase Hsc basename suff input_fn output_fn 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 @@ -1841,14 +945,12 @@ run_phase cc_phase _basename _suff input_fn output_fn _ -> "#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 @@ -1914,11 +1016,10 @@ run_phase SplitMangle _basename _suff input_fn _output_fn 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 @@ -2020,435 +1121,6 @@ do_link o_files = do ) ----------------------------------------------------------------------------- --- 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) 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-" options cancel out "-f" on the hsc cmdline - , ( "fno-", Prefix (\s -> addAntiOpt_C ("-f"++s)) ) - - -- Pass all remaining "-f" 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 diff --git a/ghc/compiler/main/PackageMaintenance.hs b/ghc/compiler/main/PackageMaintenance.hs new file mode 100644 index 0000000..7d93662 --- /dev/null +++ b/ghc/compiler/main/PackageMaintenance.hs @@ -0,0 +1,134 @@ +----------------------------------------------------------------------------- +-- $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)))) diff --git a/ghc/compiler/main/PreProcess.hs b/ghc/compiler/main/PreProcess.hs new file mode 100644 index 0000000..64c2bb7 --- /dev/null +++ b/ghc/compiler/main/PreProcess.hs @@ -0,0 +1,97 @@ +----------------------------------------------------------------------------- +-- $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 + diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs index 5ec340b..adf6835 100644 --- a/ghc/compiler/main/TmpFiles.hs +++ b/ghc/compiler/main/TmpFiles.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -11,10 +11,12 @@ module TmpFiles ( Suffix, initTempFileStorage, -- :: IO () cleanTempFiles, -- :: IO () - newTempName -- :: Suffix -> IO FilePath + newTempName, -- :: Suffix -> IO FilePath + addFilesToClean -- :: [FilePath] -> IO () ) where -- main +import DriverState import Config import Util @@ -31,13 +33,12 @@ import Monad #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 () @@ -65,5 +66,14 @@ newTempName extn = do 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) -- 1.7.10.4