Delete old comments referring to newSession
[ghc.git] / compiler / main / StaticFlags.hs
1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
3
4 -----------------------------------------------------------------------------
5 --
6 -- Static flags
7 --
8 -- Static flags can only be set once, on the command-line. Inside GHC,
9 -- each static flag corresponds to a top-level value, usually of type Bool.
10 --
11 -- (c) The University of Glasgow 2005
12 --
13 -----------------------------------------------------------------------------
14
15 module StaticFlags (
16 -- entry point
17 parseStaticFlags,
18
19 staticFlags,
20 initStaticOpts,
21
22 -- Output style options
23 opt_PprStyle_Debug,
24 opt_NoDebugOutput,
25
26 -- optimisation opts
27 opt_NoStateHack,
28 opt_CprOff,
29 opt_NoOptCoercion,
30
31 -- For the parser
32 addOpt, removeOpt, v_opt_C_ready,
33
34 -- Saving/restoring globals
35 saveStaticFlagGlobals, restoreStaticFlagGlobals,
36
37 -- For options autocompletion
38 flagsStatic, flagsStaticNames
39 ) where
40
41 #include "HsVersions.h"
42
43 import CmdLineParser
44 import FastString
45 import SrcLoc
46 import Util
47 -- import Maybes ( firstJusts )
48 import Panic
49
50 import Control.Monad
51 import Data.Char
52 import Data.IORef
53 import System.IO.Unsafe ( unsafePerformIO )
54
55
56 -----------------------------------------------------------------------------
57 -- Static flags
58
59 -- | Parses GHC's static flags from a list of command line arguments.
60 --
61 -- These flags are static in the sense that they can be set only once and they
62 -- are global, meaning that they affect every instance of GHC running;
63 -- multiple GHC threads will use the same flags.
64 --
65 -- This function must be called before any session is started, i.e., before
66 -- the first call to 'GHC.withGhc'.
67 --
68 -- Static flags are more of a hack and are static for more or less historical
69 -- reasons. In the long run, most static flags should eventually become
70 -- dynamic flags.
71 --
72 -- XXX: can we add an auto-generated list of static flags here?
73 --
74 parseStaticFlags :: [Located String] -> IO ([Located String], [Located String])
75 parseStaticFlags = parseStaticFlagsFull flagsStatic
76
77 -- | Parse GHC's static flags as @parseStaticFlags@ does. However it also
78 -- takes a list of available static flags, such that certain flags can be
79 -- enabled or disabled through this argument.
80 parseStaticFlagsFull :: [Flag IO] -> [Located String]
81 -> IO ([Located String], [Located String])
82 parseStaticFlagsFull flagsAvailable args = do
83 ready <- readIORef v_opt_C_ready
84 when ready $ throwGhcExceptionIO (ProgramError "Too late for parseStaticFlags: call it before runGhc or runGhcT")
85
86 (leftover, errs, warns) <- processArgs flagsAvailable args
87 when (not (null errs)) $ throwGhcExceptionIO $ errorsToGhcException errs
88
89 -- see sanity code in staticOpts
90 writeIORef v_opt_C_ready True
91 return (leftover, warns)
92
93 -- holds the static opts while they're being collected, before
94 -- being unsafely read by unpacked_static_opts below.
95 GLOBAL_VAR(v_opt_C, [], [String])
96 GLOBAL_VAR(v_opt_C_ready, False, Bool)
97
98
99 staticFlags :: [String]
100 staticFlags = unsafePerformIO $ do
101 ready <- readIORef v_opt_C_ready
102 if (not ready)
103 then panic "Static flags have not been initialised!\n Please call GHC.parseStaticFlags early enough."
104 else readIORef v_opt_C
105
106 -- All the static flags should appear in this list. It describes how each
107 -- static flag should be processed. Two main purposes:
108 -- (a) if a command-line flag doesn't appear in the list, GHC can complain
109 -- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X"
110 -- things
111 --
112 -- The common (PassFlag addOpt) action puts the static flag into the bunch of
113 -- things that are searched up by the top-level definitions like
114 -- opt_foo = lookUp (fsLit "-dfoo")
115
116 -- Note that ordering is important in the following list: any flag which
117 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
118 -- flags further down the list with the same prefix.
119
120 flagsStatic :: [Flag IO]
121 flagsStatic = [
122 ------ Debugging ----------------------------------------------------
123 Flag "dppr-debug" (PassFlag addOptEwM)
124 , Flag "dno-debug-output" (PassFlag addOptEwM)
125 -- rest of the debugging flags are dynamic
126
127 ----- RTS opts ------------------------------------------------------
128 , Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
129
130 , Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
131
132 ------ Compiler flags -----------------------------------------------
133 -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
134 , Flag "fno-"
135 (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOptEwM ("-f"++s)))
136
137 -- Pass all remaining "-f<blah>" options to hsc
138 , Flag "f" (AnySuffixPred isStaticFlag addOptEwM)
139 ]
140
141
142
143 isStaticFlag :: String -> Bool
144 isStaticFlag f = f `elem` flagsStaticNames
145
146
147 flagsStaticNames :: [String]
148 flagsStaticNames = [
149 "fno-state-hack",
150 "fno-opt-coercion",
151 "fcpr-off"
152 ]
153
154
155 initStaticOpts :: IO ()
156 initStaticOpts = writeIORef v_opt_C_ready True
157
158 addOpt :: String -> IO ()
159 addOpt = consIORef v_opt_C
160
161 removeOpt :: String -> IO ()
162 removeOpt f = do
163 fs <- readIORef v_opt_C
164 writeIORef v_opt_C $! filter (/= f) fs
165
166 type StaticP = EwM IO
167
168 addOptEwM :: String -> StaticP ()
169 addOptEwM = liftEwM . addOpt
170
171 removeOptEwM :: String -> StaticP ()
172 removeOptEwM = liftEwM . removeOpt
173
174 packed_static_opts :: [FastString]
175 packed_static_opts = map mkFastString staticFlags
176
177 lookUp :: FastString -> Bool
178 lookUp sw = sw `elem` packed_static_opts
179
180 -- debugging options
181
182 opt_PprStyle_Debug :: Bool
183 opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
184
185 opt_NoDebugOutput :: Bool
186 opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")
187
188 opt_NoStateHack :: Bool
189 opt_NoStateHack = lookUp (fsLit "-fno-state-hack")
190
191 -- Switch off CPR analysis in the new demand analyser
192 opt_CprOff :: Bool
193 opt_CprOff = lookUp (fsLit "-fcpr-off")
194
195 opt_NoOptCoercion :: Bool
196 opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion")
197
198
199 -----------------------------------------------------------------------------
200 -- Convert sizes like "3.5M" into integers
201
202 decodeSize :: String -> Integer
203 decodeSize str
204 | c == "" = truncate n
205 | c == "K" || c == "k" = truncate (n * 1000)
206 | c == "M" || c == "m" = truncate (n * 1000 * 1000)
207 | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
208 | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str))
209 where (m, c) = span pred str
210 n = readRational m
211 pred c = isDigit c || c == '.'
212
213
214 -----------------------------------------------------------------------------
215 -- Tunneling our global variables into a new instance of the GHC library
216
217 saveStaticFlagGlobals :: IO (Bool, [String])
218 saveStaticFlagGlobals = liftM2 (,) (readIORef v_opt_C_ready) (readIORef v_opt_C)
219
220 restoreStaticFlagGlobals :: (Bool, [String]) -> IO ()
221 restoreStaticFlagGlobals (c_ready, c) = do
222 writeIORef v_opt_C_ready c_ready
223 writeIORef v_opt_C c
224
225
226 -----------------------------------------------------------------------------
227 -- RTS Hooks
228
229 foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO ()
230 foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
231
232
233 {-
234 -- (lookup_str "foo") looks for the flag -foo=X or -fooX,
235 -- and returns the string X
236 lookup_str :: String -> Maybe String
237 lookup_str sw
238 = case firstJusts (map (stripPrefix sw) staticFlags) of
239 Just ('=' : str) -> Just str
240 Just str -> Just str
241 Nothing -> Nothing
242
243 lookup_def_int :: String -> Int -> Int
244 lookup_def_int sw def = case (lookup_str sw) of
245 Nothing -> def -- Use default
246 Just xx -> try_read sw xx
247
248 lookup_def_float :: String -> Float -> Float
249 lookup_def_float sw def = case (lookup_str sw) of
250 Nothing -> def -- Use default
251 Just xx -> try_read sw xx
252
253 try_read :: Read a => String -> String -> a
254 -- (try_read sw str) tries to read s; if it fails, it
255 -- bleats about flag sw
256 try_read sw str
257 = case reads str of
258 ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses
259 [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
260 -- ToDo: hack alert. We should really parse the arguments
261 -- and announce errors in a more civilised way.
262 -}
263