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 "dsuppress-uniques"         (PassFlag addOpt)
 126   , Flag "dsuppress-coercions"       (PassFlag addOpt)
 127   , Flag "dsuppress-module-prefixes" (PassFlag addOpt)
 128   , Flag "dppr-user-length"          (AnySuffix addOpt)
 129   , Flag "dopt-fuel"                 (AnySuffix addOpt)
 130   , Flag "dtrace-level"              (AnySuffix addOpt)
 131   , Flag "dno-debug-output"          (PassFlag addOpt)
 132   , Flag "dstub-dead-values"         (PassFlag addOpt)
 133       -- rest of the debugging flags are dynamic
 134
 135         ----- Linker --------------------------------------------------------
 136   , Flag "static"         (PassFlag addOpt)
 137   , Flag "dynamic"        (NoArg (removeOpt "-static" >> addWay WayDyn))
 138     -- ignored for compat w/ gcc:
 139   , Flag "rdynamic"       (NoArg (return ()))
 140
 141         ----- RTS opts ------------------------------------------------------
 142   , Flag "H"              (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
 143
 144   , Flag "Rghc-timing"    (NoArg (liftEwM enableTimingStats))
 145
 146         ------ Compiler flags -----------------------------------------------
 147
 148         -- -fPIC requires extra checking: only the NCG supports it.
 149         -- See also DynFlags.parseDynamicFlags.
 150   , Flag "fPIC" (PassFlag setPIC)
 151
 152         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
 153   , Flag "fno-"
 154          (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
 155
 156
 157         -- Pass all remaining "-f<blah>" options to hsc
 158   , Flag "f" (AnySuffixPred isStaticFlag addOpt)
 159   ]
 160
 161 setPIC :: String -> StaticP ()
 162 setPIC | cGhcWithNativeCodeGen == "YES" || cGhcUnregisterised == "YES"
 163        = addOpt
 164        | otherwise
 165        = ghcError $ CmdLineError "-fPIC is not supported on this platform"
 166
 167 isStaticFlag :: String -> Bool
 168 isStaticFlag f =
 169   f `elem` [
 170     "fscc-profiling",
 171     "fdicts-strict",
 172     "fspec-inline-join-points",
 173     "firrefutable-tuples",
 174     "fparallel",
 175     "fgransim",
 176     "fno-hi-version-check",
 177     "dno-black-holing",
 178     "fno-state-hack",
 179     "fsimple-list-literals",
 180     "fno-ds-multi-tyvar",
 181     "fruntime-types",
 182     "fno-pre-inlining",
 183     "fexcess-precision",
 184     "static",
 185     "fhardwire-lib-paths",
 186     "funregisterised",
 187     "fcpr-off",
 188     "ferror-spans",
 189     "fPIC",
 190     "fhpc"
 191     ]
 192   || any (`isPrefixOf` f) [
 193     "fliberate-case-threshold",
 194     "fmax-worker-args",
 195     "fhistory-size",
 196     "funfolding-creation-threshold",
 197     "funfolding-use-threshold",
 198     "funfolding-fun-discount",
 199     "funfolding-keeness-factor"
 200      ]
 201
 202 unregFlags :: [Located String]
 203 unregFlags = map (mkGeneralLocated "in unregFlags")
 204    [ "-optc-DNO_REGS"
 205    , "-optc-DUSE_MINIINTERPRETER"
 206    , "-fno-asm-mangling"
 207    , "-funregisterised" ]
 208
 209 -----------------------------------------------------------------------------
 210 -- convert sizes like "3.5M" into integers
 211
 212 decodeSize :: String -> Integer
 213 decodeSize str
 214   | c == ""      = truncate n
 215   | c == "K" || c == "k" = truncate (n * 1000)
 216   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
 217   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
 218   | otherwise            = ghcError (CmdLineError ("can't decode size: " ++ str))
 219   where (m, c) = span pred str
 220         n      = readRational m
 221         pred c = isDigit c || c == '.'
 222
 223
 224 type StaticP = EwM IO
 225
 226 addOpt :: String -> StaticP ()
 227 addOpt = liftEwM . SF.addOpt
 228
 229 addWay :: WayName -> StaticP ()
 230 addWay = liftEwM . SF.addWay
 231
 232 removeOpt :: String -> StaticP ()
 233 removeOpt = liftEwM . SF.removeOpt
 234
 235 -----------------------------------------------------------------------------
 236 -- RTS Hooks
 237
 238 foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
 239 foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
 240