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