ghc/compiler/main/DriverFlags.hs

   1 {-# OPTIONS -#include "hschooks.h" #-}
   2
   3 -----------------------------------------------------------------------------
   4 -- $Id: DriverFlags.hs,v 1.40 2001/01/19 15:26:37 simonmar Exp $
   5 --
   6 -- Driver flags
   7 --
   8 -- (c) Simon Marlow 2000
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module DriverFlags where
  13
  14 #include "HsVersions.h"
  15
  16 import PackageMaintenance
  17 import DriverState
  18 import DriverUtil
  19 import TmpFiles         ( v_TmpDir )
  20 import CmdLineOpts
  21 import Config
  22 import Util
  23 import Panic
  24
  25 import Exception
  26 import IOExts
  27
  28 import IO
  29 import Maybe
  30 import Monad
  31 import System
  32 import Char
  33
  34 -----------------------------------------------------------------------------
  35 -- Flags
  36
  37 -- Flag parsing is now done in stages:
  38 --
  39 --     * parse the initial list of flags and remove any flags understood
  40 --       by the driver only.  Determine whether we're in multi-compilation
  41 --       or single-compilation mode.
  42 --
  43 --     * gather the list of "static" hsc flags, and assign them to the global
  44 --       static hsc flags variable.
  45 --
  46 --     * build the inital DynFlags from the remaining flags.
  47 --
  48 --     * complain if we've got any flags left over.
  49 --
  50 --     * for each source file: grab the OPTIONS, and build a new DynFlags
  51 --       to pass to the compiler.
  52
  53 -----------------------------------------------------------------------------
  54 -- Process command-line
  55
  56 data OptKind
  57         = NoArg (IO ())                     -- flag with no argument
  58         | HasArg (String -> IO ())          -- flag has an argument (maybe prefix)
  59         | SepArg (String -> IO ())          -- flag has a separate argument
  60         | Prefix (String -> IO ())          -- flag is a prefix only
  61         | OptPrefix (String -> IO ())       -- flag may be a prefix
  62         | AnySuffix (String -> IO ())       -- flag is a prefix, pass whole arg to fn
  63         | PassFlag  (String -> IO ())       -- flag with no arg, pass flag to fn
  64         | PrefixPred (String -> Bool) (String -> IO ())
  65         | AnySuffixPred (String -> Bool) (String -> IO ())
  66
  67 processArgs :: [(String,OptKind)] -> [String] -> [String]
  68    -> IO [String]  -- returns spare args
  69 processArgs _spec [] spare = return (reverse spare)
  70 processArgs spec args@(('-':arg):args') spare = do
  71   case findArg spec arg of
  72     Just (rest,action) ->
  73       do args' <- processOneArg action rest args
  74          processArgs spec args' spare
  75     Nothing ->
  76       processArgs spec args' (('-':arg):spare)
  77 processArgs spec (arg:args) spare =
  78   processArgs spec args (arg:spare)
  79
  80 processOneArg :: OptKind -> String -> [String] -> IO [String]
  81 processOneArg action rest (dash_arg@('-':arg):args) =
  82   case action of
  83         NoArg  io ->
  84                 if rest == ""
  85                         then io >> return args
  86                         else unknownFlagErr dash_arg
  87
  88         HasArg fio ->
  89                 if rest /= ""
  90                         then fio rest >> return args
  91                         else case args of
  92                                 [] -> unknownFlagErr dash_arg
  93                                 (arg1:args1) -> fio arg1 >> return args1
  94
  95         SepArg fio ->
  96                 case args of
  97                         [] -> unknownFlagErr dash_arg
  98                         (arg1:args1) -> fio arg1 >> return args1
  99
 100         Prefix fio ->
 101                 if rest /= ""
 102                         then fio rest >> return args
 103                         else unknownFlagErr dash_arg
 104
 105         PrefixPred p fio ->
 106                 if rest /= ""
 107                         then fio rest >> return args
 108                         else unknownFlagErr dash_arg
 109
 110         OptPrefix fio       -> fio rest >> return args
 111
 112         AnySuffix fio       -> fio dash_arg >> return args
 113
 114         AnySuffixPred p fio -> fio dash_arg >> return args
 115
 116         PassFlag fio  ->
 117                 if rest /= ""
 118                         then unknownFlagErr dash_arg
 119                         else fio dash_arg >> return args
 120
 121 findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind)
 122 findArg spec arg
 123   = case [ (remove_spaces rest, k)
 124          | (pat,k) <- spec, Just rest <- [my_prefix_match pat arg],
 125            arg_ok k rest arg ]
 126     of
 127         []      -> Nothing
 128         (one:_) -> Just one
 129
 130 arg_ok (NoArg _)            rest arg = null rest
 131 arg_ok (HasArg _)           rest arg = True
 132 arg_ok (SepArg _)           rest arg = null rest
 133 arg_ok (Prefix _)           rest arg = not (null rest)
 134 arg_ok (PrefixPred p _)     rest arg = not (null rest) && p rest
 135 arg_ok (OptPrefix _)        rest arg = True
 136 arg_ok (PassFlag _)         rest arg = null rest
 137 arg_ok (AnySuffix _)        rest arg = True
 138 arg_ok (AnySuffixPred p _)  rest arg = p arg
 139
 140 -----------------------------------------------------------------------------
 141 -- Static flags
 142
 143 -- note that ordering is important in the following list: any flag which
 144 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
 145 -- flags further down the list with the same prefix.
 146
 147 static_flags =
 148   [  ------- help -------------------------------------------------------
 149      ( "?"              , NoArg long_usage)
 150   ,  ( "-help"          , NoArg long_usage)
 151
 152
 153       ------- version ----------------------------------------------------
 154   ,  ( "-version"        , NoArg (do hPutStrLn stdout (cProjectName
 155                                       ++ ", version " ++ cProjectVersion)
 156                                      exitWith ExitSuccess))
 157   ,  ( "-numeric-version", NoArg (do hPutStrLn stdout cProjectVersion
 158                                      exitWith ExitSuccess))
 159
 160       ------- verbosity ----------------------------------------------------
 161   ,  ( "n"              , NoArg (writeIORef v_Dry_run True) )
 162
 163         ------- recompilation checker --------------------------------------
 164   ,  ( "recomp"         , NoArg (writeIORef v_Recomp True) )
 165   ,  ( "no-recomp"      , NoArg (writeIORef v_Recomp False) )
 166
 167         ------- ways --------------------------------------------------------
 168   ,  ( "prof"           , NoArg (addNoDups v_Ways       WayProf) )
 169   ,  ( "unreg"          , NoArg (addNoDups v_Ways       WayUnreg) )
 170   ,  ( "ticky"          , NoArg (addNoDups v_Ways       WayTicky) )
 171   ,  ( "parallel"       , NoArg (addNoDups v_Ways       WayPar) )
 172   ,  ( "gransim"        , NoArg (addNoDups v_Ways       WayGran) )
 173   ,  ( "smp"            , NoArg (addNoDups v_Ways       WaySMP) )
 174   ,  ( "debug"          , NoArg (addNoDups v_Ways       WayDebug) )
 175         -- ToDo: user ways
 176
 177         ------ Debugging ----------------------------------------------------
 178   ,  ( "dppr-noprags",     PassFlag (add v_Opt_C) )
 179   ,  ( "dppr-debug",       PassFlag (add v_Opt_C) )
 180   ,  ( "dppr-user-length", AnySuffix (add v_Opt_C) )
 181       -- rest of the debugging flags are dynamic
 182
 183         ------- Interface files ---------------------------------------------
 184   ,  ( "hi"             , NoArg (writeIORef v_ProduceHi True) )
 185   ,  ( "nohi"           , NoArg (writeIORef v_ProduceHi False) )
 186
 187         --------- Profiling --------------------------------------------------
 188   ,  ( "auto-dicts"     , NoArg (add v_Opt_C "-fauto-sccs-on-dicts") )
 189   ,  ( "auto-all"       , NoArg (add v_Opt_C "-fauto-sccs-on-all-toplevs") )
 190   ,  ( "auto"           , NoArg (add v_Opt_C "-fauto-sccs-on-exported-toplevs") )
 191   ,  ( "caf-all"        , NoArg (add v_Opt_C "-fauto-sccs-on-individual-cafs") )
 192          -- "ignore-sccs"  doesn't work  (ToDo)
 193
 194   ,  ( "no-auto-dicts"  , NoArg (add v_Anti_opt_C "-fauto-sccs-on-dicts") )
 195   ,  ( "no-auto-all"    , NoArg (add v_Anti_opt_C "-fauto-sccs-on-all-toplevs") )
 196   ,  ( "no-auto"        , NoArg (add v_Anti_opt_C "-fauto-sccs-on-exported-toplevs") )
 197   ,  ( "no-caf-all"     , NoArg (add v_Anti_opt_C "-fauto-sccs-on-individual-cafs") )
 198
 199         ------- Miscellaneous -----------------------------------------------
 200   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
 201   ,  ( "no-hs-main"     , NoArg (writeIORef v_NoHsMain True) )
 202
 203         ------- Output Redirection ------------------------------------------
 204   ,  ( "odir"           , HasArg (writeIORef v_Output_dir  . Just) )
 205   ,  ( "o"              , SepArg (writeIORef v_Output_file . Just) )
 206   ,  ( "osuf"           , HasArg (writeIORef v_Object_suf  . Just) )
 207   ,  ( "hisuf"          , HasArg (writeIORef v_Hi_suf) )
 208   ,  ( "tmpdir"         , HasArg (writeIORef v_TmpDir . (++ "/")) )
 209   ,  ( "ohi"            , HasArg (\s -> case s of
 210                                           "-" -> writeIORef v_Hi_on_stdout True
 211                                           _   -> writeIORef v_Output_hi (Just s)) )
 212         -- -odump?
 213
 214   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef v_Keep_hc_files True) )
 215   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef v_Keep_s_files  True) )
 216   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef v_Keep_raw_s_files  True) )
 217   ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef v_Keep_tmp_files True) )
 218
 219   ,  ( "split-objs"     , NoArg (if can_split
 220                                     then do writeIORef v_Split_object_files True
 221                                             add v_Opt_C "-fglobalise-toplev-names"
 222                                     else hPutStrLn stderr
 223                                             "warning: don't know how to  split \
 224                                             \object files on this architecture"
 225                                 ) )
 226
 227         ------- Include/Import Paths ----------------------------------------
 228   ,  ( "i"              , OptPrefix (addToDirList v_Import_paths) )
 229   ,  ( "I"              , Prefix    (addToDirList v_Include_paths) )
 230
 231         ------- Libraries ---------------------------------------------------
 232   ,  ( "L"              , Prefix (addToDirList v_Library_paths) )
 233   ,  ( "l"              , Prefix (add v_Cmdline_libraries) )
 234
 235         ------- Packages ----------------------------------------------------
 236   ,  ( "package-name"   , HasArg (\s -> add v_Opt_C ("-inpackage="++s)) )
 237
 238   ,  ( "package"        , HasArg (addPackage) )
 239   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
 240
 241   ,  ( "-list-packages"  , NoArg (listPackages) )
 242   ,  ( "-add-package"    , NoArg (newPackage) )
 243   ,  ( "-delete-package" , SepArg (deletePackage) )
 244
 245         ------- Specific phases  --------------------------------------------
 246   ,  ( "pgmL"           , HasArg (writeIORef v_Pgm_L) )
 247   ,  ( "pgmP"           , HasArg (writeIORef v_Pgm_P) )
 248   ,  ( "pgmc"           , HasArg (writeIORef v_Pgm_c) )
 249   ,  ( "pgmm"           , HasArg (writeIORef v_Pgm_m) )
 250   ,  ( "pgms"           , HasArg (writeIORef v_Pgm_s) )
 251   ,  ( "pgma"           , HasArg (writeIORef v_Pgm_a) )
 252   ,  ( "pgml"           , HasArg (writeIORef v_Pgm_l) )
 253
 254   ,  ( "optdep"         , HasArg (add v_Opt_dep) )
 255   ,  ( "optl"           , HasArg (add v_Opt_l) )
 256   ,  ( "optdll"         , HasArg (add v_Opt_dll) )
 257
 258         ------ Warning opts -------------------------------------------------
 259   ,  ( "W"              , NoArg (writeIORef v_Warning_opt W_) )
 260   ,  ( "Wall"           , NoArg (writeIORef v_Warning_opt W_all) )
 261   ,  ( "Wnot"           , NoArg (writeIORef v_Warning_opt W_not) )
 262   ,  ( "w"              , NoArg (writeIORef v_Warning_opt W_not) )
 263
 264         ----- Linker --------------------------------------------------------
 265   ,  ( "static"         , NoArg (writeIORef v_Static True) )
 266   ,  ( "dynamic"        , NoArg (writeIORef v_Static False) )
 267   ,  ( "rdynamic"       , NoArg (return ()) ) -- ignored for compat w/ gcc
 268
 269         ----- RTS opts ------------------------------------------------------
 270   ,  ( "H"                 , HasArg (setHeapSize . fromIntegral . decodeSize) )
 271   ,  ( "Rghc-timing"       , NoArg  (enableTimingStats) )
 272
 273         ------ Compiler flags -----------------------------------------------
 274   ,  ( "O2-for-C"          , NoArg (writeIORef v_minus_o2_for_C True) )
 275   ,  ( "O"                 , OptPrefix (setOptLevel) )
 276
 277   ,  ( "fno-asm-mangling"  , NoArg (writeIORef v_Do_asm_mangling False) )
 278
 279   ,  ( "fmax-simplifier-iterations",
 280                 Prefix (writeIORef v_MaxSimplifierIterations . read) )
 281
 282   ,  ( "fusagesp"          , NoArg (do writeIORef v_UsageSPInf True
 283                                        add v_Opt_C "-fusagesp-on") )
 284
 285   ,  ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
 286                                        add v_Opt_C "-fexcess-precision"))
 287
 288         -- Optimisation flags are treated specially, so the normal
 289         -- -fno-* pattern below doesn't work.  We therefore allow
 290         -- certain optimisation passes to be turned off explicitly:
 291   ,  ( "fno-strictness"    , NoArg (writeIORef v_Strictness False) )
 292   ,  ( "fno-cpr"           , NoArg (writeIORef v_CPR False) )
 293   ,  ( "fno-cse"           , NoArg (writeIORef v_CSE False) )
 294
 295         -- flags that are "active negatives"
 296   ,  ( "fno-prune-tydecls"      , PassFlag (add v_Opt_C) )
 297   ,  ( "fno-prune-instdecls"    , PassFlag (add v_Opt_C) )
 298   ,  ( "fno-pre-inlining"       , PassFlag (add v_Opt_C) )
 299
 300         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
 301   ,  ( "fno-",                  PrefixPred (\s -> isStaticHscFlag ("f"++s))
 302                                     (\s -> add v_Anti_opt_C ("-f"++s)) )
 303
 304         -- Pass all remaining "-f<blah>" options to hsc
 305   ,  ( "f",                     AnySuffixPred (isStaticHscFlag) (add v_Opt_C) )
 306   ]
 307
 308 -----------------------------------------------------------------------------
 309 -- parse the dynamic arguments
 310
 311 -- v_InitDynFlags
 312 --      is the "baseline" dynamic flags, initialised from
 313 --      the defaults and command line options, and updated by the
 314 --      ':s' command in GHCi.
 315 --
 316 -- v_DynFlags
 317 --      is the dynamic flags for the current compilation.  It is reset
 318 --      to the value of v_InitDynFlags before each compilation, then
 319 --      updated by reading any OPTIONS pragma in the current module.
 320
 321 GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
 322 GLOBAL_VAR(v_DynFlags,     defaultDynFlags, DynFlags)
 323
 324 updDynFlags f = do
 325    dfs <- readIORef v_DynFlags
 326    writeIORef v_DynFlags (f dfs)
 327
 328 getDynFlags :: IO DynFlags
 329 getDynFlags = readIORef v_DynFlags
 330
 331 dynFlag :: (DynFlags -> a) -> IO a
 332 dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
 333
 334 setDynFlag f   = updDynFlags (\dfs -> dfs{ flags = f : flags dfs })
 335 unSetDynFlag f = updDynFlags (\dfs -> dfs{ flags = filter (/= f) (flags dfs) })
 336
 337 addOpt_L     a = updDynFlags (\s -> s{opt_L =  a : opt_L s})
 338 addOpt_P     a = updDynFlags (\s -> s{opt_P =  a : opt_P s})
 339 addOpt_c     a = updDynFlags (\s -> s{opt_c =  a : opt_c s})
 340 addOpt_a     a = updDynFlags (\s -> s{opt_a =  a : opt_a s})
 341 addOpt_m     a = updDynFlags (\s -> s{opt_m =  a : opt_m s})
 342
 343 addCmdlineHCInclude a =
 344    updDynFlags (\s -> s{cmdlineHcIncludes =  a : cmdlineHcIncludes s})
 345
 346         -- we add to the options from the front, so we need to reverse the list
 347 getOpts :: (DynFlags -> [a]) -> IO [a]
 348 getOpts opts = dynFlag opts >>= return . reverse
 349
 350 -- we can only change HscC to HscAsm and vice-versa with dynamic flags
 351 -- (-fvia-C and -fasm).
 352 setLang l = do
 353    dfs <- readIORef v_DynFlags
 354    case hscLang dfs of
 355         HscC   -> writeIORef v_DynFlags dfs{ hscLang = l }
 356         HscAsm -> writeIORef v_DynFlags dfs{ hscLang = l }
 357         _      -> return ()
 358
 359 setVerbosityAtLeast n =
 360   updDynFlags (\dfs -> if verbosity dfs < n
 361                           then dfs{ verbosity = n }
 362                           else dfs)
 363
 364 setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 })
 365 setVerbosity n
 366   | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n })
 367   | otherwise     = throwDyn (OtherError "can't parse verbosity flag (-v<n>)")
 368
 369 getVerbFlag = do
 370    verb <- dynFlag verbosity
 371    if verb >= 3  then return  "-v" else return ""
 372
 373 dynamic_flags = [
 374
 375      ( "cpp",           NoArg  (updDynFlags (\s -> s{ cppFlag = True })) )
 376   ,  ( "#include",      HasArg (addCmdlineHCInclude) )
 377
 378   ,  ( "v",             OptPrefix (setVerbosity) )
 379
 380   ,  ( "optL",          HasArg (addOpt_L) )
 381   ,  ( "optP",          HasArg (addOpt_P) )
 382   ,  ( "optc",          HasArg (addOpt_c) )
 383   ,  ( "optm",          HasArg (addOpt_m) )
 384   ,  ( "opta",          HasArg (addOpt_a) )
 385
 386         ------ HsCpp opts ---------------------------------------------------
 387   ,  ( "D",             Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
 388   ,  ( "U",             Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )
 389
 390         ------ Debugging ----------------------------------------------------
 391   ,  ( "dstg-stats",    NoArg (writeIORef v_StgStats True) )
 392
 393   ,  ( "ddump-absC",             NoArg (setDynFlag Opt_D_dump_absC) )
 394   ,  ( "ddump-asm",              NoArg (setDynFlag Opt_D_dump_asm) )
 395   ,  ( "ddump-cpranal",          NoArg (setDynFlag Opt_D_dump_cpranal) )
 396   ,  ( "ddump-deriv",            NoArg (setDynFlag Opt_D_dump_deriv) )
 397   ,  ( "ddump-ds",               NoArg (setDynFlag Opt_D_dump_ds) )
 398   ,  ( "ddump-flatC",            NoArg (setDynFlag Opt_D_dump_flatC) )
 399   ,  ( "ddump-foreign",          NoArg (setDynFlag Opt_D_dump_foreign) )
 400   ,  ( "ddump-inlinings",        NoArg (setDynFlag Opt_D_dump_inlinings) )
 401   ,  ( "ddump-occur-anal",       NoArg (setDynFlag Opt_D_dump_occur_anal) )
 402   ,  ( "ddump-parsed",           NoArg (setDynFlag Opt_D_dump_parsed) )
 403   ,  ( "ddump-realC",            NoArg (setDynFlag Opt_D_dump_realC) )
 404   ,  ( "ddump-rn",               NoArg (setDynFlag Opt_D_dump_rn) )
 405   ,  ( "ddump-simpl",            NoArg (setDynFlag Opt_D_dump_simpl) )
 406   ,  ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) )
 407   ,  ( "ddump-spec",             NoArg (setDynFlag Opt_D_dump_spec) )
 408   ,  ( "ddump-sat",              NoArg (setDynFlag Opt_D_dump_sat) )
 409   ,  ( "ddump-stg",              NoArg (setDynFlag Opt_D_dump_stg) )
 410   ,  ( "ddump-stranal",          NoArg (setDynFlag Opt_D_dump_stranal) )
 411   ,  ( "ddump-tc",               NoArg (setDynFlag Opt_D_dump_tc) )
 412   ,  ( "ddump-types",            NoArg (setDynFlag Opt_D_dump_types) )
 413   ,  ( "ddump-rules",            NoArg (setDynFlag Opt_D_dump_rules) )
 414   ,  ( "ddump-usagesp",          NoArg (setDynFlag Opt_D_dump_usagesp) )
 415   ,  ( "ddump-cse",              NoArg (setDynFlag Opt_D_dump_cse) )
 416   ,  ( "ddump-worker-wrapper",   NoArg (setDynFlag Opt_D_dump_worker_wrapper) )
 417   ,  ( "dshow-passes",           NoArg (setVerbosity "2") )
 418   ,  ( "ddump-rn-trace",         NoArg (setDynFlag Opt_D_dump_rn_trace) )
 419   ,  ( "ddump-rn-stats",         NoArg (setDynFlag Opt_D_dump_rn_stats) )
 420   ,  ( "ddump-stix",             NoArg (setDynFlag Opt_D_dump_stix) )
 421   ,  ( "ddump-simpl-stats",      NoArg (setDynFlag Opt_D_dump_simpl_stats) )
 422   ,  ( "ddump-bcos",             NoArg (setDynFlag Opt_D_dump_BCOs) )
 423   ,  ( "dsource-stats",          NoArg (setDynFlag Opt_D_source_stats) )
 424   ,  ( "dverbose-core2core",     NoArg (setDynFlag Opt_D_verbose_core2core) )
 425   ,  ( "dverbose-stg2stg",       NoArg (setDynFlag Opt_D_verbose_stg2stg) )
 426   ,  ( "ddump-hi-diffs",         NoArg (setDynFlag Opt_D_dump_hi_diffs) )
 427   ,  ( "ddump-hi",               NoArg (setDynFlag Opt_D_dump_hi) )
 428   ,  ( "ddump-minimal-imports",  NoArg (setDynFlag Opt_D_dump_minimal_imports) )
 429   ,  ( "dcore-lint",             NoArg (setDynFlag Opt_DoCoreLinting) )
 430   ,  ( "dstg-lint",              NoArg (setDynFlag Opt_DoStgLinting) )
 431   ,  ( "dusagesp-lint",          NoArg (setDynFlag Opt_DoUSPLinting) )
 432
 433         ------ Machine dependant (-m<blah>) stuff ---------------------------
 434
 435   ,  ( "monly-2-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 2}) ))
 436   ,  ( "monly-3-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 3}) ))
 437   ,  ( "monly-4-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 4}) ))
 438
 439         ------ Compiler flags -----------------------------------------------
 440
 441   ,  ( "fasm",          AnySuffix (\_ -> setLang HscAsm) )
 442   ,  ( "fvia-c",        NoArg (setLang HscC) )
 443   ,  ( "fvia-C",        NoArg (setLang HscC) )
 444
 445         -- "active negatives"
 446   ,  ( "fno-implicit-prelude",  NoArg (setDynFlag Opt_NoImplicitPrelude) )
 447
 448         -- the rest of the -f* and -fno-* flags
 449   ,  ( "fno-",          PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
 450   ,  ( "f",             PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
 451  ]
 452
 453 -- these -f<blah> flags can all be reversed with -fno-<blah>
 454
 455 fFlags = [
 456   ( "warn-duplicate-exports",           Opt_WarnDuplicateExports ),
 457   ( "warn-hi-shadowing",                Opt_WarnHiShadows ),
 458   ( "warn-incomplete-patterns",         Opt_WarnIncompletePatterns ),
 459   ( "warn-missing-fields",              Opt_WarnMissingFields ),
 460   ( "warn-missing-methods",             Opt_WarnMissingMethods ),
 461   ( "warn-missing-signatures",          Opt_WarnMissingSigs ),
 462   ( "warn-name-shadowing",              Opt_WarnNameShadowing ),
 463   ( "warn-overlapping-patterns",        Opt_WarnOverlappingPatterns ),
 464   ( "warn-simple-patterns",             Opt_WarnSimplePatterns ),
 465   ( "warn-type-defaults",               Opt_WarnTypeDefaults ),
 466   ( "warn-unused-binds",                Opt_WarnUnusedBinds ),
 467   ( "warn-unused-imports",              Opt_WarnUnusedImports ),
 468   ( "warn-unused-matches",              Opt_WarnUnusedMatches ),
 469   ( "warn-deprecations",                Opt_WarnDeprecations ),
 470   ( "glasgow-exts",                     Opt_GlasgowExts ),
 471   ( "allow-overlapping-instances",      Opt_AllowOverlappingInstances ),
 472   ( "allow-undecidable-instances",      Opt_AllowUndecidableInstances ),
 473   ( "fgenerics",                        Opt_Generics ),
 474   ( "report-compile",                   Opt_ReportCompile )
 475   ]
 476
 477 isFFlag f = f `elem` (map fst fFlags)
 478 getFFlag f = fromJust (lookup f fFlags)
 479
 480 -----------------------------------------------------------------------------
 481 -- convert sizes like "3.5M" into integers
 482
 483 decodeSize :: String -> Integer
 484 decodeSize str
 485   | c == ""              = truncate n
 486   | c == "K" || c == "k" = truncate (n * 1000)
 487   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
 488   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
 489   | otherwise            = throwDyn (OtherError ("can't decode size: " ++ str))
 490   where (m, c) = span pred str
 491         n      = read m  :: Double
 492         pred c = isDigit c || c == '.'
 493
 494 floatOpt :: IORef Double -> String -> IO ()
 495 floatOpt ref str = writeIORef ref (read str :: Double)
 496
 497 -----------------------------------------------------------------------------
 498 -- RTS Hooks
 499
 500 foreign import "setHeapSize"       unsafe setHeapSize       :: Int -> IO ()
 501 foreign import "enableTimingStats" unsafe enableTimingStats :: IO ()
 502
 503 -----------------------------------------------------------------------------
 504 -- Build the Hsc static command line opts
 505
 506 buildStaticHscOpts :: IO [String]
 507 buildStaticHscOpts = do
 508
 509   opt_C_ <- getStaticOpts v_Opt_C       -- misc hsc opts from the command line
 510
 511         -- optimisation
 512   minus_o <- readIORef v_OptLevel
 513   let optimisation_opts =
 514         case minus_o of
 515             0 -> hsc_minusNoO_flags
 516             1 -> hsc_minusO_flags
 517             2 -> hsc_minusO2_flags
 518             _ -> error "unknown opt level"
 519             -- ToDo: -Ofile
 520
 521         -- take into account -fno-* flags by removing the equivalent -f*
 522         -- flag from our list.
 523   anti_flags <- getStaticOpts v_Anti_opt_C
 524   let basic_opts = opt_C_ ++ optimisation_opts
 525       filtered_opts = filter (`notElem` anti_flags) basic_opts
 526
 527   static <- (do s <- readIORef v_Static; if s then return "-static"
 528                                               else return "")
 529
 530   return ( static : filtered_opts )
 531
 532 -----------------------------------------------------------------------------
 533 -- Running an external program
 534
 535 -- sigh, here because both DriverMkDepend & DriverPipeline need it.
 536
 537 runSomething phase_name cmd
 538  = do
 539    verb <- dynFlag verbosity
 540    when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
 541    when (verb >= 3) $ hPutStrLn stderr cmd
 542    hFlush stderr
 543
 544    -- test for -n flag
 545    n <- readIORef v_Dry_run
 546    unless n $ do
 547
 548    -- and run it!
 549    exit_code <- kludgedSystem cmd phase_name
 550
 551    if exit_code /= ExitSuccess
 552         then throwDyn (PhaseFailed phase_name exit_code)
 553         else do when (verb >= 3) (hPutStr stderr "\n")
 554                 return ()
 555
 556 -----------------------------------------------------------------------------
 557 -- Via-C compilation stuff
 558
 559 -- flags returned are: ( all C compilations
 560 --                     , registerised HC compilations
 561 --                     )
 562
 563 machdepCCOpts
 564    | prefixMatch "alpha"   cTARGETPLATFORM
 565         = return ( ["-static"], [] )
 566
 567    | prefixMatch "hppa"    cTARGETPLATFORM
 568         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 569         -- (very nice, but too bad the HP /usr/include files don't agree.)
 570         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 571
 572    | prefixMatch "m68k"    cTARGETPLATFORM
 573       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 574       --    popping of args to routines to be explicit; if we let things
 575       --    be deferred 'til after an STGJUMP, imminent death is certain!
 576       --
 577       -- -fomit-frame-pointer : *don't*
 578       --     It's better to have a6 completely tied up being a frame pointer
 579       --     rather than let GCC pick random things to do with it.
 580       --     (If we want to steal a6, then we would try to do things
 581       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 582         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 583
 584    | prefixMatch "i386"    cTARGETPLATFORM
 585       -- -fno-defer-pop : basically the same game as for m68k
 586       --
 587       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 588       --   the fp (%ebp) for our register maps.
 589         = do n_regs <- dynFlag stolen_x86_regs
 590              sta    <- readIORef v_Static
 591              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "",
 592                         if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" ],
 593                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 594                         "-DSTOLEN_X86_REGS="++show n_regs ]
 595                     )
 596
 597    | prefixMatch "mips"    cTARGETPLATFORM
 598         = return ( ["static"], [] )
 599
 600    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 601         = return ( ["static"], ["-finhibit-size-directive"] )
 602
 603    | otherwise
 604         = return ( [], [] )