+{-# OPTIONS -#include "hschooks.h" #-}
+
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.20 2000/11/19 19:40:08 simonmar 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
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
, ( "H" , HasArg (setHeapSize . fromIntegral . decodeSize) )
-#endif
+ , ( "Rghc-timing" , NoArg (enableTimingStats) )
------ Compiler flags -----------------------------------------------
, ( "O2-for-C" , NoArg (writeIORef v_minus_o2_for_C True) )
, ( "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.
-setDynFlag f = do
- dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags dfs{ flags = f : flags dfs }
+GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
+GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
-unSetDynFlag f = do
+updDynFlags f = do
dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags dfs{ flags = filter (/= 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) })
-- 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-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 -----------------------------------------------
- , ( "fasm" , AnySuffix (\_ -> setLang HscAsm) )
-
- , ( "fvia-c" , NoArg (setLang HscC) )
- , ( "fvia-C" , NoArg (setLang HscC) )
+ , ( "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) )
+ -- "active negatives"
+ , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) )
- , ( "fallow-overlapping-instances",
- NoArg (setDynFlag Opt_AllowOverlappingInstances) )
-
- , ( "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)
-#ifdef not_yet
-foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO ()
-#endif
+-----------------------------------------------------------------------------
+-- RTS Hooks
+
+foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO ()
+foreign import "enableTimingStats" unsafe enableTimingStats :: IO ()
-----------------------------------------------------------------------------
-- Build the Hsc static command line opts
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!
+ 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 ()
projects / ghc-hetmet.git / blobdiff