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