+{-# OPTIONS -#include "hschooks.h" #-}
+
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.18 2000/11/13 16:16:05 sewardj Exp $
+-- $Id: DriverFlags.hs,v 1.37 2000/12/19 13:06:50 simonmar Exp $
--
-- Driver flags
--
import DriverUtil
import TmpFiles ( v_TmpDir )
import CmdLineOpts
+import TmpFiles ( newTempName )
import Config
import Util
+import Panic
import Exception
import IOExts
+
+import Directory ( removeFile )
import IO
+import Maybe
+import Monad
import System
import Char
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
+arg_ok (AnySuffix _) rest arg = True
+arg_ok (AnySuffixPred p _) rest arg = p arg
-----------------------------------------------------------------------------
-- Static flags
exitWith ExitSuccess))
------- verbosity ----------------------------------------------------
- , ( "v" , NoArg (writeIORef v_Verbose True) )
, ( "n" , NoArg (writeIORef v_Dry_run True) )
------- recompilation checker --------------------------------------
------- ways --------------------------------------------------------
, ( "prof" , NoArg (addNoDups v_Ways WayProf) )
, ( "unreg" , NoArg (addNoDups v_Ways WayUnreg) )
- , ( "dll" , NoArg (addNoDups v_Ways WayDll) )
, ( "ticky" , NoArg (addNoDups v_Ways WayTicky) )
, ( "parallel" , NoArg (addNoDups v_Ways WayPar) )
, ( "gransim" , NoArg (addNoDups v_Ways WayGran) )
------- Miscellaneous -----------------------------------------------
, ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat
+ , ( "no-hs-main" , NoArg (writeIORef v_NoHsMain True) )
------- Output Redirection ------------------------------------------
, ( "odir" , HasArg (writeIORef v_Output_dir . Just) )
"warning: don't know how to split \
\object files on this architecture"
) )
-
+
------- Include/Import Paths ----------------------------------------
, ( "i" , OptPrefix (addToDirList v_Import_paths) )
, ( "I" , Prefix (addToDirList v_Include_paths) )
----- Linker --------------------------------------------------------
, ( "static" , NoArg (writeIORef v_Static True) )
+ , ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc
+
+ ----- RTS opts ------------------------------------------------------
+ , ( "H" , HasArg (setHeapSize . fromIntegral . decodeSize) )
+ , ( "Rghc-timing" , NoArg (enableTimingStats) )
------ Compiler flags -----------------------------------------------
, ( "O2-for-C" , NoArg (writeIORef v_minus_o2_for_C True) )
, ( "O" , OptPrefix (setOptLevel) )
- , ( "fasm" , OptPrefix (\_ -> writeIORef v_Hsc_Lang HscAsm) )
-
- , ( "fvia-c" , NoArg (writeIORef v_Hsc_Lang HscC) )
- , ( "fvia-C" , NoArg (writeIORef v_Hsc_Lang HscC) )
-
, ( "fno-asm-mangling" , NoArg (writeIORef v_Do_asm_mangling False) )
, ( "fmax-simplifier-iterations",
, ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
add v_Opt_C "-fexcess-precision"))
+ -- Optimisation flags are treated specially, so the normal
+ -- -fno-* pattern below doesn't work. We therefore allow
+ -- certain optimisation passes to be turned off explicitly:
+ , ( "fno-strictness" , NoArg (writeIORef v_Strictness False) )
+ , ( "fno-cpr" , NoArg (writeIORef v_CPR False) )
+ , ( "fno-cse" , NoArg (writeIORef v_CSE False) )
+
-- flags that are "active negatives"
- , ( "fno-implicit-prelude" , PassFlag (add v_Opt_C) )
, ( "fno-prune-tydecls" , PassFlag (add v_Opt_C) )
, ( "fno-prune-instdecls" , PassFlag (add v_Opt_C) )
, ( "fno-pre-inlining" , PassFlag (add v_Opt_C) )
-----------------------------------------------------------------------------
-- parse the dynamic arguments
-GLOBAL_VAR(v_InitDynFlags, error "no InitDynFlags", DynFlags)
-GLOBAL_VAR(v_DynFlags, error "no DynFlags", DynFlags)
+-- v_InitDynFlags
+-- is the "baseline" dynamic flags, initialised from
+-- the defaults and command line options.
+--
+-- v_DynFlags
+-- is the dynamic flags for the current compilation. It is reset
+-- to the value of v_InitDynFlags before each compilation, then
+-- updated by reading any OPTIONS pragma in the current module.
+
+GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
+GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
-setDynFlag f = do
+updDynFlags f = do
dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags dfs{ flags = f : flags dfs }
+ writeIORef v_DynFlags (f dfs)
+
+getDynFlags :: IO DynFlags
+getDynFlags = readIORef v_DynFlags
+
+dynFlag :: (DynFlags -> a) -> IO a
+dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
-unSetDynFlag f = do
+setDynFlag f = updDynFlags (\dfs -> dfs{ flags = f : flags dfs })
+unSetDynFlag f = updDynFlags (\dfs -> dfs{ flags = filter (/= f) (flags dfs) })
+
+-- we can only change HscC to HscAsm and vice-versa with dynamic flags
+-- (-fvia-C and -fasm).
+setLang l = do
dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags dfs{ flags = filter (/= f) (flags dfs) }
+ case hscLang dfs of
+ HscC -> writeIORef v_DynFlags dfs{ hscLang = l }
+ HscAsm -> writeIORef v_DynFlags dfs{ hscLang = l }
+ _ -> return ()
+
+setVerbosityAtLeast n =
+ updDynFlags (\dfs -> if verbosity dfs < n
+ then dfs{ verbosity = n }
+ else dfs)
+
+setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 2 })
+setVerbosity n
+ | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n })
+ | otherwise = throwDyn (OtherError "can't parse verbosity flag (-v<n>)")
+
+getVerbFlag = do
+ verb <- dynFlag verbosity
+ if verb >= 3 then return "-v" else return ""
dynamic_flags = [
( "cpp", NoArg (updateState (\s -> s{ cpp_flag = True })) )
, ( "#include", HasArg (addCmdlineHCInclude) )
+ , ( "v", OptPrefix (setVerbosity) )
+
, ( "optL", HasArg (addOpt_L) )
, ( "optP", HasArg (addOpt_P) )
, ( "optc", HasArg (addOpt_c) )
------ Debugging ----------------------------------------------------
, ( "dstg-stats", NoArg (writeIORef v_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-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-sat", NoArg (setDynFlag Opt_D_dump_sat) )
, ( "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-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) )
+ , ( "dshow-passes", NoArg (setVerbosity "2") )
, ( "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) )
+ , ( "ddump-bcos", NoArg (setDynFlag Opt_D_dump_BCOs) )
, ( "dsource-stats", NoArg (setDynFlag Opt_D_source_stats) )
, ( "dverbose-core2core", NoArg (setDynFlag Opt_D_verbose_core2core) )
, ( "dverbose-stg2stg", NoArg (setDynFlag Opt_D_verbose_stg2stg) )
, ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting) )
, ( "dusagesp-lint", NoArg (setDynFlag Opt_DoUSPLinting) )
- ------ Warnings ----------------------------------------------------
-
- , ( "fwarn-duplicate-exports", NoArg (setDynFlag Opt_WarnDuplicateExports) )
- , ( "fwarn-hi-shadowing", NoArg (setDynFlag Opt_WarnHiShadows) )
- , ( "fwarn-incomplete-patterns", NoArg (setDynFlag Opt_WarnIncompletePatterns) )
- , ( "fwarn-missing-fields", NoArg (setDynFlag Opt_WarnMissingFields) )
- , ( "fwarn-missing-methods", NoArg (setDynFlag Opt_WarnMissingMethods))
- , ( "fwarn-missing-signatures", NoArg (setDynFlag Opt_WarnMissingSigs) )
- , ( "fwarn-name-shadowing", NoArg (setDynFlag Opt_WarnNameShadowing) )
- , ( "fwarn-overlapping-patterns", NoArg (setDynFlag Opt_WarnOverlappingPatterns ) )
- , ( "fwarn-simple-patterns", NoArg (setDynFlag Opt_WarnSimplePatterns))
- , ( "fwarn-type-defaults", NoArg (setDynFlag Opt_WarnTypeDefaults) )
- , ( "fwarn-unused-binds", NoArg (setDynFlag Opt_WarnUnusedBinds) )
- , ( "fwarn-unused-imports", NoArg (setDynFlag Opt_WarnUnusedImports) )
- , ( "fwarn-unused-matches", NoArg (setDynFlag Opt_WarnUnusedMatches) )
- , ( "fwarn-deprecations", NoArg (setDynFlag Opt_WarnDeprecations) )
-
------ Machine dependant (-m<blah>) stuff ---------------------------
, ( "monly-2-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 2}) ))
------ Compiler flags -----------------------------------------------
- , ( "fglasgow-exts", NoArg (setDynFlag Opt_GlasgowExts) )
- , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) )
+ , ( "fasm", AnySuffix (\_ -> setLang HscAsm) )
+ , ( "fvia-c", NoArg (setLang HscC) )
+ , ( "fvia-C", NoArg (setLang HscC) )
- , ( "fallow-overlapping-instances",
- NoArg (setDynFlag Opt_AllowOverlappingInstances) )
+ -- "active negatives"
+ , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) )
- , ( "fallow-undecidable-instances",
- NoArg (setDynFlag Opt_AllowUndecidableInstances) )
+ -- the rest of the -f* and -fno-* flags
+ , ( "fno-", PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
+ , ( "f", PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
+ ]
- , ( "fgenerics", NoArg (setDynFlag Opt_Generics) )
+-- these -f<blah> flags can all be reversed with -fno-<blah>
+
+fFlags = [
+ ( "warn-duplicate-exports", Opt_WarnDuplicateExports ),
+ ( "warn-hi-shadowing", Opt_WarnHiShadows ),
+ ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns ),
+ ( "warn-missing-fields", Opt_WarnMissingFields ),
+ ( "warn-missing-methods", Opt_WarnMissingMethods ),
+ ( "warn-missing-signatures", Opt_WarnMissingSigs ),
+ ( "warn-name-shadowing", Opt_WarnNameShadowing ),
+ ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns ),
+ ( "warn-simple-patterns", Opt_WarnSimplePatterns ),
+ ( "warn-type-defaults", Opt_WarnTypeDefaults ),
+ ( "warn-unused-binds", Opt_WarnUnusedBinds ),
+ ( "warn-unused-imports", Opt_WarnUnusedImports ),
+ ( "warn-unused-matches", Opt_WarnUnusedMatches ),
+ ( "warn-deprecations", Opt_WarnDeprecations ),
+ ( "glasgow-exts", Opt_GlasgowExts ),
+ ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
+ ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ),
+ ( "fgenerics", Opt_Generics ),
+ ( "report-compile", Opt_ReportCompile )
+ ]
- , ( "freport-compile", NoArg (setDynFlag Opt_ReportCompile) )
- ]
+isFFlag f = f `elem` (map fst fFlags)
+getFFlag f = fromJust (lookup f fFlags)
-----------------------------------------------------------------------------
-- convert sizes like "3.5M" into integers
pred c = isDigit c || c == '.'
floatOpt :: IORef Double -> String -> IO ()
-floatOpt ref str
- = writeIORef ref (read str :: Double)
+floatOpt ref str = writeIORef ref (read str :: Double)
+
+-----------------------------------------------------------------------------
+-- RTS Hooks
+
+foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO ()
+foreign import "enableTimingStats" unsafe enableTimingStats :: IO ()
-----------------------------------------------------------------------------
-- Build the Hsc static command line opts
buildStaticHscOpts :: IO [String]
buildStaticHscOpts = do
- opt_C_ <- getStaticOpts v_Opt_C -- misc hsc opts
+ opt_C_ <- getStaticOpts v_Opt_C -- misc hsc opts from the command line
-- optimisation
minus_o <- readIORef v_OptLevel
let basic_opts = opt_C_ ++ optimisation_opts ++ stg_opts
filtered_opts = filter (`notElem` anti_flags) basic_opts
- verb <- is_verbose
- let hi_vers = "-fhi-version="++cProjectVersionInt
-
static <- (do s <- readIORef v_Static; if s then return "-static"
else return "")
- return ( filtered_opts ++ [ hi_vers, static, verb ] )
+ return ( static : filtered_opts )
+
+-----------------------------------------------------------------------------
+-- Running an external program
+
+-- sigh, here because both DriverMkDepend & DriverPipeline need it.
+
+runSomething phase_name cmd
+ = do
+ verb <- dynFlag verbosity
+ when (verb >= 2) $ putStrLn ("*** " ++ phase_name)
+ when (verb >= 3) $ putStrLn cmd
+ hFlush stdout
+
+ -- test for -n flag
+ n <- readIORef v_Dry_run
+ unless n $ do
+
+ -- and run it!
+ exit_code <- kludgedSystem cmd phase_name
+
+ if exit_code /= ExitSuccess
+ then throwDyn (PhaseFailed phase_name exit_code)
+ else do when (verb >= 3) (putStr "\n")
+ return ()