StaticFlagParser.hs 6.28 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
-----------------------------------------------------------------------------
--
-- 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
--
-----------------------------------------------------------------------------

12
13
14
15
16
module StaticFlagParser (
        parseStaticFlags,
        parseStaticFlagsFull,
        flagsStatic
    ) where
17
18
19

#include "HsVersions.h"

20
import qualified StaticFlags as SF
ian@well-typed.com's avatar
ian@well-typed.com committed
21
import StaticFlags ( v_opt_C_ready, opt_SimplExcessPrecision )
22
import CmdLineParser
23
import SrcLoc
24
25
26
27
28
29
30
31
32
33
34
import Util
import Panic

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

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

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
-- | 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?
--
50
parseStaticFlags :: [Located String] -> IO ([Located String], [Located String])
51
52
53
54
55
56
57
58
parseStaticFlags = parseStaticFlagsFull flagsStatic

-- | Parse GHC's static flags as @parseStaticFlags@ does. However it also
-- takes a list of available static flags, such that certain flags can be
-- enabled or disabled through this argument.
parseStaticFlagsFull :: [Flag IO] -> [Located String]
                     -> IO ([Located String], [Located String])
parseStaticFlagsFull flagsAvailable args = do
59
60
61
  ready <- readIORef v_opt_C_ready
  when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")

ian@well-typed.com's avatar
ian@well-typed.com committed
62
  (leftover, errs, warns) <- processArgs flagsAvailable args
63
  when (not (null errs)) $ ghcError $ errorsToGhcException errs
64
65
66
67
68

    -- see sanity code in staticOpts
  writeIORef v_opt_C_ready True

    -- HACK: -fexcess-precision is both a static and a dynamic flag.  If
dterei's avatar
dterei committed
69
    -- the static flag parser has slurped it, we must return it as a
70
    -- leftover too.  ToDo: make -fexcess-precision dynamic only.
71
72
73
74
  let excess_prec
       | opt_SimplExcessPrecision = map (mkGeneralLocated "in excess_prec")
                                        ["-fexcess-precision"]
       | otherwise                = []
75

ian@well-typed.com's avatar
ian@well-typed.com committed
76
  return (excess_prec ++ leftover, warns)
77

78
flagsStatic :: [Flag IO]
79
80
81
82
83
84
85
-- 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
86
--      opt_foo = lookUp (fsLit "-dfoo")
87
88
89
90
91

-- 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.

92
flagsStatic = [
93
        ------ Debugging ----------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
94
    Flag "dppr-debug"                  (PassFlag addOpt)
95
96
97
98
99
100
  , 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)
101
  , Flag "dsuppress-var-kinds"         (PassFlag addOpt)
102
103
104
  , Flag "dsuppress-type-signatures"   (PassFlag addOpt)
  , Flag "dopt-fuel"                   (AnySuffix addOpt)
  , Flag "dno-debug-output"            (PassFlag addOpt)
105
106
107
      -- rest of the debugging flags are dynamic

        ----- RTS opts ------------------------------------------------------
108
  , Flag "H"              (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
dterei's avatar
dterei committed
109

110
  , Flag "Rghc-timing"    (NoArg (liftEwM enableTimingStats))
111
112

        ------ Compiler flags -----------------------------------------------
113

114
        -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
115
  , Flag "fno-"
116
         (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
dterei's avatar
dterei committed
117

118
119

        -- Pass all remaining "-f<blah>" options to hsc
120
  , Flag "f" (AnySuffixPred isStaticFlag addOpt)
121
122
123
124
125
126
127
128
129
130
  ]

isStaticFlag :: String -> Bool
isStaticFlag f =
  f `elem` [
    "fdicts-strict",
    "fspec-inline-join-points",
    "fno-hi-version-check",
    "dno-black-holing",
    "fno-state-hack",
131
    "fsimple-list-literals",
132
133
    "fruntime-types",
    "fno-pre-inlining",
134
    "fno-opt-coercion",
135
136
137
138
139
140
141
142
143
144
    "fexcess-precision",
    "fhardwire-lib-paths",
    "fcpr-off",
    "ferror-spans",
    "fhpc"
    ]
  || any (`isPrefixOf` f) [
    "fliberate-case-threshold",
    "fmax-worker-args",
    "funfolding-creation-threshold",
145
    "funfolding-dict-threshold",
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
    "funfolding-use-threshold",
    "funfolding-fun-discount",
    "funfolding-keeness-factor"
     ]

-----------------------------------------------------------------------------
-- 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 == '.'

165
166
167
168
169
170
171
172
173

type StaticP = EwM IO

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

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

174
175
176
177
178
179
-----------------------------------------------------------------------------
-- RTS Hooks

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