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