Turn -H and -Rghc-timing into dynamic flags.
[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.IORef
52 import System.IO.Unsafe ( unsafePerformIO )
53
54
55 -----------------------------------------------------------------------------
56 -- Static flags
57
58 -- | Parses GHC's static flags from a list of command line arguments.
59 --
60 -- These flags are static in the sense that they can be set only once and they
61 -- are global, meaning that they affect every instance of GHC running;
62 -- multiple GHC threads will use the same flags.
63 --
64 -- This function must be called before any session is started, i.e., before
65 -- the first call to 'GHC.withGhc'.
66 --
67 -- Static flags are more of a hack and are static for more or less historical
68 -- reasons. In the long run, most static flags should eventually become
69 -- dynamic flags.
70 --
71 -- XXX: can we add an auto-generated list of static flags here?
72 --
73 parseStaticFlags :: [Located String] -> IO ([Located String], [Located String])
74 parseStaticFlags = parseStaticFlagsFull flagsStatic
75
76 -- | Parse GHC's static flags as @parseStaticFlags@ does. However it also
77 -- takes a list of available static flags, such that certain flags can be
78 -- enabled or disabled through this argument.
79 parseStaticFlagsFull :: [Flag IO] -> [Located String]
80 -> IO ([Located String], [Located String])
81 parseStaticFlagsFull flagsAvailable args = do
82 ready <- readIORef v_opt_C_ready
83 when ready $ throwGhcExceptionIO (ProgramError "Too late for parseStaticFlags: call it before runGhc or runGhcT")
84
85 (leftover, errs, warns) <- processArgs flagsAvailable args
86 when (not (null errs)) $ throwGhcExceptionIO $ errorsToGhcException errs
87
88 -- see sanity code in staticOpts
89 writeIORef v_opt_C_ready True
90 return (leftover, warns)
91
92 -- holds the static opts while they're being collected, before
93 -- being unsafely read by unpacked_static_opts below.
94 GLOBAL_VAR(v_opt_C, [], [String])
95 GLOBAL_VAR(v_opt_C_ready, False, Bool)
96
97
98 staticFlags :: [String]
99 staticFlags = unsafePerformIO $ do
100 ready <- readIORef v_opt_C_ready
101 if (not ready)
102 then panic "Static flags have not been initialised!\n Please call GHC.parseStaticFlags early enough."
103 else readIORef v_opt_C
104
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"
109 -- things
110 --
111 -- The common (PassFlag addOpt) action puts the static flag into the bunch of
112 -- things that are searched up by the top-level definitions like
113 -- opt_foo = lookUp (fsLit "-dfoo")
114
115 -- Note that ordering is important in the following list: any flag which
116 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
117 -- flags further down the list with the same prefix.
118
119 flagsStatic :: [Flag IO]
120 flagsStatic = [
121 ------ Debugging ----------------------------------------------------
122 Flag "dppr-debug" (PassFlag addOptEwM)
123 , Flag "dno-debug-output" (PassFlag addOptEwM)
124 -- rest of the debugging flags are dynamic
125
126 ------ Compiler flags -----------------------------------------------
127 -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
128 , Flag "fno-"
129 (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOptEwM ("-f"++s)))
130
131 -- Pass all remaining "-f<blah>" options to hsc
132 , Flag "f" (AnySuffixPred isStaticFlag addOptEwM)
133 ]
134
135
136
137 isStaticFlag :: String -> Bool
138 isStaticFlag f = f `elem` flagsStaticNames
139
140
141 flagsStaticNames :: [String]
142 flagsStaticNames = [
143 "fno-state-hack",
144 "fno-opt-coercion",
145 "fcpr-off"
146 ]
147
148
149 initStaticOpts :: IO ()
150 initStaticOpts = writeIORef v_opt_C_ready True
151
152 addOpt :: String -> IO ()
153 addOpt = consIORef v_opt_C
154
155 removeOpt :: String -> IO ()
156 removeOpt f = do
157 fs <- readIORef v_opt_C
158 writeIORef v_opt_C $! filter (/= f) fs
159
160 type StaticP = EwM IO
161
162 addOptEwM :: String -> StaticP ()
163 addOptEwM = liftEwM . addOpt
164
165 removeOptEwM :: String -> StaticP ()
166 removeOptEwM = liftEwM . removeOpt
167
168 packed_static_opts :: [FastString]
169 packed_static_opts = map mkFastString staticFlags
170
171 lookUp :: FastString -> Bool
172 lookUp sw = sw `elem` packed_static_opts
173
174 -- debugging options
175
176 opt_PprStyle_Debug :: Bool
177 opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
178
179 opt_NoDebugOutput :: Bool
180 opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")
181
182 opt_NoStateHack :: Bool
183 opt_NoStateHack = lookUp (fsLit "-fno-state-hack")
184
185 -- Switch off CPR analysis in the new demand analyser
186 opt_CprOff :: Bool
187 opt_CprOff = lookUp (fsLit "-fcpr-off")
188
189 opt_NoOptCoercion :: Bool
190 opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion")
191
192 -----------------------------------------------------------------------------
193 -- Tunneling our global variables into a new instance of the GHC library
194
195 saveStaticFlagGlobals :: IO (Bool, [String])
196 saveStaticFlagGlobals = liftM2 (,) (readIORef v_opt_C_ready) (readIORef v_opt_C)
197
198 restoreStaticFlagGlobals :: (Bool, [String]) -> IO ()
199 restoreStaticFlagGlobals (c_ready, c) = do
200 writeIORef v_opt_C_ready c_ready
201 writeIORef v_opt_C c
202
203
204 {-
205 -- (lookup_str "foo") looks for the flag -foo=X or -fooX,
206 -- and returns the string X
207 lookup_str :: String -> Maybe String
208 lookup_str sw
209 = case firstJusts (map (stripPrefix sw) staticFlags) of
210 Just ('=' : str) -> Just str
211 Just str -> Just str
212 Nothing -> Nothing
213
214 lookup_def_int :: String -> Int -> Int
215 lookup_def_int sw def = case (lookup_str sw) of
216 Nothing -> def -- Use default
217 Just xx -> try_read sw xx
218
219 lookup_def_float :: String -> Float -> Float
220 lookup_def_float sw def = case (lookup_str sw) of
221 Nothing -> def -- Use default
222 Just xx -> try_read sw xx
223
224 try_read :: Read a => String -> String -> a
225 -- (try_read sw str) tries to read s; if it fails, it
226 -- bleats about flag sw
227 try_read sw str
228 = case reads str of
229 ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses
230 [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
231 -- ToDo: hack alert. We should really parse the arguments
232 -- and announce errors in a more civilised way.
233 -}
234