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