StaticFlagParser.hs 8.63 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
-----------------------------------------------------------------------------
--
-- Static flags
--
-- Static flags can only be set once, on the command-line.  Inside GHC,
-- each static flag corresponds to a top-level value, usually of type Bool.
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------

module StaticFlagParser (parseStaticFlags) where

#include "HsVersions.h"

16 17 18
import qualified StaticFlags as SF
import StaticFlags ( v_opt_C_ready, getWayFlags, tablesNextToCode, WayName(..)
                   , opt_SimplExcessPrecision )
19 20
import CmdLineParser
import Config
21
import SrcLoc
22 23 24 25 26 27 28 29 30 31 32
import Util
import Panic

import Control.Monad
import Data.Char
import Data.IORef
import Data.List

-----------------------------------------------------------------------------
-- Static flags

33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
-- | Parses GHC's static flags from a list of command line arguments.
--
-- These flags are static in the sense that they can be set only once and they
-- are global, meaning that they affect every instance of GHC running;
-- multiple GHC threads will use the same flags.
--
-- This function must be called before any session is started, i.e., before
-- the first call to 'GHC.withGhc'.
--
-- Static flags are more of a hack and are static for more or less historical
-- reasons.  In the long run, most static flags should eventually become
-- dynamic flags.
--
-- XXX: can we add an auto-generated list of static flags here?
--
48
parseStaticFlags :: [Located String] -> IO ([Located String], [Located String])
49 50 51 52
parseStaticFlags args = do
  ready <- readIORef v_opt_C_ready
  when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")

53
  (leftover, errs, warns1) <- processArgs static_flags args
54
  when (not (null errs)) $ ghcError $ errorsToGhcException errs
55 56 57

    -- deal with the way flags: the way (eg. prof) gives rise to
    -- 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 62

    -- if we're unregisterised, add some more flags
  let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
63
                  | otherwise = []
64

65
  (more_leftover, errs, warns2) <-
66
      processArgs static_flags (unreg_flags ++ way_flags')
67 68 69 70 71 72 73 74

    -- see sanity code in staticOpts
  writeIORef v_opt_C_ready True

    -- TABLES_NEXT_TO_CODE affects the info table layout.
    -- Be careful to do this *after* all processArgs,
    -- because evaluating tablesNextToCode involves looking at the global
    -- static flags.  Those pesky global variables...
75 76 77
  let cg_flags | tablesNextToCode = map (mkGeneralLocated "in cg_flags")
                                        ["-optc-DTABLES_NEXT_TO_CODE"]
               | otherwise        = []
78 79

    -- HACK: -fexcess-precision is both a static and a dynamic flag.  If
dterei's avatar
dterei committed
80
    -- the static flag parser has slurped it, we must return it as a
81
    -- leftover too.  ToDo: make -fexcess-precision dynamic only.
82 83 84 85
  let excess_prec
       | opt_SimplExcessPrecision = map (mkGeneralLocated "in excess_prec")
                                        ["-fexcess-precision"]
       | otherwise                = []
86

87
  when (not (null errs)) $ ghcError $ errorsToGhcException errs
88 89 90 91 92 93 94 95 96 97 98
  return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
          warns1 ++ warns2)

static_flags :: [Flag IO]
-- All the static flags should appear in this list.  It describes how each
-- static flag should be processed.  Two main purposes:
-- (a) if a command-line flag doesn't appear in the list, GHC can complain
-- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" things
--
-- The common (PassFlag addOpt) action puts the static flag into the bunch of
-- things that are searched up by the top-level definitions like
99
--      opt_foo = lookUp (fsLit "-dfoo")
100 101 102 103 104 105 106

-- Note that ordering is important in the following list: any flag which
-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
-- flags further down the list with the same prefix.

static_flags = [
        ------- ways --------------------------------------------------------
107
    Flag "prof"           (NoArg (addWay WayProf))
108 109 110 111 112 113 114 115 116
  , Flag "eventlog"       (NoArg (addWay WayEventLog))
  , Flag "parallel"       (NoArg (addWay WayPar))
  , Flag "gransim"        (NoArg (addWay WayGran))
  , Flag "smp"            (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead"))
  , Flag "debug"          (NoArg (addWay WayDebug))
  , Flag "ndp"            (NoArg (addWay WayNDP))
  , Flag "threaded"       (NoArg (addWay WayThreaded))

  , Flag "ticky"          (PassFlag (\f -> do addOpt f; addWay WayDebug))
117 118
    -- -ticky enables ticky-ticky code generation, and also implies -debug which
    -- is required to get the RTS ticky support.
119 120

        ------ Debugging ----------------------------------------------------
121 122 123 124 125 126 127
  , Flag "dppr-debug"                  (PassFlag addOpt)
  , Flag "dsuppress-all"               (PassFlag addOpt)
  , Flag "dsuppress-uniques"           (PassFlag addOpt)
  , Flag "dsuppress-coercions"         (PassFlag addOpt)
  , Flag "dsuppress-module-prefixes"   (PassFlag addOpt)
  , Flag "dsuppress-type-applications" (PassFlag addOpt)
  , Flag "dsuppress-idinfo"            (PassFlag addOpt)
128
  , Flag "dsuppress-var-kinds"         (PassFlag addOpt)
129 130 131 132
  , Flag "dsuppress-type-signatures"   (PassFlag addOpt)
  , Flag "dopt-fuel"                   (AnySuffix addOpt)
  , Flag "dno-debug-output"            (PassFlag addOpt)
  , Flag "dstub-dead-values"           (PassFlag addOpt)
133 134 135
      -- rest of the debugging flags are dynamic

        ----- Linker --------------------------------------------------------
136 137
  , Flag "static"         (PassFlag addOpt)
  , 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)))))
dterei's avatar
dterei committed
143

144
  , Flag "Rghc-timing"    (NoArg (liftEwM enableTimingStats))
145 146

        ------ Compiler flags -----------------------------------------------
147 148 149

        -- -fPIC requires extra checking: only the NCG supports it.
        -- 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)))
dterei's avatar
dterei committed
155

156 157

        -- Pass all remaining "-f<blah>" options to hsc
158
  , Flag "f" (AnySuffixPred isStaticFlag addOpt)
159 160
  ]

161
setPIC :: String -> StaticP ()
162 163 164 165 166
setPIC | cGhcWithNativeCodeGen == "YES" || cGhcUnregisterised == "YES"
       = addOpt
       | otherwise
       = ghcError $ CmdLineError "-fPIC is not supported on this platform"

167 168 169 170 171 172 173 174 175 176 177
isStaticFlag :: String -> Bool
isStaticFlag f =
  f `elem` [
    "fscc-profiling",
    "fdicts-strict",
    "fspec-inline-join-points",
    "fparallel",
    "fgransim",
    "fno-hi-version-check",
    "dno-black-holing",
    "fno-state-hack",
178
    "fsimple-list-literals",
179 180
    "fruntime-types",
    "fno-pre-inlining",
181
    "fno-opt-coercion",
182 183 184 185 186 187 188 189 190 191 192 193 194 195
    "fexcess-precision",
    "static",
    "fhardwire-lib-paths",
    "funregisterised",
    "fcpr-off",
    "ferror-spans",
    "fPIC",
    "fhpc"
    ]
  || any (`isPrefixOf` f) [
    "fliberate-case-threshold",
    "fmax-worker-args",
    "fhistory-size",
    "funfolding-creation-threshold",
196
    "funfolding-dict-threshold",
197 198 199 200 201
    "funfolding-use-threshold",
    "funfolding-fun-discount",
    "funfolding-keeness-factor"
     ]

202 203
unregFlags :: [Located String]
unregFlags = map (mkGeneralLocated "in unregFlags")
204 205
   [ "-optc-DNO_REGS"
   , "-optc-DUSE_MINIINTERPRETER"
206
   , "-funregisterised" ]
207 208 209 210 211 212 213 214 215 216 217 218 219 220 221

-----------------------------------------------------------------------------
-- convert sizes like "3.5M" into integers

decodeSize :: String -> Integer
decodeSize str
  | c == ""      = truncate n
  | c == "K" || c == "k" = truncate (n * 1000)
  | c == "M" || c == "m" = truncate (n * 1000 * 1000)
  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
  | otherwise            = ghcError (CmdLineError ("can't decode size: " ++ str))
  where (m, c) = span pred str
        n      = readRational m
        pred c = isDigit c || c == '.'

222 223 224 225 226 227 228 229 230 231 232 233

type StaticP = EwM IO

addOpt :: String -> StaticP ()
addOpt = liftEwM . SF.addOpt

addWay :: WayName -> StaticP ()
addWay = liftEwM . SF.addWay

removeOpt :: String -> StaticP ()
removeOpt = liftEwM . SF.removeOpt

234 235 236 237 238 239
-----------------------------------------------------------------------------
-- RTS Hooks

foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()