ghc/compiler/main/DriverFlags.hs

   1 {-# OPTIONS -#include "hschooks.h" #-}
   2
   3 -----------------------------------------------------------------------------
   4 -- $Id: DriverFlags.hs,v 1.42 2001/01/30 10:52:14 simonmar 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 )
  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         ------- Interface files ---------------------------------------------
 191   ,  ( "hi"             , NoArg (writeIORef v_ProduceHi True) )
 192   ,  ( "nohi"           , NoArg (writeIORef v_ProduceHi False) )
 193
 194         --------- Profiling --------------------------------------------------
 195   ,  ( "auto-dicts"     , NoArg (add v_Opt_C "-fauto-sccs-on-dicts") )
 196   ,  ( "auto-all"       , NoArg (add v_Opt_C "-fauto-sccs-on-all-toplevs") )
 197   ,  ( "auto"           , NoArg (add v_Opt_C "-fauto-sccs-on-exported-toplevs") )
 198   ,  ( "caf-all"        , NoArg (add v_Opt_C "-fauto-sccs-on-individual-cafs") )
 199          -- "ignore-sccs"  doesn't work  (ToDo)
 200
 201   ,  ( "no-auto-dicts"  , NoArg (add v_Anti_opt_C "-fauto-sccs-on-dicts") )
 202   ,  ( "no-auto-all"    , NoArg (add v_Anti_opt_C "-fauto-sccs-on-all-toplevs") )
 203   ,  ( "no-auto"        , NoArg (add v_Anti_opt_C "-fauto-sccs-on-exported-toplevs") )
 204   ,  ( "no-caf-all"     , NoArg (add v_Anti_opt_C "-fauto-sccs-on-individual-cafs") )
 205
 206         ------- Miscellaneous -----------------------------------------------
 207   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
 208   ,  ( "no-hs-main"     , NoArg (writeIORef v_NoHsMain True) )
 209
 210         ------- Output Redirection ------------------------------------------
 211   ,  ( "odir"           , HasArg (writeIORef v_Output_dir  . Just) )
 212   ,  ( "o"              , SepArg (writeIORef v_Output_file . Just) )
 213   ,  ( "osuf"           , HasArg (writeIORef v_Object_suf  . Just) )
 214   ,  ( "hisuf"          , HasArg (writeIORef v_Hi_suf) )
 215   ,  ( "tmpdir"         , HasArg (writeIORef v_TmpDir . (++ "/")) )
 216   ,  ( "ohi"            , HasArg (\s -> case s of
 217                                           "-" -> writeIORef v_Hi_on_stdout True
 218                                           _   -> writeIORef v_Output_hi (Just s)) )
 219         -- -odump?
 220
 221   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef v_Keep_hc_files True) )
 222   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef v_Keep_s_files  True) )
 223   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef v_Keep_raw_s_files  True) )
 224   ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef v_Keep_tmp_files True) )
 225
 226   ,  ( "split-objs"     , NoArg (if can_split
 227                                     then do writeIORef v_Split_object_files True
 228                                             add v_Opt_C "-fglobalise-toplev-names"
 229                                     else hPutStrLn stderr
 230                                             "warning: don't know how to  split \
 231                                             \object files on this architecture"
 232                                 ) )
 233
 234         ------- Include/Import Paths ----------------------------------------
 235   ,  ( "i"              , OptPrefix (addToDirList v_Import_paths) )
 236   ,  ( "I"              , Prefix    (addToDirList v_Include_paths) )
 237
 238         ------- Libraries ---------------------------------------------------
 239   ,  ( "L"              , Prefix (addToDirList v_Library_paths) )
 240   ,  ( "l"              , Prefix (add v_Cmdline_libraries) )
 241
 242         ------- Packages ----------------------------------------------------
 243   ,  ( "package-name"   , HasArg (\s -> add v_Opt_C ("-inpackage="++s)) )
 244
 245   ,  ( "package"        , HasArg (addPackage) )
 246   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
 247
 248   ,  ( "-list-packages"  , NoArg (listPackages) )
 249   ,  ( "-add-package"    , NoArg (newPackage) )
 250   ,  ( "-delete-package" , SepArg (deletePackage) )
 251
 252         ------- Specific phases  --------------------------------------------
 253   ,  ( "pgmL"           , HasArg (writeIORef v_Pgm_L) )
 254   ,  ( "pgmP"           , HasArg (writeIORef v_Pgm_P) )
 255   ,  ( "pgmc"           , HasArg (writeIORef v_Pgm_c) )
 256   ,  ( "pgmm"           , HasArg (writeIORef v_Pgm_m) )
 257   ,  ( "pgms"           , HasArg (writeIORef v_Pgm_s) )
 258   ,  ( "pgma"           , HasArg (writeIORef v_Pgm_a) )
 259   ,  ( "pgml"           , HasArg (writeIORef v_Pgm_l) )
 260
 261   ,  ( "optdep"         , HasArg (add v_Opt_dep) )
 262   ,  ( "optl"           , HasArg (add v_Opt_l) )
 263   ,  ( "optdll"         , HasArg (add v_Opt_dll) )
 264
 265         ------ Warning opts -------------------------------------------------
 266   ,  ( "W"              , NoArg (writeIORef v_Warning_opt W_) )
 267   ,  ( "Wall"           , NoArg (writeIORef v_Warning_opt W_all) )
 268   ,  ( "Wnot"           , NoArg (writeIORef v_Warning_opt W_not) )
 269   ,  ( "w"              , NoArg (writeIORef v_Warning_opt W_not) )
 270
 271         ----- Linker --------------------------------------------------------
 272   ,  ( "static"         , NoArg (writeIORef v_Static True) )
 273   ,  ( "dynamic"        , NoArg (writeIORef v_Static False) )
 274   ,  ( "rdynamic"       , NoArg (return ()) ) -- ignored for compat w/ gcc
 275
 276         ----- RTS opts ------------------------------------------------------
 277   ,  ( "H"                 , HasArg (setHeapSize . fromIntegral . decodeSize) )
 278   ,  ( "Rghc-timing"       , NoArg  (enableTimingStats) )
 279
 280         ------ Compiler flags -----------------------------------------------
 281   ,  ( "O2-for-C"          , NoArg (writeIORef v_minus_o2_for_C True) )
 282   ,  ( "O"                 , OptPrefix (setOptLevel) )
 283
 284   ,  ( "fno-asm-mangling"  , NoArg (writeIORef v_Do_asm_mangling False) )
 285
 286   ,  ( "fmax-simplifier-iterations",
 287                 Prefix (writeIORef v_MaxSimplifierIterations . read) )
 288
 289   ,  ( "fusagesp"          , NoArg (do writeIORef v_UsageSPInf True
 290                                        add v_Opt_C "-fusagesp-on") )
 291
 292   ,  ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
 293                                        add v_Opt_C "-fexcess-precision"))
 294
 295         -- Optimisation flags are treated specially, so the normal
 296         -- -fno-* pattern below doesn't work.  We therefore allow
 297         -- certain optimisation passes to be turned off explicitly:
 298   ,  ( "fno-strictness"    , NoArg (writeIORef v_Strictness False) )
 299   ,  ( "fno-cpr"           , NoArg (writeIORef v_CPR False) )
 300   ,  ( "fno-cse"           , NoArg (writeIORef v_CSE False) )
 301
 302         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
 303   ,  ( "fno-",                  PrefixPred (\s -> isStaticHscFlag ("f"++s))
 304                                     (\s -> add v_Anti_opt_C ("-f"++s)) )
 305
 306         -- Pass all remaining "-f<blah>" options to hsc
 307   ,  ( "f",                     AnySuffixPred (isStaticHscFlag) (add v_Opt_C) )
 308   ]
 309
 310 -----------------------------------------------------------------------------
 311 -- parse the dynamic arguments
 312
 313 -- v_InitDynFlags
 314 --      is the "baseline" dynamic flags, initialised from
 315 --      the defaults and command line options, and updated by the
 316 --      ':s' command in GHCi.
 317 --
 318 -- v_DynFlags
 319 --      is the dynamic flags for the current compilation.  It is reset
 320 --      to the value of v_InitDynFlags before each compilation, then
 321 --      updated by reading any OPTIONS pragma in the current module.
 322
 323 GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
 324 GLOBAL_VAR(v_DynFlags,     defaultDynFlags, DynFlags)
 325
 326 updDynFlags f = do
 327    dfs <- readIORef v_DynFlags
 328    writeIORef v_DynFlags (f dfs)
 329
 330 getDynFlags :: IO DynFlags
 331 getDynFlags = readIORef v_DynFlags
 332
 333 dynFlag :: (DynFlags -> a) -> IO a
 334 dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
 335
 336 setDynFlag f   = updDynFlags (\dfs -> dfs{ flags = f : flags dfs })
 337 unSetDynFlag f = updDynFlags (\dfs -> dfs{ flags = filter (/= f) (flags dfs) })
 338
 339 addOpt_L     a = updDynFlags (\s -> s{opt_L =  a : opt_L s})
 340 addOpt_P     a = updDynFlags (\s -> s{opt_P =  a : opt_P s})
 341 addOpt_c     a = updDynFlags (\s -> s{opt_c =  a : opt_c s})
 342 addOpt_a     a = updDynFlags (\s -> s{opt_a =  a : opt_a s})
 343 addOpt_m     a = updDynFlags (\s -> s{opt_m =  a : opt_m s})
 344
 345 addCmdlineHCInclude a =
 346    updDynFlags (\s -> s{cmdlineHcIncludes =  a : cmdlineHcIncludes s})
 347
 348         -- we add to the options from the front, so we need to reverse the list
 349 getOpts :: (DynFlags -> [a]) -> IO [a]
 350 getOpts opts = dynFlag opts >>= return . reverse
 351
 352 -- we can only change HscC to HscAsm and vice-versa with dynamic flags
 353 -- (-fvia-C and -fasm).
 354 setLang l = do
 355    dfs <- readIORef v_DynFlags
 356    case hscLang dfs of
 357         HscC   -> writeIORef v_DynFlags dfs{ hscLang = l }
 358         HscAsm -> writeIORef v_DynFlags dfs{ hscLang = l }
 359         _      -> return ()
 360
 361 setVerbosityAtLeast n =
 362   updDynFlags (\dfs -> if verbosity dfs < n
 363                           then dfs{ verbosity = n }
 364                           else dfs)
 365
 366 setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 })
 367 setVerbosity n
 368   | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n })
 369   | otherwise     = throwDyn (OtherError "can't parse verbosity flag (-v<n>)")
 370
 371 getVerbFlag = do
 372    verb <- dynFlag verbosity
 373    if verb >= 3  then return  "-v" else return ""
 374
 375 dynamic_flags = [
 376
 377      ( "cpp",           NoArg  (updDynFlags (\s -> s{ cppFlag = True })) )
 378   ,  ( "#include",      HasArg (addCmdlineHCInclude) )
 379
 380   ,  ( "v",             OptPrefix (setVerbosity) )
 381
 382   ,  ( "optL",          HasArg (addOpt_L) )
 383   ,  ( "optP",          HasArg (addOpt_P) )
 384   ,  ( "optc",          HasArg (addOpt_c) )
 385   ,  ( "optm",          HasArg (addOpt_m) )
 386   ,  ( "opta",          HasArg (addOpt_a) )
 387
 388         ------ HsCpp opts ---------------------------------------------------
 389   ,  ( "D",             Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
 390   ,  ( "U",             Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )
 391
 392         ------ Debugging ----------------------------------------------------
 393   ,  ( "dstg-stats",    NoArg (writeIORef v_StgStats True) )
 394
 395   ,  ( "ddump-absC",             NoArg (setDynFlag Opt_D_dump_absC) )
 396   ,  ( "ddump-asm",              NoArg (setDynFlag Opt_D_dump_asm) )
 397   ,  ( "ddump-cpranal",          NoArg (setDynFlag Opt_D_dump_cpranal) )
 398   ,  ( "ddump-deriv",            NoArg (setDynFlag Opt_D_dump_deriv) )
 399   ,  ( "ddump-ds",               NoArg (setDynFlag Opt_D_dump_ds) )
 400   ,  ( "ddump-flatC",            NoArg (setDynFlag Opt_D_dump_flatC) )
 401   ,  ( "ddump-foreign",          NoArg (setDynFlag Opt_D_dump_foreign) )
 402   ,  ( "ddump-inlinings",        NoArg (setDynFlag Opt_D_dump_inlinings) )
 403   ,  ( "ddump-occur-anal",       NoArg (setDynFlag Opt_D_dump_occur_anal) )
 404   ,  ( "ddump-parsed",           NoArg (setDynFlag Opt_D_dump_parsed) )
 405   ,  ( "ddump-realC",            NoArg (setDynFlag Opt_D_dump_realC) )
 406   ,  ( "ddump-rn",               NoArg (setDynFlag Opt_D_dump_rn) )
 407   ,  ( "ddump-simpl",            NoArg (setDynFlag Opt_D_dump_simpl) )
 408   ,  ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) )
 409   ,  ( "ddump-spec",             NoArg (setDynFlag Opt_D_dump_spec) )
 410   ,  ( "ddump-sat",              NoArg (setDynFlag Opt_D_dump_sat) )
 411   ,  ( "ddump-stg",              NoArg (setDynFlag Opt_D_dump_stg) )
 412   ,  ( "ddump-stranal",          NoArg (setDynFlag Opt_D_dump_stranal) )
 413   ,  ( "ddump-tc",               NoArg (setDynFlag Opt_D_dump_tc) )
 414   ,  ( "ddump-types",            NoArg (setDynFlag Opt_D_dump_types) )
 415   ,  ( "ddump-rules",            NoArg (setDynFlag Opt_D_dump_rules) )
 416   ,  ( "ddump-usagesp",          NoArg (setDynFlag Opt_D_dump_usagesp) )
 417   ,  ( "ddump-cse",              NoArg (setDynFlag Opt_D_dump_cse) )
 418   ,  ( "ddump-worker-wrapper",   NoArg (setDynFlag Opt_D_dump_worker_wrapper) )
 419   ,  ( "dshow-passes",           NoArg (setVerbosity "2") )
 420   ,  ( "ddump-rn-trace",         NoArg (setDynFlag Opt_D_dump_rn_trace) )
 421   ,  ( "ddump-rn-stats",         NoArg (setDynFlag Opt_D_dump_rn_stats) )
 422   ,  ( "ddump-stix",             NoArg (setDynFlag Opt_D_dump_stix) )
 423   ,  ( "ddump-simpl-stats",      NoArg (setDynFlag Opt_D_dump_simpl_stats) )
 424   ,  ( "ddump-bcos",             NoArg (setDynFlag Opt_D_dump_BCOs) )
 425   ,  ( "dsource-stats",          NoArg (setDynFlag Opt_D_source_stats) )
 426   ,  ( "dverbose-core2core",     NoArg (setDynFlag Opt_D_verbose_core2core) )
 427   ,  ( "dverbose-stg2stg",       NoArg (setDynFlag Opt_D_verbose_stg2stg) )
 428   ,  ( "ddump-hi-diffs",         NoArg (setDynFlag Opt_D_dump_hi_diffs) )
 429   ,  ( "ddump-hi",               NoArg (setDynFlag Opt_D_dump_hi) )
 430   ,  ( "ddump-minimal-imports",  NoArg (setDynFlag Opt_D_dump_minimal_imports) )
 431   ,  ( "dcore-lint",             NoArg (setDynFlag Opt_DoCoreLinting) )
 432   ,  ( "dstg-lint",              NoArg (setDynFlag Opt_DoStgLinting) )
 433   ,  ( "dusagesp-lint",          NoArg (setDynFlag Opt_DoUSPLinting) )
 434
 435         ------ Machine dependant (-m<blah>) stuff ---------------------------
 436
 437   ,  ( "monly-2-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 2}) ))
 438   ,  ( "monly-3-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 3}) ))
 439   ,  ( "monly-4-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 4}) ))
 440
 441         ------ Compiler flags -----------------------------------------------
 442
 443   ,  ( "fasm",          AnySuffix (\_ -> setLang HscAsm) )
 444   ,  ( "fvia-c",        NoArg (setLang HscC) )
 445   ,  ( "fvia-C",        NoArg (setLang HscC) )
 446
 447         -- "active negatives"
 448   ,  ( "fno-implicit-prelude",  NoArg (setDynFlag Opt_NoImplicitPrelude) )
 449
 450         -- the rest of the -f* and -fno-* flags
 451   ,  ( "fno-",          PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
 452   ,  ( "f",             PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
 453  ]
 454
 455 -- these -f<blah> flags can all be reversed with -fno-<blah>
 456
 457 fFlags = [
 458   ( "warn-duplicate-exports",           Opt_WarnDuplicateExports ),
 459   ( "warn-hi-shadowing",                Opt_WarnHiShadows ),
 460   ( "warn-incomplete-patterns",         Opt_WarnIncompletePatterns ),
 461   ( "warn-missing-fields",              Opt_WarnMissingFields ),
 462   ( "warn-missing-methods",             Opt_WarnMissingMethods ),
 463   ( "warn-missing-signatures",          Opt_WarnMissingSigs ),
 464   ( "warn-name-shadowing",              Opt_WarnNameShadowing ),
 465   ( "warn-overlapping-patterns",        Opt_WarnOverlappingPatterns ),
 466   ( "warn-simple-patterns",             Opt_WarnSimplePatterns ),
 467   ( "warn-type-defaults",               Opt_WarnTypeDefaults ),
 468   ( "warn-unused-binds",                Opt_WarnUnusedBinds ),
 469   ( "warn-unused-imports",              Opt_WarnUnusedImports ),
 470   ( "warn-unused-matches",              Opt_WarnUnusedMatches ),
 471   ( "warn-deprecations",                Opt_WarnDeprecations ),
 472   ( "glasgow-exts",                     Opt_GlasgowExts ),
 473   ( "allow-overlapping-instances",      Opt_AllowOverlappingInstances ),
 474   ( "allow-undecidable-instances",      Opt_AllowUndecidableInstances ),
 475   ( "fgenerics",                        Opt_Generics ),
 476   ( "report-compile",                   Opt_ReportCompile )
 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 ( [], [] )