Make the GHC API a little more powerful.
[ghc.git] / 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 (
13 parseStaticFlags,
14 parseStaticFlagsFull,
15 flagsStatic
16 ) where
17
18 #include "HsVersions.h"
19
20 import qualified StaticFlags as SF
21 import StaticFlags ( v_opt_C_ready, getWayFlags, tablesNextToCode, WayName(..)
22 , opt_SimplExcessPrecision )
23 import CmdLineParser
24 import Config
25 import SrcLoc
26 import Util
27 import Panic
28
29 import Control.Monad
30 import Data.Char
31 import Data.IORef
32 import Data.List
33
34 -----------------------------------------------------------------------------
35 -- Static flags
36
37 -- | Parses GHC's static flags from a list of command line arguments.
38 --
39 -- These flags are static in the sense that they can be set only once and they
40 -- are global, meaning that they affect every instance of GHC running;
41 -- multiple GHC threads will use the same flags.
42 --
43 -- This function must be called before any session is started, i.e., before
44 -- the first call to 'GHC.withGhc'.
45 --
46 -- Static flags are more of a hack and are static for more or less historical
47 -- reasons. In the long run, most static flags should eventually become
48 -- dynamic flags.
49 --
50 -- XXX: can we add an auto-generated list of static flags here?
51 --
52 parseStaticFlags :: [Located String] -> IO ([Located String], [Located String])
53 parseStaticFlags = parseStaticFlagsFull flagsStatic
54
55 -- | Parse GHC's static flags as @parseStaticFlags@ does. However it also
56 -- takes a list of available static flags, such that certain flags can be
57 -- enabled or disabled through this argument.
58 parseStaticFlagsFull :: [Flag IO] -> [Located String]
59 -> IO ([Located String], [Located String])
60 parseStaticFlagsFull flagsAvailable args = do
61 ready <- readIORef v_opt_C_ready
62 when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")
63
64 (leftover, errs, warns1) <- processArgs flagsAvailable args
65 when (not (null errs)) $ ghcError $ errorsToGhcException errs
66
67 -- deal with the way flags: the way (eg. prof) gives rise to
68 -- further flags, some of which might be static.
69 way_flags <- getWayFlags
70 let way_flags' = map (mkGeneralLocated "in way flags") way_flags
71
72 -- if we're unregisterised, add some more flags
73 let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
74 | otherwise = []
75
76 -- as these are GHC generated flags, we parse them with all static flags
77 -- in scope, regardless of what availableFlags are passed in.
78 (more_leftover, errs, warns2) <-
79 processArgs flagsStatic (unreg_flags ++ way_flags')
80
81 -- see sanity code in staticOpts
82 writeIORef v_opt_C_ready True
83
84 -- TABLES_NEXT_TO_CODE affects the info table layout.
85 -- Be careful to do this *after* all processArgs,
86 -- because evaluating tablesNextToCode involves looking at the global
87 -- static flags. Those pesky global variables...
88 let cg_flags | tablesNextToCode = map (mkGeneralLocated "in cg_flags")
89 ["-optc-DTABLES_NEXT_TO_CODE"]
90 | otherwise = []
91
92 -- HACK: -fexcess-precision is both a static and a dynamic flag. If
93 -- the static flag parser has slurped it, we must return it as a
94 -- leftover too. ToDo: make -fexcess-precision dynamic only.
95 let excess_prec
96 | opt_SimplExcessPrecision = map (mkGeneralLocated "in excess_prec")
97 ["-fexcess-precision"]
98 | otherwise = []
99
100 when (not (null errs)) $ ghcError $ errorsToGhcException errs
101 return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
102 warns1 ++ warns2)
103
104 flagsStatic :: [Flag IO]
105 -- All the static flags should appear in this list. It describes how each
106 -- static flag should be processed. Two main purposes:
107 -- (a) if a command-line flag doesn't appear in the list, GHC can complain
108 -- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" things
109 --
110 -- The common (PassFlag addOpt) action puts the static flag into the bunch of
111 -- things that are searched up by the top-level definitions like
112 -- opt_foo = lookUp (fsLit "-dfoo")
113
114 -- Note that ordering is important in the following list: any flag which
115 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
116 -- flags further down the list with the same prefix.
117
118 flagsStatic = [
119 ------- ways --------------------------------------------------------
120 Flag "prof" (NoArg (addWay WayProf))
121 , Flag "eventlog" (NoArg (addWay WayEventLog))
122 , Flag "parallel" (NoArg (addWay WayPar))
123 , Flag "gransim" (NoArg (addWay WayGran))
124 , Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead"))
125 , Flag "debug" (NoArg (addWay WayDebug))
126 , Flag "ndp" (NoArg (addWay WayNDP))
127 , Flag "threaded" (NoArg (addWay WayThreaded))
128
129 , Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug))
130 -- -ticky enables ticky-ticky code generation, and also implies -debug which
131 -- is required to get the RTS ticky support.
132
133 ------ Debugging ----------------------------------------------------
134 , Flag "dppr-debug" (PassFlag addOpt)
135 , Flag "dsuppress-all" (PassFlag addOpt)
136 , Flag "dsuppress-uniques" (PassFlag addOpt)
137 , Flag "dsuppress-coercions" (PassFlag addOpt)
138 , Flag "dsuppress-module-prefixes" (PassFlag addOpt)
139 , Flag "dsuppress-type-applications" (PassFlag addOpt)
140 , Flag "dsuppress-idinfo" (PassFlag addOpt)
141 , Flag "dsuppress-var-kinds" (PassFlag addOpt)
142 , Flag "dsuppress-type-signatures" (PassFlag addOpt)
143 , Flag "dopt-fuel" (AnySuffix addOpt)
144 , Flag "dno-debug-output" (PassFlag addOpt)
145 , Flag "dstub-dead-values" (PassFlag addOpt)
146 -- rest of the debugging flags are dynamic
147
148 ----- Linker --------------------------------------------------------
149 , Flag "static" (PassFlag addOpt)
150 , Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn))
151 -- ignored for compat w/ gcc:
152 , Flag "rdynamic" (NoArg (return ()))
153
154 ----- RTS opts ------------------------------------------------------
155 , Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
156
157 , Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
158
159 ------ Compiler flags -----------------------------------------------
160
161 -- -fPIC requires extra checking: only the NCG supports it.
162 -- See also DynFlags.parseDynamicFlags.
163 , Flag "fPIC" (PassFlag setPIC)
164
165 -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
166 , Flag "fno-"
167 (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
168
169
170 -- Pass all remaining "-f<blah>" options to hsc
171 , Flag "f" (AnySuffixPred isStaticFlag addOpt)
172 ]
173
174 setPIC :: String -> StaticP ()
175 setPIC | cGhcWithNativeCodeGen == "YES" || cGhcUnregisterised == "YES"
176 = addOpt
177 | otherwise
178 = ghcError $ CmdLineError "-fPIC is not supported on this platform"
179
180 isStaticFlag :: String -> Bool
181 isStaticFlag f =
182 f `elem` [
183 "fscc-profiling",
184 "fdicts-strict",
185 "fspec-inline-join-points",
186 "fno-hi-version-check",
187 "dno-black-holing",
188 "fno-state-hack",
189 "fsimple-list-literals",
190 "fruntime-types",
191 "fno-pre-inlining",
192 "fno-opt-coercion",
193 "fexcess-precision",
194 "static",
195 "fhardwire-lib-paths",
196 "funregisterised",
197 "fcpr-off",
198 "ferror-spans",
199 "fPIC",
200 "fhpc"
201 ]
202 || any (`isPrefixOf` f) [
203 "fliberate-case-threshold",
204 "fmax-worker-args",
205 "fhistory-size",
206 "funfolding-creation-threshold",
207 "funfolding-dict-threshold",
208 "funfolding-use-threshold",
209 "funfolding-fun-discount",
210 "funfolding-keeness-factor"
211 ]
212
213 unregFlags :: [Located String]
214 unregFlags = map (mkGeneralLocated "in unregFlags")
215 [ "-optc-DNO_REGS"
216 , "-optc-DUSE_MINIINTERPRETER"
217 , "-funregisterised" ]
218
219 -----------------------------------------------------------------------------
220 -- convert sizes like "3.5M" into integers
221
222 decodeSize :: String -> Integer
223 decodeSize str
224 | c == "" = truncate n
225 | c == "K" || c == "k" = truncate (n * 1000)
226 | c == "M" || c == "m" = truncate (n * 1000 * 1000)
227 | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
228 | otherwise = ghcError (CmdLineError ("can't decode size: " ++ str))
229 where (m, c) = span pred str
230 n = readRational m
231 pred c = isDigit c || c == '.'
232
233
234 type StaticP = EwM IO
235
236 addOpt :: String -> StaticP ()
237 addOpt = liftEwM . SF.addOpt
238
239 addWay :: WayName -> StaticP ()
240 addWay = liftEwM . SF.addWay
241
242 removeOpt :: String -> StaticP ()
243 removeOpt = liftEwM . SF.removeOpt
244
245 -----------------------------------------------------------------------------
246 -- RTS Hooks
247
248 foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO ()
249 foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
250