-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.20 2000/11/19 19:40:08 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 TmpFiles ( newTempName )
+import Directory ( removeFile )
import Exception
import IOExts
import IO
+import Monad
import System
import Char
exitWith ExitSuccess))
------- verbosity ----------------------------------------------------
- , ( "v" , NoArg (writeIORef v_Verbose True) )
, ( "n" , NoArg (writeIORef v_Dry_run True) )
------- recompilation checker --------------------------------------
------- 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) )
----- Linker --------------------------------------------------------
, ( "static" , NoArg (writeIORef v_Static True) )
+ , ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc
----- RTS opts ------------------------------------------------------
#ifdef not_yet
-----------------------------------------------------------------------------
-- 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)
-unSetDynFlag f = do
- dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags dfs{ flags = filter (/= f) (flags 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) })
-- we can only change HscC to HscAsm and vice-versa with dynamic flags
-- (-fvia-C and -fasm).
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) )
, ( "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) )
else return "")
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