ghc/compiler/main/DriverFlags.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Driver flags
   4 --
   5 -- (c) The University of Glasgow 2000-2003
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module DriverFlags (
  10         processDynamicFlags,
  11         processStaticFlags,
  12
  13         addCmdlineHCInclude,
  14         buildStaticHscOpts,
  15         machdepCCOpts,
  16         picCCOpts,
  17
  18         processArgs, OptKind(..), -- for DriverMkDepend only
  19   ) where
  20
  21 #include "HsVersions.h"
  22
  23 import MkIface          ( showIface )
  24 import DriverState
  25 import DriverPhases
  26 import DriverUtil
  27 import SysTools
  28 import CmdLineOpts
  29 import Config
  30 import Util
  31 import Panic
  32 import FastString       ( mkFastString )
  33
  34 import EXCEPTION
  35 import DATA_IOREF       ( IORef, readIORef, writeIORef )
  36
  37 import System           ( exitWith, ExitCode(..) )
  38 import IO
  39 import Maybe
  40 import Monad
  41 import Char
  42
  43 -----------------------------------------------------------------------------
  44 -- Flags
  45
  46 -- Flag parsing is now done in stages:
  47 --
  48 --     * parse the initial list of flags and remove any flags understood
  49 --       by the driver only.  Determine whether we're in multi-compilation
  50 --       or single-compilation mode (done in Main.main).
  51 --
  52 --     * gather the list of "static" hsc flags, and assign them to the global
  53 --       static hsc flags variable.
  54 --
  55 --     * build the inital DynFlags from the remaining flags.
  56 --
  57 --     * complain if we've got any flags left over.
  58 --
  59 --     * for each source file: grab the OPTIONS, and build a new DynFlags
  60 --       to pass to the compiler.
  61
  62 -----------------------------------------------------------------------------
  63 -- Process command-line
  64
  65 processStaticFlags :: [String] -> IO [String]
  66 processStaticFlags opts = processArgs static_flags opts []
  67
  68 data OptKind
  69         = NoArg (IO ())                     -- flag with no argument
  70         | HasArg (String -> IO ())          -- flag has an argument (maybe prefix)
  71         | SepArg (String -> IO ())          -- flag has a separate argument
  72         | Prefix (String -> IO ())          -- flag is a prefix only
  73         | OptPrefix (String -> IO ())       -- flag may be a prefix
  74         | AnySuffix (String -> IO ())       -- flag is a prefix, pass whole arg to fn
  75         | PassFlag  (String -> IO ())       -- flag with no arg, pass flag to fn
  76         | PrefixPred (String -> Bool) (String -> IO ())
  77         | AnySuffixPred (String -> Bool) (String -> IO ())
  78
  79 processArgs :: [(String,OptKind)] -> [String] -> [String]
  80             -> IO [String]  -- returns spare args
  81 processArgs _spec [] spare = return (reverse spare)
  82
  83 processArgs spec args@(('-':arg):args') spare = do
  84   case findArg spec arg of
  85     Just (rest,action) -> do args' <- processOneArg action rest args
  86                              processArgs spec args' spare
  87     Nothing            -> processArgs spec args' (('-':arg):spare)
  88
  89 processArgs spec (arg:args) spare =
  90   processArgs spec args (arg:spare)
  91
  92 processOneArg :: OptKind -> String -> [String] -> IO [String]
  93 processOneArg action rest (dash_arg@('-':arg):args) =
  94   case action of
  95         NoArg  io ->
  96                 if rest == ""
  97                         then io >> return args
  98                         else unknownFlagErr dash_arg
  99
 100         HasArg fio ->
 101                 if rest /= ""
 102                         then fio rest >> return args
 103                         else case args of
 104                                 [] -> missingArgErr dash_arg
 105                                 (arg1:args1) -> fio arg1 >> return args1
 106
 107         SepArg fio ->
 108                 case args of
 109                         [] -> unknownFlagErr dash_arg
 110                         (arg1:args1) -> fio arg1 >> return args1
 111
 112         Prefix fio ->
 113                 if rest /= ""
 114                         then fio rest >> return args
 115                         else unknownFlagErr dash_arg
 116
 117         PrefixPred p fio ->
 118                 if rest /= ""
 119                         then fio rest >> return args
 120                         else unknownFlagErr dash_arg
 121
 122         OptPrefix fio       -> fio rest >> return args
 123
 124         AnySuffix fio       -> fio dash_arg >> return args
 125
 126         AnySuffixPred p fio -> fio dash_arg >> return args
 127
 128         PassFlag fio  ->
 129                 if rest /= ""
 130                         then unknownFlagErr dash_arg
 131                         else fio dash_arg >> return args
 132
 133 findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind)
 134 findArg spec arg
 135   = case [ (remove_spaces rest, k)
 136          | (pat,k)   <- spec,
 137            Just rest <- [maybePrefixMatch pat arg],
 138            arg_ok k rest arg ]
 139     of
 140         []      -> Nothing
 141         (one:_) -> Just one
 142
 143 arg_ok (NoArg _)            rest arg = null rest
 144 arg_ok (HasArg _)           rest arg = True
 145 arg_ok (SepArg _)           rest arg = null rest
 146 arg_ok (Prefix _)           rest arg = notNull rest
 147 arg_ok (PrefixPred p _)     rest arg = notNull rest && p rest
 148 arg_ok (OptPrefix _)        rest arg = True
 149 arg_ok (PassFlag _)         rest arg = null rest
 150 arg_ok (AnySuffix _)        rest arg = True
 151 arg_ok (AnySuffixPred p _)  rest arg = p arg
 152
 153 -----------------------------------------------------------------------------
 154 -- Static flags
 155
 156 -- note that ordering is important in the following list: any flag which
 157 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
 158 -- flags further down the list with the same prefix.
 159
 160 static_flags =
 161   [  ------- help / version ----------------------------------------------
 162      ( "?"               , NoArg showGhcUsage)
 163   ,  ( "-help"           , NoArg showGhcUsage)
 164   ,  ( "-print-libdir"   , NoArg (do getTopDir >>= putStrLn
 165                                      exitWith ExitSuccess))
 166   ,  ( "V"               , NoArg showVersion)
 167   ,  ( "-version"        , NoArg showVersion)
 168   ,  ( "-numeric-version", NoArg (do putStrLn cProjectVersion
 169                                      exitWith ExitSuccess))
 170
 171       ------- interfaces ----------------------------------------------------
 172   ,  ( "-show-iface"     , HasArg (\f -> do showIface f
 173                                             exitWith ExitSuccess))
 174
 175       ------- verbosity ----------------------------------------------------
 176   ,  ( "n"              , NoArg setDryRun )
 177
 178       ------- primary modes ------------------------------------------------
 179   ,  ( "M"              , PassFlag (setMode DoMkDependHS))
 180   ,  ( "E"              , PassFlag (setMode (StopBefore anyHsc)))
 181   ,  ( "C"              , PassFlag (\f -> do setMode (StopBefore HCc) f
 182                                              setTarget HscC))
 183   ,  ( "S"              , PassFlag (setMode (StopBefore As)))
 184   ,  ( "-make"          , PassFlag (setMode DoMake))
 185   ,  ( "-interactive"   , PassFlag (setMode DoInteractive))
 186   ,  ( "-mk-dll"        , NoArg (writeIORef v_GhcLink MkDLL))
 187   ,  ( "e"              , HasArg   (\s -> setMode (DoEval s) "-e"))
 188
 189         -- -fno-code says to stop after Hsc but don't generate any code.
 190   ,  ( "fno-code"       , PassFlag (\f -> do setMode (StopBefore HCc) f
 191                                              setTarget HscNothing
 192                                              setRecompFlag False))
 193
 194         ------- GHCi -------------------------------------------------------
 195   ,  ( "ignore-dot-ghci", NoArg (writeIORef v_Read_DotGHCi False) )
 196   ,  ( "read-dot-ghci"  , NoArg (writeIORef v_Read_DotGHCi True) )
 197
 198         ------- ways --------------------------------------------------------
 199   ,  ( "prof"           , NoArg (addNoDups v_Ways       WayProf) )
 200   ,  ( "unreg"          , NoArg (addNoDups v_Ways       WayUnreg) )
 201   ,  ( "ticky"          , NoArg (addNoDups v_Ways       WayTicky) )
 202   ,  ( "parallel"       , NoArg (addNoDups v_Ways       WayPar) )
 203   ,  ( "gransim"        , NoArg (addNoDups v_Ways       WayGran) )
 204   ,  ( "smp"            , NoArg (addNoDups v_Ways       WaySMP) )
 205   ,  ( "debug"          , NoArg (addNoDups v_Ways       WayDebug) )
 206   ,  ( "ndp"            , NoArg (addNoDups v_Ways       WayNDP) )
 207   ,  ( "threaded"       , NoArg (addNoDups v_Ways       WayThreaded) )
 208         -- ToDo: user ways
 209
 210         ------ RTS ways -----------------------------------------------------
 211
 212         ------ Debugging ----------------------------------------------------
 213   ,  ( "dppr-noprags",     PassFlag (add v_Opt_C) )
 214   ,  ( "dppr-debug",       PassFlag (add v_Opt_C) )
 215   ,  ( "dppr-user-length", AnySuffix (add v_Opt_C) )
 216       -- rest of the debugging flags are dynamic
 217
 218         --------- Profiling --------------------------------------------------
 219   ,  ( "auto-dicts"     , NoArg (add v_Opt_C "-fauto-sccs-on-dicts") )
 220   ,  ( "auto-all"       , NoArg (add v_Opt_C "-fauto-sccs-on-all-toplevs") )
 221   ,  ( "auto"           , NoArg (add v_Opt_C "-fauto-sccs-on-exported-toplevs") )
 222   ,  ( "caf-all"        , NoArg (add v_Opt_C "-fauto-sccs-on-individual-cafs") )
 223          -- "ignore-sccs"  doesn't work  (ToDo)
 224
 225   ,  ( "no-auto-dicts"  , NoArg (add v_Anti_opt_C "-fauto-sccs-on-dicts") )
 226   ,  ( "no-auto-all"    , NoArg (add v_Anti_opt_C "-fauto-sccs-on-all-toplevs") )
 227   ,  ( "no-auto"        , NoArg (add v_Anti_opt_C "-fauto-sccs-on-exported-toplevs") )
 228   ,  ( "no-caf-all"     , NoArg (add v_Anti_opt_C "-fauto-sccs-on-individual-cafs") )
 229
 230         ------- Miscellaneous -----------------------------------------------
 231   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
 232   ,  ( "no-hs-main"     , NoArg (writeIORef v_NoHsMain True) )
 233   ,  ( "main-is"        , SepArg setMainIs )
 234
 235         ------- Output Redirection ------------------------------------------
 236   ,  ( "odir"           , HasArg (writeIORef v_Output_dir  . Just) )
 237   ,  ( "o"              , SepArg (writeIORef v_Output_file . Just) )
 238   ,  ( "osuf"           , HasArg (writeIORef v_Object_suf) )
 239   ,  ( "hcsuf"          , HasArg (writeIORef v_HC_suf    ) )
 240   ,  ( "hisuf"          , HasArg (writeIORef v_Hi_suf    ) )
 241   ,  ( "hidir"          , HasArg (writeIORef v_Hi_dir . Just) )
 242   ,  ( "buildtag"       , HasArg (writeIORef v_Build_tag) )
 243   ,  ( "tmpdir"         , HasArg setTmpDir)
 244   ,  ( "ohi"            , HasArg (writeIORef v_Output_hi   . Just) )
 245         -- -odump?
 246
 247   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef v_Keep_hc_files True) )
 248   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef v_Keep_s_files  True) )
 249   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef v_Keep_raw_s_files  True) )
 250 #ifdef ILX
 251   ,  ( "keep-il-file"   , AnySuffix (\_ -> writeIORef v_Keep_il_files True) )
 252   ,  ( "keep-ilx-file"  , AnySuffix (\_ -> writeIORef v_Keep_ilx_files True) )
 253 #endif
 254   ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef v_Keep_tmp_files True) )
 255
 256   ,  ( "split-objs"     , NoArg (if can_split
 257                                     then do writeIORef v_Split_object_files True
 258                                             add v_Opt_C "-fglobalise-toplev-names"
 259                                     else hPutStrLn stderr
 260                                             "warning: don't know how to split object files on this architecture"
 261                                 ) )
 262
 263         ------- Include/Import Paths ----------------------------------------
 264   ,  ( "I"              , Prefix    (addToDirList v_Include_paths) )
 265
 266         ------- Libraries ---------------------------------------------------
 267   ,  ( "L"              , Prefix (addToDirList v_Library_paths) )
 268   ,  ( "l"              , AnySuffix (\s -> add v_Opt_l s >> add v_Opt_dll s) )
 269
 270 #ifdef darwin_TARGET_OS
 271         ------- Frameworks --------------------------------------------------
 272         -- -framework-path should really be -F ...
 273   ,  ( "framework-path" , HasArg (addToDirList v_Framework_paths) )
 274   ,  ( "framework"      , HasArg (add v_Cmdline_frameworks) )
 275 #endif
 276         ------- Specific phases  --------------------------------------------
 277   ,  ( "pgmL"           , HasArg setPgmL )
 278   ,  ( "pgmP"           , HasArg setPgmP )
 279   ,  ( "pgmF"           , HasArg setPgmF )
 280   ,  ( "pgmc"           , HasArg setPgmc )
 281   ,  ( "pgmm"           , HasArg setPgmm )
 282   ,  ( "pgms"           , HasArg setPgms )
 283   ,  ( "pgma"           , HasArg setPgma )
 284   ,  ( "pgml"           , HasArg setPgml )
 285   ,  ( "pgmdll"         , HasArg setPgmDLL )
 286 #ifdef ILX
 287   ,  ( "pgmI"           , HasArg setPgmI )
 288   ,  ( "pgmi"           , HasArg setPgmi )
 289 #endif
 290
 291   ,  ( "optdep"         , HasArg (add v_Opt_dep) )
 292   ,  ( "optl"           , HasArg (add v_Opt_l) )
 293   ,  ( "optdll"         , HasArg (add v_Opt_dll) )
 294
 295         ----- Linker --------------------------------------------------------
 296   ,  ( "c"              , NoArg (writeIORef v_GhcLink NoLink) )
 297   ,  ( "no-link"        , NoArg (writeIORef v_GhcLink NoLink) ) -- Deprecated
 298   ,  ( "static"         , NoArg (writeIORef v_Static True) )
 299   ,  ( "dynamic"        , NoArg (writeIORef v_Static False) )
 300   ,  ( "rdynamic"       , NoArg (return ()) ) -- ignored for compat w/ gcc
 301
 302         ----- RTS opts ------------------------------------------------------
 303   ,  ( "H"                 , HasArg (setHeapSize . fromIntegral . decodeSize) )
 304   ,  ( "Rghc-timing"       , NoArg  (enableTimingStats) )
 305
 306         ------ Compiler flags -----------------------------------------------
 307   ,  ( "fno-asm-mangling"  , NoArg (writeIORef v_Do_asm_mangling False) )
 308
 309   ,  ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
 310                                        add v_Opt_C "-fexcess-precision"))
 311
 312         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
 313   ,  ( "fno-",                  PrefixPred (\s -> isStaticHscFlag ("f"++s))
 314                                     (\s -> add v_Anti_opt_C ("-f"++s)) )
 315
 316         -- Pass all remaining "-f<blah>" options to hsc
 317   ,  ( "f",                     AnySuffixPred (isStaticHscFlag) (add v_Opt_C) )
 318   ]
 319
 320 dynamic_flags = [
 321
 322      ( "cpp",           NoArg  (updDynFlags (\s -> s{ cppFlag = True })) )
 323   ,  ( "F",             NoArg  (updDynFlags (\s -> s{ ppFlag = True })) )
 324   ,  ( "#include",      HasArg (addCmdlineHCInclude) )
 325
 326   ,  ( "v",             OptPrefix (setVerbosity) )
 327
 328   ,  ( "optL",          HasArg (addOpt_L) )
 329   ,  ( "optP",          HasArg (addOpt_P) )
 330   ,  ( "optF",          HasArg (addOpt_F) )
 331   ,  ( "optc",          HasArg (addOpt_c) )
 332   ,  ( "optm",          HasArg (addOpt_m) )
 333   ,  ( "opta",          HasArg (addOpt_a) )
 334 #ifdef ILX
 335   ,  ( "optI",          HasArg (addOpt_I) )
 336   ,  ( "opti",          HasArg (addOpt_i) )
 337 #endif
 338
 339         ------- recompilation checker --------------------------------------
 340   ,  ( "recomp"         , NoArg (setRecompFlag True) )
 341   ,  ( "no-recomp"      , NoArg (setRecompFlag False) )
 342
 343         ------- Packages ----------------------------------------------------
 344   ,  ( "package-conf"   , HasArg extraPkgConf_ )
 345   ,  ( "no-user-package-conf", NoArg noUserPkgConf_ )
 346   ,  ( "package-name"   , HasArg ignorePackage ) -- for compatibility
 347   ,  ( "package"        , HasArg exposePackage )
 348   ,  ( "hide-package"   , HasArg hidePackage )
 349   ,  ( "ignore-package" , HasArg ignorePackage )
 350   ,  ( "syslib"         , HasArg exposePackage )  -- for compatibility
 351
 352         ------ HsCpp opts ---------------------------------------------------
 353   ,  ( "D",             AnySuffix addOpt_P )
 354   ,  ( "U",             AnySuffix addOpt_P )
 355
 356         ------- Paths & stuff -----------------------------------------------
 357   ,  ( "i"              , OptPrefix addImportPath )
 358
 359         ------ Debugging ----------------------------------------------------
 360   ,  ( "dstg-stats",    NoArg (writeIORef v_StgStats True) )
 361
 362   ,  ( "ddump-cmm",              setDumpFlag Opt_D_dump_cmm)
 363   ,  ( "ddump-asm",              setDumpFlag Opt_D_dump_asm)
 364   ,  ( "ddump-cpranal",          setDumpFlag Opt_D_dump_cpranal)
 365   ,  ( "ddump-deriv",            setDumpFlag Opt_D_dump_deriv)
 366   ,  ( "ddump-ds",               setDumpFlag Opt_D_dump_ds)
 367   ,  ( "ddump-flatC",            setDumpFlag Opt_D_dump_flatC)
 368   ,  ( "ddump-foreign",          setDumpFlag Opt_D_dump_foreign)
 369   ,  ( "ddump-inlinings",        setDumpFlag Opt_D_dump_inlinings)
 370   ,  ( "ddump-occur-anal",       setDumpFlag Opt_D_dump_occur_anal)
 371   ,  ( "ddump-parsed",           setDumpFlag Opt_D_dump_parsed)
 372   ,  ( "ddump-rn",               setDumpFlag Opt_D_dump_rn)
 373   ,  ( "ddump-simpl",            setDumpFlag Opt_D_dump_simpl)
 374   ,  ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations)
 375   ,  ( "ddump-spec",             setDumpFlag Opt_D_dump_spec)
 376   ,  ( "ddump-prep",             setDumpFlag Opt_D_dump_prep)
 377   ,  ( "ddump-stg",              setDumpFlag Opt_D_dump_stg)
 378   ,  ( "ddump-stranal",          setDumpFlag Opt_D_dump_stranal)
 379   ,  ( "ddump-tc",               setDumpFlag Opt_D_dump_tc)
 380   ,  ( "ddump-types",            setDumpFlag Opt_D_dump_types)
 381   ,  ( "ddump-rules",            setDumpFlag Opt_D_dump_rules)
 382   ,  ( "ddump-cse",              setDumpFlag Opt_D_dump_cse)
 383   ,  ( "ddump-worker-wrapper",   setDumpFlag Opt_D_dump_worker_wrapper)
 384   ,  ( "ddump-rn-trace",         NoArg (setDynFlag Opt_D_dump_rn_trace))
 385   ,  ( "ddump-if-trace",         NoArg (setDynFlag Opt_D_dump_if_trace))
 386   ,  ( "ddump-tc-trace",         setDumpFlag Opt_D_dump_tc_trace)
 387   ,  ( "ddump-splices",          setDumpFlag Opt_D_dump_splices)
 388   ,  ( "ddump-rn-stats",         NoArg (setDynFlag Opt_D_dump_rn_stats))
 389   ,  ( "ddump-opt-cmm",          setDumpFlag Opt_D_dump_opt_cmm)
 390   ,  ( "ddump-simpl-stats",      setDumpFlag Opt_D_dump_simpl_stats)
 391   ,  ( "ddump-bcos",             setDumpFlag Opt_D_dump_BCOs)
 392   ,  ( "dsource-stats",          setDumpFlag Opt_D_source_stats)
 393   ,  ( "dverbose-core2core",     setDumpFlag Opt_D_verbose_core2core)
 394   ,  ( "dverbose-stg2stg",       setDumpFlag Opt_D_verbose_stg2stg)
 395   ,  ( "ddump-hi-diffs",         setDumpFlag Opt_D_dump_hi_diffs)
 396   ,  ( "ddump-hi",               setDumpFlag Opt_D_dump_hi)
 397   ,  ( "ddump-minimal-imports",  setDumpFlag Opt_D_dump_minimal_imports)
 398   ,  ( "ddump-vect",             setDumpFlag Opt_D_dump_vect)
 399   ,  ( "dcore-lint",             NoArg (setDynFlag Opt_DoCoreLinting))
 400   ,  ( "dstg-lint",              NoArg (setDynFlag Opt_DoStgLinting))
 401   ,  ( "dcmm-lint",              NoArg (setDynFlag Opt_DoCmmLinting))
 402   ,  ( "dshow-passes",           NoArg (setRecompFlag False >> setVerbosity "2") )
 403
 404         ------ Machine dependant (-m<blah>) stuff ---------------------------
 405
 406   ,  ( "monly-2-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 2}) ))
 407   ,  ( "monly-3-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 3}) ))
 408   ,  ( "monly-4-regs",  NoArg (updDynFlags (\s -> s{stolen_x86_regs = 4}) ))
 409
 410         ------ Warning opts -------------------------------------------------
 411   ,  ( "W"              , NoArg (mapM_ setDynFlag   minusWOpts)    )
 412   ,  ( "Werror"         , NoArg (setDynFlag         Opt_WarnIsError) )
 413   ,  ( "Wall"           , NoArg (mapM_ setDynFlag   minusWallOpts) )
 414   ,  ( "Wnot"           , NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */
 415   ,  ( "w"              , NoArg (mapM_ unSetDynFlag minusWallOpts) )
 416
 417         ------ Optimisation flags ------------------------------------------
 418   ,  ( "O"                 , NoArg (setOptLevel 1))
 419   ,  ( "Onot"              , NoArg (setOptLevel 0))
 420   ,  ( "O"                 , PrefixPred (all isDigit) (setOptLevel . read))
 421
 422   ,  ( "fmax-simplifier-iterations",
 423                 PrefixPred (all isDigit)
 424                   (\n -> updDynFlags (\dfs ->
 425                         dfs{ maxSimplIterations = read n })) )
 426
 427   ,  ( "frule-check",
 428                 SepArg (\s -> updDynFlags (\dfs -> dfs{ ruleCheck = Just s })))
 429
 430         ------ Compiler flags -----------------------------------------------
 431
 432   ,  ( "fasm",          AnySuffix (\_ -> setTarget HscAsm) )
 433   ,  ( "fvia-c",        NoArg (setTarget HscC) )
 434   ,  ( "fvia-C",        NoArg (setTarget HscC) )
 435   ,  ( "filx",          NoArg (setTarget HscILX) )
 436
 437   ,  ( "fglasgow-exts",    NoArg (mapM_ setDynFlag   glasgowExtsFlags) )
 438   ,  ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
 439
 440         -- the rest of the -f* and -fno-* flags
 441   ,  ( "fno-",          PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
 442   ,  ( "f",             PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
 443  ]
 444
 445 -- these -f<blah> flags can all be reversed with -fno-<blah>
 446
 447 fFlags = [
 448   ( "warn-duplicate-exports",           Opt_WarnDuplicateExports ),
 449   ( "warn-hi-shadowing",                Opt_WarnHiShadows ),
 450   ( "warn-incomplete-patterns",         Opt_WarnIncompletePatterns ),
 451   ( "warn-incomplete-record-updates",   Opt_WarnIncompletePatternsRecUpd ),
 452   ( "warn-missing-fields",              Opt_WarnMissingFields ),
 453   ( "warn-missing-methods",             Opt_WarnMissingMethods ),
 454   ( "warn-missing-signatures",          Opt_WarnMissingSigs ),
 455   ( "warn-name-shadowing",              Opt_WarnNameShadowing ),
 456   ( "warn-overlapping-patterns",        Opt_WarnOverlappingPatterns ),
 457   ( "warn-simple-patterns",             Opt_WarnSimplePatterns ),
 458   ( "warn-type-defaults",               Opt_WarnTypeDefaults ),
 459   ( "warn-unused-binds",                Opt_WarnUnusedBinds ),
 460   ( "warn-unused-imports",              Opt_WarnUnusedImports ),
 461   ( "warn-unused-matches",              Opt_WarnUnusedMatches ),
 462   ( "warn-deprecations",                Opt_WarnDeprecations ),
 463   ( "warn-orphans",                     Opt_WarnOrphans ),
 464   ( "fi",                               Opt_FFI ),  -- support `-ffi'...
 465   ( "ffi",                              Opt_FFI ),  -- ...and also `-fffi'
 466   ( "arrows",                           Opt_Arrows ), -- arrow syntax
 467   ( "parr",                             Opt_PArr ),
 468   ( "th",                               Opt_TH ),
 469   ( "implicit-prelude",                 Opt_ImplicitPrelude ),
 470   ( "scoped-type-variables",            Opt_ScopedTypeVariables ),
 471   ( "monomorphism-restriction",         Opt_MonomorphismRestriction ),
 472   ( "implicit-params",                  Opt_ImplicitParams ),
 473   ( "allow-overlapping-instances",      Opt_AllowOverlappingInstances ),
 474   ( "allow-undecidable-instances",      Opt_AllowUndecidableInstances ),
 475   ( "allow-incoherent-instances",       Opt_AllowIncoherentInstances ),
 476   ( "generics",                         Opt_Generics ),
 477   ( "strictness",                       Opt_Strictness ),
 478   ( "full-laziness",                    Opt_FullLaziness ),
 479   ( "cse",                              Opt_CSE ),
 480   ( "ignore-interface-pragmas",         Opt_IgnoreInterfacePragmas ),
 481   ( "omit-interface-pragmas",           Opt_OmitInterfacePragmas ),
 482   ( "do-lambda-eta-expansion",          Opt_DoLambdaEtaExpansion ),
 483   ( "ignore-asserts",                   Opt_IgnoreAsserts ),
 484   ( "do-eta-reduction",                 Opt_DoEtaReduction ),
 485   ( "case-merge",                       Opt_CaseMerge ),
 486   ( "unbox-strict-fields",              Opt_UnboxStrictFields )
 487   ]
 488
 489 glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams, Opt_ScopedTypeVariables ]
 490
 491 isFFlag f = f `elem` (map fst fFlags)
 492 getFFlag f = fromJust (lookup f fFlags)
 493
 494 -- -----------------------------------------------------------------------------
 495 -- Parsing the dynamic flags.
 496
 497 -- we use a temporary global variable, for convenience
 498
 499 GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
 500
 501 processDynamicFlags :: [String] -> DynFlags -> IO (DynFlags,[String])
 502 processDynamicFlags args dflags = do
 503   writeIORef v_DynFlags dflags
 504   spare <- processArgs dynamic_flags args []
 505   dflags <- readIORef v_DynFlags
 506   return (dflags,spare)
 507
 508 updDynFlags :: (DynFlags -> DynFlags) -> IO ()
 509 updDynFlags f = do dfs <- readIORef v_DynFlags
 510                    writeIORef v_DynFlags (f dfs)
 511
 512 setDynFlag, unSetDynFlag :: DynFlag -> IO ()
 513 setDynFlag f   = updDynFlags (\dfs -> dopt_set dfs f)
 514 unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f)
 515
 516 setDumpFlag :: DynFlag -> OptKind
 517 setDumpFlag dump_flag
 518   = NoArg (setRecompFlag False >> setDynFlag dump_flag)
 519         -- Whenver we -ddump, switch off the recompilation checker,
 520         -- else you don't see the dump!
 521
 522 addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s})
 523 addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s})
 524 addOpt_F a = updDynFlags (\s -> s{opt_F = a : opt_F s})
 525 addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s})
 526 addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s})
 527 addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s})
 528 #ifdef ILX
 529 addOpt_I a = updDynFlags (\s -> s{opt_I = a : opt_I s})
 530 addOpt_i a = updDynFlags (\s -> s{opt_i = a : opt_i s})
 531 #endif
 532
 533 setRecompFlag :: Bool -> IO ()
 534 setRecompFlag recomp = updDynFlags (\dfs -> dfs{ recompFlag = recomp })
 535
 536 setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 })
 537 setVerbosity n
 538   | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n })
 539   | otherwise     = throwDyn (UsageError "can't parse verbosity flag (-v<n>)")
 540
 541 addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes =  a : cmdlineHcIncludes s})
 542
 543 extraPkgConf_  p = updDynFlags (\s -> s{ extraPkgConfs = p : extraPkgConfs s })
 544 noUserPkgConf_   = updDynFlags (\s -> s{ readUserPkgConf = False })
 545
 546 exposePackage p =
 547   updDynFlags (\s -> s{ packageFlags = ExposePackage p : packageFlags s })
 548 hidePackage p =
 549   updDynFlags (\s -> s{ packageFlags = HidePackage p : packageFlags s })
 550 ignorePackage p =
 551   updDynFlags (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
 552
 553 -- -i on its own deletes the import paths
 554 addImportPath "" = updDynFlags (\s -> s{importPaths = []})
 555 addImportPath p  = do
 556   paths <- splitPathList p
 557   updDynFlags (\s -> s{importPaths = importPaths s ++ paths})
 558
 559 -- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags
 560 -- (-fvia-C, -fasm, -filx respectively).
 561 setTarget l = updDynFlags (\dfs -> case hscTarget dfs of
 562                                         HscC   -> dfs{ hscTarget = l }
 563                                         HscAsm -> dfs{ hscTarget = l }
 564                                         HscILX -> dfs{ hscTarget = l }
 565                                         _      -> dfs)
 566
 567 setOptLevel :: Int -> IO ()
 568 setOptLevel n
 569    = do dflags <- readIORef v_DynFlags
 570         if hscTarget dflags == HscInterpreted && n > 0
 571           then putStr "warning: -O conflicts with --interactive; -O ignored.\n"
 572           else writeIORef v_DynFlags (updOptLevel n dflags)
 573
 574 -----------------------------------------------------------------------------
 575 -- convert sizes like "3.5M" into integers
 576
 577 decodeSize :: String -> Integer
 578 decodeSize str
 579   | c == ""              = truncate n
 580   | c == "K" || c == "k" = truncate (n * 1000)
 581   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
 582   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
 583   | otherwise            = throwDyn (CmdLineError ("can't decode size: " ++ str))
 584   where (m, c) = span pred str
 585         n      = read m  :: Double
 586         pred c = isDigit c || c == '.'
 587
 588
 589 -----------------------------------------------------------------------------
 590 -- RTS Hooks
 591
 592 #if __GLASGOW_HASKELL__ >= 504
 593 foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
 594 foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
 595 #else
 596 foreign import "setHeapSize"       unsafe setHeapSize       :: Int -> IO ()
 597 foreign import "enableTimingStats" unsafe enableTimingStats :: IO ()
 598 #endif
 599
 600 -----------------------------------------------------------------------------
 601 -- Build the Hsc static command line opts
 602
 603 buildStaticHscOpts :: IO [String]
 604 buildStaticHscOpts = do
 605
 606   opt_C_ <- getStaticOpts v_Opt_C       -- misc hsc opts from the command line
 607
 608         -- take into account -fno-* flags by removing the equivalent -f*
 609         -- flag from our list.
 610   anti_flags <- getStaticOpts v_Anti_opt_C
 611   let basic_opts = opt_C_
 612       filtered_opts = filter (`notElem` anti_flags) basic_opts
 613
 614   static <- (do s <- readIORef v_Static; if s then return "-static"
 615                                               else return "")
 616
 617   return ( static : filtered_opts )
 618
 619 setMainIs :: String -> IO ()
 620 setMainIs arg
 621   | not (null main_mod)         -- The arg looked like "Foo.baz"
 622   = do { writeIORef v_MainFunIs (Just main_fn) ;
 623          writeIORef v_MainModIs (Just main_mod) }
 624
 625   | isUpper (head main_fn)      -- The arg looked like "Foo"
 626   = writeIORef v_MainModIs (Just main_fn)
 627
 628   | otherwise                   -- The arg looked like "baz"
 629   = writeIORef v_MainFunIs (Just main_fn)
 630   where
 631     (main_mod, main_fn) = split_longest_prefix arg (== '.')
 632
 633
 634 -----------------------------------------------------------------------------
 635 -- Via-C compilation stuff
 636
 637 -- flags returned are: ( all C compilations
 638 --                     , registerised HC compilations
 639 --                     )
 640
 641 machdepCCOpts dflags
 642 #if alpha_TARGET_ARCH
 643         = return ( ["-w", "-mieee"
 644 #ifdef HAVE_THREADED_RTS_SUPPORT
 645                     , "-D_REENTRANT"
 646 #endif
 647                    ], [] )
 648         -- For now, to suppress the gcc warning "call-clobbered
 649         -- register used for global register variable", we simply
 650         -- disable all warnings altogether using the -w flag. Oh well.
 651
 652 #elif hppa_TARGET_ARCH
 653         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 654         -- (very nice, but too bad the HP /usr/include files don't agree.)
 655         = return ( ["-D_HPUX_SOURCE"], [] )
 656
 657 #elif m68k_TARGET_ARCH
 658       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 659       --    popping of args to routines to be explicit; if we let things
 660       --    be deferred 'til after an STGJUMP, imminent death is certain!
 661       --
 662       -- -fomit-frame-pointer : *don't*
 663       --     It's better to have a6 completely tied up being a frame pointer
 664       --     rather than let GCC pick random things to do with it.
 665       --     (If we want to steal a6, then we would try to do things
 666       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 667         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 668
 669 #elif i386_TARGET_ARCH
 670       -- -fno-defer-pop : basically the same game as for m68k
 671       --
 672       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 673       --   the fp (%ebp) for our register maps.
 674         = do let n_regs = stolen_x86_regs dflags
 675              sta    <- readIORef v_Static
 676              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else ""
 677 --                    , if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else ""
 678                       ],
 679                       [ "-fno-defer-pop",
 680 #ifdef HAVE_GCC_MNO_OMIT_LFPTR
 681                         -- Some gccs are configured with
 682                         -- -momit-leaf-frame-pointer on by default, and it
 683                         -- apparently takes precedence over
 684                         -- -fomit-frame-pointer, so we disable it first here.
 685                         "-mno-omit-leaf-frame-pointer",
 686 #endif
 687                         "-fomit-frame-pointer",
 688                         -- we want -fno-builtin, because when gcc inlines
 689                         -- built-in functions like memcpy() it tends to
 690                         -- run out of registers, requiring -monly-n-regs
 691                         "-fno-builtin",
 692                         "-DSTOLEN_X86_REGS="++show n_regs ]
 693                     )
 694
 695 #elif ia64_TARGET_ARCH
 696         = return ( [], ["-fomit-frame-pointer", "-G0"] )
 697
 698 #elif x86_64_TARGET_ARCH
 699         = return ( [], ["-fomit-frame-pointer"] )
 700
 701 #elif mips_TARGET_ARCH
 702         = return ( ["-static"], [] )
 703
 704 #elif sparc_TARGET_ARCH
 705         = return ( [], ["-w"] )
 706         -- For now, to suppress the gcc warning "call-clobbered
 707         -- register used for global register variable", we simply
 708         -- disable all warnings altogether using the -w flag. Oh well.
 709
 710 #elif powerpc_apple_darwin_TARGET
 711       -- -no-cpp-precomp:
 712       --     Disable Apple's precompiling preprocessor. It's a great thing
 713       --     for "normal" programs, but it doesn't support register variable
 714       --     declarations.
 715         = return ( [], ["-no-cpp-precomp"] )
 716 #else
 717         = return ( [], [] )
 718 #endif
 719
 720 picCCOpts dflags
 721 #if darwin_TARGET_OS
 722       -- Apple prefers to do things the other way round.
 723       -- PIC is on by default.
 724       -- -mdynamic-no-pic:
 725       --     Turn off PIC code generation.
 726       -- -fno-common:
 727       --     Don't generate "common" symbols - these are unwanted
 728       --     in dynamic libraries.
 729
 730     | opt_PIC
 731         = return ["-fno-common"]
 732     | otherwise
 733         = return ["-mdynamic-no-pic"]
 734 #elif mingw32_TARGET_OS
 735       -- no -fPIC for Windows
 736         = return []
 737 #else
 738     | opt_PIC
 739         = return ["-fPIC"]
 740     | otherwise
 741         = return []
 742 #endif
 743
 744 -----------------------------------------------------------------------------
 745 -- local utils
 746
 747 -- -----------------------------------------------------------------------------
 748 -- Version and usage messages
 749
 750 showVersion :: IO ()
 751 showVersion = do
 752   putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
 753   exitWith ExitSuccess
 754
 755 showGhcUsage = do
 756   (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths
 757   mode <- readIORef v_GhcMode
 758   let usage_path
 759         | DoInteractive <- mode = ghci_usage_path
 760         | otherwise             = ghc_usage_path
 761   usage <- readFile usage_path
 762   dump usage
 763   exitWith ExitSuccess
 764   where
 765      dump ""          = return ()
 766      dump ('$':'$':s) = hPutStr stderr progName >> dump s
 767      dump (c:s)       = hPutChar stderr c >> dump s