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