-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.16 2000/11/08 16:24:34 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.29 2000/12/08 10:26:41 simonmar Exp $
--
-- Driver flags
--
import CmdLineOpts
import Config
import Util
-import CmdLineOpts
-
+import TmpFiles ( newTempName )
+import Directory ( removeFile )
import Exception
import IOExts
import IO
+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
------- version ----------------------------------------------------
, ( "-version" , NoArg (do hPutStrLn stdout (cProjectName
- ++ ", version " ++ version_str)
+ ++ ", version " ++ cProjectVersion)
exitWith ExitSuccess))
- , ( "-numeric-version", NoArg (do hPutStrLn stdout version_str
+ , ( "-numeric-version", NoArg (do hPutStrLn stdout cProjectVersion
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 ------------------------------------------------------
+#ifdef not_yet
+ , ( "H" , HasArg (setHeapSize . fromIntegral . decodeSize) )
+#endif
------ 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",
-----------------------------------------------------------------------------
-- 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)
+
+setDynFlag f = updDynFlags (\dfs -> dfs{ flags = f : flags dfs })
+unSetDynFlag f = updDynFlags (\dfs -> dfs{ flags = filter (/= f) (flags dfs) })
-unSetDynFlag f = do
+-- 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-interpsyn", NoArg (setDynFlag Opt_D_dump_InterpSyn) )
, ( "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-hi", NoArg (setDynFlag Opt_D_dump_hi) )
, ( "ddump-minimal-imports", NoArg (setDynFlag Opt_D_dump_minimal_imports) )
, ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting) )
, ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting) )
------ Compiler flags -----------------------------------------------
+ , ( "fasm" , AnySuffix (\_ -> setLang HscAsm) )
+
+ , ( "fvia-c" , NoArg (setLang HscC) )
+ , ( "fvia-C" , NoArg (setLang HscC) )
+
, ( "fglasgow-exts", NoArg (setDynFlag Opt_GlasgowExts) )
, ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) )
+ -- 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) )
+
, ( "fallow-overlapping-instances",
NoArg (setDynFlag Opt_AllowOverlappingInstances) )
floatOpt ref str
= writeIORef ref (read str :: Double)
+#ifdef not_yet
+foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO ()
+#endif
+
-----------------------------------------------------------------------------
-- 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!
+#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`
+ (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+ removeFile tmp
+#endif
+
+ if exit_code /= ExitSuccess
+ then throwDyn (PhaseFailed phase_name exit_code)
+ else do when (verb >= 3) (putStr "\n")
+ return ()
+
projects / ghc-hetmet.git / blobdiff