Bake in ByteOff to ParamLocation, and remove ArgumentFormat synonym.
[ghc-hetmet.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         staticFlags,
17         initStaticOpts,
18
19         -- Ways
20         WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag,
21
22         -- Output style options
23         opt_PprUserLength,
24         opt_PprCols,
25         opt_PprCaseAsLet,
26         opt_PprStyle_Debug, opt_TraceLevel,
27         opt_NoDebugOutput, 
28
29         -- Suppressing boring aspects of core dumps
30         opt_SuppressAll,
31         opt_SuppressUniques,
32         opt_SuppressCoercions,
33         opt_SuppressModulePrefixes,
34         opt_SuppressTypeApplications,
35         opt_SuppressIdInfo,
36         opt_SuppressTypeSignatures,
37
38         -- profiling opts
39         opt_SccProfilingOn,
40
41         -- Hpc opts
42         opt_Hpc,
43
44         -- language opts
45         opt_DictsStrict,
46         opt_IrrefutableTuples,
47         opt_Parallel,
48
49         -- optimisation opts
50         opt_NoStateHack,
51         opt_SimpleListLiterals,
52         opt_CprOff,
53         opt_SimplNoPreInlining,
54         opt_SimplExcessPrecision,
55         opt_NoOptCoercion,
56         opt_MaxWorkerArgs,
57
58         -- Unfolding control
59         opt_UF_CreationThreshold,
60         opt_UF_UseThreshold,
61         opt_UF_FunAppDiscount,
62         opt_UF_DictDiscount,
63         opt_UF_KeenessFactor,
64         opt_UF_DearOp,
65
66         -- Optimization fuel controls
67         opt_Fuel,
68
69         -- Related to linking
70         opt_PIC,
71         opt_Static,
72
73         -- misc opts
74         opt_IgnoreDotGhci,
75         opt_ErrorSpans,
76         opt_GranMacros,
77         opt_HiVersion,
78         opt_HistorySize,
79         opt_OmitBlackHoling,
80         opt_Unregisterised,
81         v_Ld_inputs,
82         tablesNextToCode,
83         opt_StubDeadValues,
84         opt_Ticky,
85
86     -- For the parser
87     addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready
88   ) where
89
90 #include "HsVersions.h"
91
92 import Config
93 import FastString
94 import Util
95 import Maybes           ( firstJusts )
96 import Panic
97
98 import Data.Maybe       ( listToMaybe )
99 import Data.IORef
100 import System.IO.Unsafe ( unsafePerformIO )
101 import Data.List
102
103 -----------------------------------------------------------------------------
104 -- Static flags
105
106 initStaticOpts :: IO ()
107 initStaticOpts = writeIORef v_opt_C_ready True
108
109 addOpt :: String -> IO ()
110 addOpt = consIORef v_opt_C
111
112 addWay :: WayName -> IO ()
113 addWay = consIORef v_Ways . lkupWay
114
115 removeOpt :: String -> IO ()
116 removeOpt f = do
117   fs <- readIORef v_opt_C
118   writeIORef v_opt_C $! filter (/= f) fs    
119
120 lookUp           :: FastString -> Bool
121 lookup_def_int   :: String -> Int -> Int
122 lookup_def_float :: String -> Float -> Float
123 lookup_str       :: String -> Maybe String
124
125 -- holds the static opts while they're being collected, before
126 -- being unsafely read by unpacked_static_opts below.
127 GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String])
128 GLOBAL_VAR(v_opt_C_ready, False, Bool)
129
130 staticFlags :: [String]
131 staticFlags = unsafePerformIO $ do
132   ready <- readIORef v_opt_C_ready
133   if (not ready)
134         then panic "Static flags have not been initialised!\n        Please call GHC.newSession or GHC.parseStaticFlags early enough."
135         else readIORef v_opt_C
136
137 -- -static is the default
138 defaultStaticOpts :: [String]
139 defaultStaticOpts = ["-static"]
140
141 packed_static_opts :: [FastString]
142 packed_static_opts   = map mkFastString staticFlags
143
144 lookUp     sw = sw `elem` packed_static_opts
145         
146 -- (lookup_str "foo") looks for the flag -foo=X or -fooX, 
147 -- and returns the string X
148 lookup_str sw 
149    = case firstJusts (map (stripPrefix sw) staticFlags) of
150         Just ('=' : str) -> Just str
151         Just str         -> Just str
152         Nothing          -> Nothing     
153
154 lookup_def_int sw def = case (lookup_str sw) of
155                             Nothing -> def              -- Use default
156                             Just xx -> try_read sw xx
157
158 lookup_def_float sw def = case (lookup_str sw) of
159                             Nothing -> def              -- Use default
160                             Just xx -> try_read sw xx
161
162
163 try_read :: Read a => String -> String -> a
164 -- (try_read sw str) tries to read s; if it fails, it
165 -- bleats about flag sw
166 try_read sw str
167   = case reads str of
168         ((x,_):_) -> x  -- Be forgiving: ignore trailing goop, and alternative parses
169         []        -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
170                         -- ToDo: hack alert. We should really parse the arguments
171                         --       and announce errors in a more civilised way.
172
173
174 {-
175  Putting the compiler options into temporary at-files
176  may turn out to be necessary later on if we turn hsc into
177  a pure Win32 application where I think there's a command-line
178  length limit of 255. unpacked_opts understands the @ option.
179
180 unpacked_opts :: [String]
181 unpacked_opts =
182   concat $
183   map (expandAts) $
184   map unpackFS argv  -- NOT ARGV any more: v_Static_hsc_opts
185   where
186    expandAts ('@':fname) = words (unsafePerformIO (readFile fname))
187    expandAts l = [l]
188 -}
189
190 opt_IgnoreDotGhci :: Bool
191 opt_IgnoreDotGhci               = lookUp (fsLit "-ignore-dot-ghci")
192
193 -- debugging options
194 -- | Suppress all that is suppressable in core dumps.
195 --   Except for uniques, as some simplifier phases introduce new varibles that
196 --   have otherwise identical names.
197 opt_SuppressAll :: Bool
198 opt_SuppressAll 
199         = lookUp  (fsLit "-dsuppress-all")
200
201 -- | Suppress all coercions, them replacing with '...'
202 opt_SuppressCoercions :: Bool
203 opt_SuppressCoercions
204         =  lookUp  (fsLit "-dsuppress-all") 
205         || lookUp  (fsLit "-dsuppress-coercions")
206
207 -- | Suppress module id prefixes on variables.
208 opt_SuppressModulePrefixes :: Bool
209 opt_SuppressModulePrefixes
210         =  lookUp  (fsLit "-dsuppress-all")
211         || lookUp  (fsLit "-dsuppress-module-prefixes")
212
213 -- | Suppress type applications.
214 opt_SuppressTypeApplications :: Bool
215 opt_SuppressTypeApplications
216         =  lookUp  (fsLit "-dsuppress-all")
217         || lookUp  (fsLit "-dsuppress-type-applications")
218
219 -- | Suppress info such as arity and unfoldings on identifiers.
220 opt_SuppressIdInfo :: Bool
221 opt_SuppressIdInfo 
222         =  lookUp  (fsLit "-dsuppress-all")
223         || lookUp  (fsLit "-dsuppress-idinfo")
224
225 -- | Suppress seprate type signatures in core, but leave types on lambda bound vars
226 opt_SuppressTypeSignatures :: Bool
227 opt_SuppressTypeSignatures
228         =  lookUp  (fsLit "-dsuppress-all")
229         || lookUp  (fsLit "-dsuppress-type-signatures")
230
231 -- | Suppress unique ids on variables.
232 --   Except for uniques, as some simplifier phases introduce new variables that
233 --   have otherwise identical names.
234 opt_SuppressUniques :: Bool
235 opt_SuppressUniques
236         =  lookUp  (fsLit "-dsuppress-uniques")
237
238 -- | Display case expressions with a single alternative as strict let bindings
239 opt_PprCaseAsLet :: Bool
240 opt_PprCaseAsLet        = lookUp   (fsLit "-dppr-case-as-let")
241
242 -- | Set the maximum width of the dumps
243 --   If GHC's command line options are bad then the options parser uses the
244 --   pretty printer display the error message. In this case the staticFlags
245 --   won't be initialized yet, so we must check for this case explicitly 
246 --   and return the default value.
247 opt_PprCols :: Int
248 opt_PprCols 
249  = unsafePerformIO
250  $ do   ready <- readIORef v_opt_C_ready
251         if (not ready)
252                 then return 100
253                 else return $ lookup_def_int "-dppr-cols" 100
254
255
256 opt_PprStyle_Debug  :: Bool
257 opt_PprStyle_Debug              = lookUp  (fsLit "-dppr-debug")
258
259 opt_TraceLevel :: Int
260 opt_TraceLevel = lookup_def_int "-dtrace-level" 1       -- Standard level is 1
261                                                         -- Less verbose is 0
262
263 opt_PprUserLength   :: Int
264 opt_PprUserLength               = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
265
266 opt_Fuel            :: Int
267 opt_Fuel                        = lookup_def_int "-dopt-fuel" maxBound
268
269 opt_NoDebugOutput   :: Bool
270 opt_NoDebugOutput               = lookUp  (fsLit "-dno-debug-output")
271
272 -- profiling opts
273 opt_SccProfilingOn :: Bool
274 opt_SccProfilingOn              = lookUp  (fsLit "-fscc-profiling")
275
276 -- Hpc opts
277 opt_Hpc :: Bool
278 opt_Hpc                         = lookUp (fsLit "-fhpc")  
279
280 -- language opts
281 opt_DictsStrict :: Bool
282 opt_DictsStrict                 = lookUp  (fsLit "-fdicts-strict")
283
284 opt_IrrefutableTuples :: Bool
285 opt_IrrefutableTuples           = lookUp  (fsLit "-firrefutable-tuples")
286
287 opt_Parallel :: Bool
288 opt_Parallel                    = lookUp  (fsLit "-fparallel")
289
290 opt_SimpleListLiterals :: Bool
291 opt_SimpleListLiterals          = lookUp  (fsLit "-fsimple-list-literals")
292
293 opt_NoStateHack :: Bool
294 opt_NoStateHack                 = lookUp  (fsLit "-fno-state-hack")
295
296 opt_CprOff :: Bool
297 opt_CprOff                      = lookUp  (fsLit "-fcpr-off")
298         -- Switch off CPR analysis in the new demand analyser
299 opt_MaxWorkerArgs :: Int
300 opt_MaxWorkerArgs               = lookup_def_int "-fmax-worker-args" (10::Int)
301
302 opt_GranMacros :: Bool
303 opt_GranMacros                  = lookUp  (fsLit "-fgransim")
304
305 opt_HiVersion :: Integer
306 opt_HiVersion                   = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
307
308 opt_HistorySize :: Int
309 opt_HistorySize                 = lookup_def_int "-fhistory-size" 20
310
311 opt_OmitBlackHoling :: Bool
312 opt_OmitBlackHoling             = lookUp  (fsLit "-dno-black-holing")
313
314 opt_StubDeadValues  :: Bool
315 opt_StubDeadValues              = lookUp  (fsLit "-dstub-dead-values")
316
317 -- Simplifier switches
318 opt_SimplNoPreInlining :: Bool
319 opt_SimplNoPreInlining          = lookUp  (fsLit "-fno-pre-inlining")
320         -- NoPreInlining is there just to see how bad things
321         -- get if you don't do it!
322 opt_SimplExcessPrecision :: Bool
323 opt_SimplExcessPrecision        = lookUp  (fsLit "-fexcess-precision")
324
325 opt_NoOptCoercion :: Bool
326 opt_NoOptCoercion               = lookUp  (fsLit "-fno-opt-coercion")
327
328 -- Unfolding control
329 -- See Note [Discounts and thresholds] in CoreUnfold
330
331 opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int
332 opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int
333 opt_UF_KeenessFactor :: Float
334
335 opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int)
336 opt_UF_UseThreshold      = lookup_def_int "-funfolding-use-threshold"      (60::Int)
337 opt_UF_FunAppDiscount    = lookup_def_int "-funfolding-fun-discount"       (60::Int)
338
339 opt_UF_DictDiscount      = lookup_def_int "-funfolding-dict-discount"      (30::Int)
340    -- Be fairly keen to inline a fuction if that means
341    -- we'll be able to pick the right method from a dictionary
342
343 opt_UF_KeenessFactor     = lookup_def_float "-funfolding-keeness-factor"   (1.5::Float)
344 opt_UF_DearOp            = ( 40 :: Int)
345
346
347 -- Related to linking
348 opt_PIC :: Bool
349 #if darwin_TARGET_OS && x86_64_TARGET_ARCH
350 opt_PIC                         = True
351 #elif darwin_TARGET_OS
352 opt_PIC                         = lookUp (fsLit "-fPIC") || not opt_Static
353 #else
354 opt_PIC                         = lookUp (fsLit "-fPIC")
355 #endif
356 opt_Static :: Bool
357 opt_Static                      = lookUp  (fsLit "-static")
358 opt_Unregisterised :: Bool
359 opt_Unregisterised              = lookUp  (fsLit "-funregisterised")
360
361 -- Derived, not a real option.  Determines whether we will be compiling
362 -- info tables that reside just before the entry code, or with an
363 -- indirection to the entry code.  See TABLES_NEXT_TO_CODE in 
364 -- includes/rts/storage/InfoTables.h.
365 tablesNextToCode :: Bool
366 tablesNextToCode                = not opt_Unregisterised
367                                   && cGhcEnableTablesNextToCode == "YES"
368
369 -- Include full span info in error messages, instead of just the start position.
370 opt_ErrorSpans :: Bool
371 opt_ErrorSpans                  = lookUp (fsLit "-ferror-spans")
372
373 opt_Ticky :: Bool
374 opt_Ticky                       = lookUp (fsLit "-ticky")
375
376 -- object files and libraries to be linked in are collected here.
377 -- ToDo: perhaps this could be done without a global, it wasn't obvious
378 -- how to do it though --SDM.
379 GLOBAL_VAR(v_Ld_inputs, [],      [String])
380
381 -----------------------------------------------------------------------------
382 -- Ways
383
384 -- The central concept of a "way" is that all objects in a given
385 -- program must be compiled in the same "way".  Certain options change
386 -- parameters of the virtual machine, eg. profiling adds an extra word
387 -- to the object header, so profiling objects cannot be linked with
388 -- non-profiling objects.
389
390 -- After parsing the command-line options, we determine which "way" we
391 -- are building - this might be a combination way, eg. profiling+threaded.
392
393 -- We then find the "build-tag" associated with this way, and this
394 -- becomes the suffix used to find .hi files and libraries used in
395 -- this compilation.
396
397 data WayName
398   = WayThreaded
399   | WayDebug
400   | WayProf
401   | WayEventLog
402   | WayPar
403   | WayGran
404   | WayNDP
405   | WayDyn
406   deriving (Eq,Ord)
407
408 GLOBAL_VAR(v_Ways, [] ,[Way])
409
410 allowed_combination :: [WayName] -> Bool
411 allowed_combination way = and [ x `allowedWith` y 
412                               | x <- way, y <- way, x < y ]
413   where
414         -- Note ordering in these tests: the left argument is
415         -- <= the right argument, according to the Ord instance
416         -- on Way above.
417
418         -- dyn is allowed with everything
419         _ `allowedWith` WayDyn                  = True
420         WayDyn `allowedWith` _                  = True
421
422         -- debug is allowed with everything
423         _ `allowedWith` WayDebug                = True
424         WayDebug `allowedWith` _                = True
425
426         WayProf `allowedWith` WayNDP            = True
427         WayThreaded `allowedWith` WayProf       = True
428         WayThreaded `allowedWith` WayEventLog   = True
429         _ `allowedWith` _                       = False
430
431
432 getWayFlags :: IO [String]  -- new options
433 getWayFlags = do
434   unsorted <- readIORef v_Ways
435   let ways = sortBy (compare `on` wayName) $
436              nubBy  ((==) `on` wayName) $ unsorted
437   writeIORef v_Ways ways
438
439   if not (allowed_combination (map wayName ways))
440       then ghcError (CmdLineError $
441                     "combination not supported: "  ++
442                     foldr1 (\a b -> a ++ '/':b) 
443                     (map wayDesc ways))
444       else
445            return (concatMap wayOpts ways)
446
447 mkBuildTag :: [Way] -> String
448 mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
449
450 lkupWay :: WayName -> Way
451 lkupWay w = 
452    case listToMaybe (filter ((==) w . wayName) way_details) of
453         Nothing -> error "findBuildTag"
454         Just details -> details
455
456 isRTSWay :: WayName -> Bool
457 isRTSWay = wayRTSOnly . lkupWay 
458
459 data Way = Way {
460   wayName    :: WayName,
461   wayTag     :: String,
462   wayRTSOnly :: Bool,
463   wayDesc    :: String,
464   wayOpts    :: [String]
465   }
466
467 way_details :: [ Way ]
468 way_details =
469   [ Way WayThreaded "thr" True "Threaded" [
470 #if defined(freebsd_TARGET_OS)
471 --        "-optc-pthread"
472 --      , "-optl-pthread"
473         -- FreeBSD's default threading library is the KSE-based M:N libpthread,
474         -- which GHC has some problems with.  It's currently not clear whether
475         -- the problems are our fault or theirs, but it seems that using the
476         -- alternative 1:1 threading library libthr works around it:
477           "-optl-lthr"
478 #elif defined(openbsd_TARGET_OS)
479           "-optc-pthread"
480         , "-optl-pthread"
481 #elif defined(solaris2_TARGET_OS)
482           "-optl-lrt"
483 #endif
484         ],
485
486     Way WayDebug "debug" True "Debug" [],
487
488     Way WayDyn "dyn" False "Dynamic"
489         [ "-DDYNAMIC"
490         , "-optc-DDYNAMIC" 
491 #if defined(mingw32_TARGET_OS)
492         -- On Windows, code that is to be linked into a dynamic library must be compiled
493         --      with -fPIC. Labels not in the current package are assumed to be in a DLL 
494         --      different from the current one.
495         , "-fPIC"
496 #elif defined(openbsd_TARGET_OS)
497         -- Without this, linking the shared libHSffi fails because
498         -- it uses pthread mutexes.
499         , "-optl-pthread"
500 #endif
501         ],
502
503     Way WayProf "p" False "Profiling"
504         [ "-fscc-profiling"
505         , "-DPROFILING"
506         , "-optc-DPROFILING" ],
507
508     Way WayEventLog "l" True "RTS Event Logging"
509         [ "-DTRACING"
510         , "-optc-DTRACING" ],
511
512     Way WayPar "mp" False "Parallel" 
513         [ "-fparallel"
514         , "-D__PARALLEL_HASKELL__"
515         , "-optc-DPAR"
516         , "-package concurrent"
517         , "-optc-w"
518         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
519         , "-optl-lpvm3"
520         , "-optl-lgpvm3" ],
521
522     -- at the moment we only change the RTS and could share compiler and libs!
523     Way WayPar "mt" False "Parallel ticky profiling" 
524         [ "-fparallel"
525         , "-D__PARALLEL_HASKELL__"
526         , "-optc-DPAR"
527         , "-optc-DPAR_TICKY"
528         , "-package concurrent"
529         , "-optc-w"
530         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
531         , "-optl-lpvm3"
532         , "-optl-lgpvm3" ],
533
534     Way WayPar "md" False "Distributed" 
535         [ "-fparallel"
536         , "-D__PARALLEL_HASKELL__"
537         , "-D__DISTRIBUTED_HASKELL__"
538         , "-optc-DPAR"
539         , "-optc-DDIST"
540         , "-package concurrent"
541         , "-optc-w"
542         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
543         , "-optl-lpvm3"
544         , "-optl-lgpvm3" ],
545
546     Way WayGran "mg" False "GranSim"
547         [ "-fgransim"
548         , "-D__GRANSIM__"
549         , "-optc-DGRAN"
550         , "-package concurrent" ],
551
552     Way WayNDP "ndp" False "Nested data parallelism"
553         [ "-XParr"
554         , "-fvectorise"]
555   ]