compiler/main/StaticFlagParser.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Static flags
   4 --
   5 -- Static flags can only be set once, on the command-line.  Inside GHC,
   6 -- each static flag corresponds to a top-level value, usually of type Bool.
   7 --
   8 -- (c) The University of Glasgow 2005
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module StaticFlagParser (parseStaticFlags) where
  13
  14 #include "HsVersions.h"
  15
  16 import StaticFlags
  17 import CmdLineParser
  18 import Config
  19 import Util
  20 import Panic
  21
  22 import Control.Monad
  23 import Data.Char
  24 import Data.IORef
  25 import Data.List
  26
  27 -----------------------------------------------------------------------------
  28 -- Static flags
  29
  30 parseStaticFlags :: [String] -> IO ([String], [String])
  31 parseStaticFlags args = do
  32   ready <- readIORef v_opt_C_ready
  33   when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")
  34
  35   (leftover, errs, warns1) <- processArgs static_flags args
  36   when (not (null errs)) $ ghcError (UsageError (unlines errs))
  37
  38     -- deal with the way flags: the way (eg. prof) gives rise to
  39     -- further flags, some of which might be static.
  40   way_flags <- findBuildTag
  41
  42     -- if we're unregisterised, add some more flags
  43   let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
  44                   | otherwise = []
  45
  46   (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags)
  47
  48     -- see sanity code in staticOpts
  49   writeIORef v_opt_C_ready True
  50
  51     -- TABLES_NEXT_TO_CODE affects the info table layout.
  52     -- Be careful to do this *after* all processArgs,
  53     -- because evaluating tablesNextToCode involves looking at the global
  54     -- static flags.  Those pesky global variables...
  55   let cg_flags | tablesNextToCode = ["-optc-DTABLES_NEXT_TO_CODE"]
  56                | otherwise        = []
  57
  58     -- HACK: -fexcess-precision is both a static and a dynamic flag.  If
  59     -- the static flag parser has slurped it, we must return it as a
  60     -- leftover too.  ToDo: make -fexcess-precision dynamic only.
  61   let excess_prec | opt_SimplExcessPrecision = ["-fexcess-precision"]
  62                   | otherwise                = []
  63
  64   when (not (null errs)) $ ghcError (UsageError (unlines errs))
  65   return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
  66           warns1 ++ warns2)
  67
  68 static_flags :: [Flag IO]
  69 -- All the static flags should appear in this list.  It describes how each
  70 -- static flag should be processed.  Two main purposes:
  71 -- (a) if a command-line flag doesn't appear in the list, GHC can complain
  72 -- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" things
  73 --
  74 -- The common (PassFlag addOpt) action puts the static flag into the bunch of
  75 -- things that are searched up by the top-level definitions like
  76 --      opt_foo = lookUp (fsLit "-dfoo")
  77
  78 -- Note that ordering is important in the following list: any flag which
  79 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
  80 -- flags further down the list with the same prefix.
  81
  82 static_flags = [
  83         ------- GHCi -------------------------------------------------------
  84     Flag "ignore-dot-ghci" (PassFlag addOpt) Supported
  85   , Flag "read-dot-ghci"   (NoArg (removeOpt "-ignore-dot-ghci")) Supported
  86
  87         ------- ways --------------------------------------------------------
  88   , Flag "prof"           (NoArg (addWay WayProf)) Supported
  89   , Flag "ticky"          (NoArg (addWay WayTicky)) Supported
  90   , Flag "parallel"       (NoArg (addWay WayPar)) Supported
  91   , Flag "gransim"        (NoArg (addWay WayGran)) Supported
  92   , Flag "smp"            (NoArg (addWay WayThreaded))
  93          (Deprecated "Use -threaded instead")
  94   , Flag "debug"          (NoArg (addWay WayDebug)) Supported
  95   , Flag "ndp"            (NoArg (addWay WayNDP)) Supported
  96   , Flag "threaded"       (NoArg (addWay WayThreaded)) Supported
  97         -- ToDo: user ways
  98
  99         ------ Debugging ----------------------------------------------------
 100   , Flag "dppr-debug"        (PassFlag addOpt) Supported
 101   , Flag "dsuppress-uniques" (PassFlag addOpt) Supported
 102   , Flag "dppr-user-length"  (AnySuffix addOpt) Supported
 103   , Flag "dopt-fuel"         (AnySuffix addOpt) Supported
 104   , Flag "dno-debug-output"  (PassFlag addOpt) Supported
 105       -- rest of the debugging flags are dynamic
 106
 107         --------- Profiling --------------------------------------------------
 108   , Flag "auto-all"       (NoArg (addOpt "-fauto-sccs-on-all-toplevs"))
 109          Supported
 110   , Flag "auto"           (NoArg (addOpt "-fauto-sccs-on-exported-toplevs"))
 111          Supported
 112   , Flag "caf-all"        (NoArg (addOpt "-fauto-sccs-on-individual-cafs"))
 113          Supported
 114          -- "ignore-sccs"  doesn't work  (ToDo)
 115
 116   , Flag "no-auto-all"    (NoArg (removeOpt "-fauto-sccs-on-all-toplevs"))
 117          Supported
 118   , Flag "no-auto"        (NoArg (removeOpt "-fauto-sccs-on-exported-toplevs"))
 119          Supported
 120   , Flag "no-caf-all"     (NoArg (removeOpt "-fauto-sccs-on-individual-cafs"))
 121          Supported
 122
 123         ----- Linker --------------------------------------------------------
 124   , Flag "static"         (PassFlag addOpt) Supported
 125   , Flag "dynamic"        (NoArg (removeOpt "-static")) Supported
 126     -- ignored for compat w/ gcc:
 127   , Flag "rdynamic"       (NoArg (return ())) Supported
 128
 129         ----- RTS opts ------------------------------------------------------
 130   , Flag "H"              (HasArg (setHeapSize . fromIntegral . decodeSize))
 131          Supported
 132   , Flag "Rghc-timing"    (NoArg  (enableTimingStats)) Supported
 133
 134         ------ Compiler flags -----------------------------------------------
 135         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
 136   , Flag "fno-"
 137          (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
 138          Supported
 139
 140         -- Pass all remaining "-f<blah>" options to hsc
 141   , Flag "f"                      (AnySuffixPred (isStaticFlag) addOpt)
 142          Supported
 143   ]
 144
 145 isStaticFlag :: String -> Bool
 146 isStaticFlag f =
 147   f `elem` [
 148     "fauto-sccs-on-all-toplevs",
 149     "fauto-sccs-on-exported-toplevs",
 150     "fauto-sccs-on-individual-cafs",
 151     "fscc-profiling",
 152     "fdicts-strict",
 153     "fspec-inline-join-points",
 154     "firrefutable-tuples",
 155     "fparallel",
 156     "fgransim",
 157     "fno-hi-version-check",
 158     "dno-black-holing",
 159     "fno-method-sharing",
 160     "fno-state-hack",
 161     "fno-ds-multi-tyvar",
 162     "fruntime-types",
 163     "fno-pre-inlining",
 164     "fexcess-precision",
 165     "static",
 166     "fhardwire-lib-paths",
 167     "funregisterised",
 168     "fext-core",
 169     "fcpr-off",
 170     "ferror-spans",
 171     "fPIC",
 172     "fhpc"
 173     ]
 174   || any (`isPrefixOf` f) [
 175     "fliberate-case-threshold",
 176     "fmax-worker-args",
 177     "fhistory-size",
 178     "funfolding-creation-threshold",
 179     "funfolding-use-threshold",
 180     "funfolding-fun-discount",
 181     "funfolding-keeness-factor"
 182      ]
 183
 184 unregFlags :: [String]
 185 unregFlags =
 186    [ "-optc-DNO_REGS"
 187    , "-optc-DUSE_MINIINTERPRETER"
 188    , "-fno-asm-mangling"
 189    , "-funregisterised"
 190    , "-fvia-C" ]
 191
 192 -----------------------------------------------------------------------------
 193 -- convert sizes like "3.5M" into integers
 194
 195 decodeSize :: String -> Integer
 196 decodeSize str
 197   | c == ""      = truncate n
 198   | c == "K" || c == "k" = truncate (n * 1000)
 199   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
 200   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
 201   | otherwise            = ghcError (CmdLineError ("can't decode size: " ++ str))
 202   where (m, c) = span pred str
 203         n      = readRational m
 204         pred c = isDigit c || c == '.'
 205
 206 -----------------------------------------------------------------------------
 207 -- RTS Hooks
 208
 209 foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
 210 foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
 211