ghc/compiler/main/DriverFlags.hs

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