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