Merge changes
[ghc-hetmet.git] / compiler / main / StaticFlags.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 StaticFlags (
13         parseStaticFlags,
14         staticFlags,
15
16         -- Ways
17         WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag,
18
19         -- Output style options
20         opt_PprUserLength,
21         opt_PprStyle_Debug,
22
23         -- profiling opts
24         opt_AutoSccsOnAllToplevs,
25         opt_AutoSccsOnExportedToplevs,
26         opt_AutoSccsOnIndividualCafs,
27         opt_SccProfilingOn,
28         opt_DoTickyProfiling,
29
30         -- language opts
31         opt_DictsStrict,
32         opt_IrrefutableTuples,
33         opt_Parallel,
34         opt_RuntimeTypes,
35         opt_Flatten,
36
37         -- optimisation opts
38         opt_NoMethodSharing, 
39         opt_NoStateHack,
40         opt_LiberateCaseThreshold,
41         opt_CprOff,
42         opt_RulesOff,
43         opt_SimplNoPreInlining,
44         opt_SimplExcessPrecision,
45         opt_MaxWorkerArgs,
46
47         -- Unfolding control
48         opt_UF_CreationThreshold,
49         opt_UF_UseThreshold,
50         opt_UF_FunAppDiscount,
51         opt_UF_KeenessFactor,
52         opt_UF_UpdateInPlace,
53         opt_UF_DearOp,
54
55         -- misc opts
56         opt_IgnoreDotGhci,
57         opt_ErrorSpans,
58         opt_GranMacros,
59         opt_HiVersion,
60         opt_HistorySize,
61         opt_OmitBlackHoling,
62         opt_Static,
63         opt_Unregisterised,
64         opt_EmitExternalCore,
65         opt_PIC,
66         v_Ld_inputs,
67   ) where
68
69 #include "HsVersions.h"
70
71 import CmdLineParser
72 import Config           ( cProjectVersionInt, cProjectPatchLevel,
73                           cGhcUnregisterised )
74 import FastString       ( FastString, mkFastString )
75 import Util
76 import Maybes           ( firstJust )
77 import Panic            ( GhcException(..), ghcError )
78
79 import EXCEPTION        ( throwDyn )
80 import DATA_IOREF
81 import UNSAFE_IO        ( unsafePerformIO )
82 import Monad            ( when )
83 import Char             ( isDigit )
84 import Data.List        ( sort, intersperse, nub )
85
86 -----------------------------------------------------------------------------
87 -- Static flags
88
89 parseStaticFlags :: [String] -> IO [String]
90 parseStaticFlags args = do
91   (leftover, errs) <- processArgs static_flags args
92   when (not (null errs)) $ throwDyn (UsageError (unlines errs))
93
94     -- deal with the way flags: the way (eg. prof) gives rise to
95     -- futher flags, some of which might be static.
96   way_flags <- findBuildTag
97
98     -- if we're unregisterised, add some more flags
99   let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
100                   | otherwise = []
101
102   (more_leftover, errs) <- processArgs static_flags (unreg_flags ++ way_flags)
103   when (not (null errs)) $ ghcError (UsageError (unlines errs))
104   return (more_leftover++leftover)
105
106
107 -- note that ordering is important in the following list: any flag which
108 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
109 -- flags further down the list with the same prefix.
110
111 static_flags :: [(String, OptKind IO)]
112 static_flags = [
113         ------- GHCi -------------------------------------------------------
114      ( "ignore-dot-ghci", PassFlag addOpt )
115   ,  ( "read-dot-ghci"  , NoArg (removeOpt "-ignore-dot-ghci") )
116
117         ------- ways --------------------------------------------------------
118   ,  ( "prof"           , NoArg (addWay WayProf) )
119   ,  ( "unreg"          , NoArg (addWay WayUnreg) )
120   ,  ( "ticky"          , NoArg (addWay WayTicky) )
121   ,  ( "parallel"       , NoArg (addWay WayPar) )
122   ,  ( "gransim"        , NoArg (addWay WayGran) )
123   ,  ( "smp"            , NoArg (addWay WayThreaded) ) -- backwards compat.
124   ,  ( "debug"          , NoArg (addWay WayDebug) )
125   ,  ( "ndp"            , NoArg (addWay WayNDP) )
126   ,  ( "threaded"       , NoArg (addWay WayThreaded) )
127         -- ToDo: user ways
128
129         ------ Debugging ----------------------------------------------------
130   ,  ( "dppr-noprags",     PassFlag addOpt )
131   ,  ( "dppr-debug",       PassFlag addOpt )
132   ,  ( "dppr-user-length", AnySuffix addOpt )
133       -- rest of the debugging flags are dynamic
134
135         --------- Profiling --------------------------------------------------
136   ,  ( "auto-all"       , NoArg (addOpt "-fauto-sccs-on-all-toplevs") )
137   ,  ( "auto"           , NoArg (addOpt "-fauto-sccs-on-exported-toplevs") )
138   ,  ( "caf-all"        , NoArg (addOpt "-fauto-sccs-on-individual-cafs") )
139          -- "ignore-sccs"  doesn't work  (ToDo)
140
141   ,  ( "no-auto-all"    , NoArg (removeOpt "-fauto-sccs-on-all-toplevs") )
142   ,  ( "no-auto"        , NoArg (removeOpt "-fauto-sccs-on-exported-toplevs") )
143   ,  ( "no-caf-all"     , NoArg (removeOpt "-fauto-sccs-on-individual-cafs") )
144
145         ------- Miscellaneous -----------------------------------------------
146   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
147
148         ----- Linker --------------------------------------------------------
149   ,  ( "static"         , PassFlag addOpt )
150   ,  ( "dynamic"        , NoArg (removeOpt "-static") )
151   ,  ( "rdynamic"       , NoArg (return ()) ) -- ignored for compat w/ gcc
152
153         ----- RTS opts ------------------------------------------------------
154   ,  ( "H"                 , HasArg (setHeapSize . fromIntegral . decodeSize) )
155   ,  ( "Rghc-timing"       , NoArg  (enableTimingStats) )
156
157         ------ Compiler flags -----------------------------------------------
158         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
159   ,  ( "fno-",                  PrefixPred (\s -> isStaticFlag ("f"++s))
160                                     (\s -> removeOpt ("-f"++s)) )
161
162         -- Pass all remaining "-f<blah>" options to hsc
163   ,  ( "f",                     AnySuffixPred (isStaticFlag) addOpt )
164   ]
165
166 addOpt = consIORef v_opt_C
167
168 addWay = consIORef v_Ways
169
170 removeOpt f = do
171   fs <- readIORef v_opt_C
172   writeIORef v_opt_C $! filter (/= f) fs    
173
174 lookUp           :: FastString -> Bool
175 lookup_def_int   :: String -> Int -> Int
176 lookup_def_float :: String -> Float -> Float
177 lookup_str       :: String -> Maybe String
178
179 -- holds the static opts while they're being collected, before
180 -- being unsafely read by unpacked_static_opts below.
181 GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String])
182 staticFlags = unsafePerformIO (readIORef v_opt_C)
183
184 -- -static is the default
185 defaultStaticOpts = ["-static"]
186
187 packed_static_opts   = map mkFastString staticFlags
188
189 lookUp     sw = sw `elem` packed_static_opts
190         
191 -- (lookup_str "foo") looks for the flag -foo=X or -fooX, 
192 -- and returns the string X
193 lookup_str sw 
194    = case firstJust (map (startsWith sw) staticFlags) of
195         Just ('=' : str) -> Just str
196         Just str         -> Just str
197         Nothing          -> Nothing     
198
199 lookup_def_int sw def = case (lookup_str sw) of
200                             Nothing -> def              -- Use default
201                             Just xx -> try_read sw xx
202
203 lookup_def_float sw def = case (lookup_str sw) of
204                             Nothing -> def              -- Use default
205                             Just xx -> try_read sw xx
206
207
208 try_read :: Read a => String -> String -> a
209 -- (try_read sw str) tries to read s; if it fails, it
210 -- bleats about flag sw
211 try_read sw str
212   = case reads str of
213         ((x,_):_) -> x  -- Be forgiving: ignore trailing goop, and alternative parses
214         []        -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
215                         -- ToDo: hack alert. We should really parse the arugments
216                         --       and announce errors in a more civilised way.
217
218
219 {-
220  Putting the compiler options into temporary at-files
221  may turn out to be necessary later on if we turn hsc into
222  a pure Win32 application where I think there's a command-line
223  length limit of 255. unpacked_opts understands the @ option.
224
225 unpacked_opts :: [String]
226 unpacked_opts =
227   concat $
228   map (expandAts) $
229   map unpackFS argv  -- NOT ARGV any more: v_Static_hsc_opts
230   where
231    expandAts ('@':fname) = words (unsafePerformIO (readFile fname))
232    expandAts l = [l]
233 -}
234
235
236 opt_IgnoreDotGhci               = lookUp FSLIT("-ignore-dot-ghci")
237
238 -- debugging opts
239 opt_PprStyle_Debug              = lookUp  FSLIT("-dppr-debug")
240 opt_PprUserLength               = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
241
242 -- profiling opts
243 opt_AutoSccsOnAllToplevs        = lookUp  FSLIT("-fauto-sccs-on-all-toplevs")
244 opt_AutoSccsOnExportedToplevs   = lookUp  FSLIT("-fauto-sccs-on-exported-toplevs")
245 opt_AutoSccsOnIndividualCafs    = lookUp  FSLIT("-fauto-sccs-on-individual-cafs")
246 opt_SccProfilingOn              = lookUp  FSLIT("-fscc-profiling")
247 opt_DoTickyProfiling            = lookUp  FSLIT("-fticky-ticky")
248
249 -- language opts
250 opt_DictsStrict                 = lookUp  FSLIT("-fdicts-strict")
251 opt_IrrefutableTuples           = lookUp  FSLIT("-firrefutable-tuples")
252 opt_Parallel                    = lookUp  FSLIT("-fparallel")
253 opt_Flatten                     = lookUp  FSLIT("-fflatten")
254
255 -- optimisation opts
256 opt_NoStateHack                 = lookUp  FSLIT("-fno-state-hack")
257 opt_NoMethodSharing             = lookUp  FSLIT("-fno-method-sharing")
258 opt_CprOff                      = lookUp  FSLIT("-fcpr-off")
259 opt_RulesOff                    = lookUp  FSLIT("-frules-off")
260         -- Switch off CPR analysis in the new demand analyser
261 opt_LiberateCaseThreshold       = lookup_def_int "-fliberate-case-threshold" (10::Int)
262 opt_MaxWorkerArgs               = lookup_def_int "-fmax-worker-args" (10::Int)
263
264 opt_GranMacros                  = lookUp  FSLIT("-fgransim")
265 opt_HiVersion                   = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int
266 opt_HistorySize                 = lookup_def_int "-fhistory-size" 20
267 opt_OmitBlackHoling             = lookUp  FSLIT("-dno-black-holing")
268 opt_RuntimeTypes                = lookUp  FSLIT("-fruntime-types")
269
270 -- Simplifier switches
271 opt_SimplNoPreInlining          = lookUp  FSLIT("-fno-pre-inlining")
272         -- NoPreInlining is there just to see how bad things
273         -- get if you don't do it!
274 opt_SimplExcessPrecision        = lookUp  FSLIT("-fexcess-precision")
275
276 -- Unfolding control
277 opt_UF_CreationThreshold        = lookup_def_int "-funfolding-creation-threshold"  (45::Int)
278 opt_UF_UseThreshold             = lookup_def_int "-funfolding-use-threshold"       (8::Int)     -- Discounts can be big
279 opt_UF_FunAppDiscount           = lookup_def_int "-funfolding-fun-discount"        (6::Int)     -- It's great to inline a fn
280 opt_UF_KeenessFactor            = lookup_def_float "-funfolding-keeness-factor"    (1.5::Float)
281 opt_UF_UpdateInPlace            = lookUp  FSLIT("-funfolding-update-in-place")
282
283 opt_UF_DearOp   = ( 4 :: Int)
284                         
285 opt_Static                      = lookUp  FSLIT("-static")
286 opt_Unregisterised              = lookUp  FSLIT("-funregisterised")
287 opt_EmitExternalCore            = lookUp  FSLIT("-fext-core")
288
289 -- Include full span info in error messages, instead of just the start position.
290 opt_ErrorSpans                  = lookUp FSLIT("-ferror-spans")
291
292 opt_PIC                         = lookUp FSLIT("-fPIC")
293
294 -- object files and libraries to be linked in are collected here.
295 -- ToDo: perhaps this could be done without a global, it wasn't obvious
296 -- how to do it though --SDM.
297 GLOBAL_VAR(v_Ld_inputs, [],      [String])
298
299 isStaticFlag f =
300   f `elem` [
301         "fauto-sccs-on-all-toplevs",
302         "fauto-sccs-on-exported-toplevs",
303         "fauto-sccs-on-individual-cafs",
304         "fscc-profiling",
305         "fticky-ticky",
306         "fdicts-strict",
307         "firrefutable-tuples",
308         "fparallel",
309         "fflatten",
310         "fgransim",
311         "fno-hi-version-check",
312         "dno-black-holing",
313         "fno-method-sharing",
314         "fno-state-hack",
315         "fruntime-types",
316         "fno-pre-inlining",
317         "fexcess-precision",
318         "funfolding-update-in-place",
319         "static",
320         "funregisterised",
321         "fext-core",
322         "frules-off",
323         "fcpr-off",
324         "ferror-spans",
325         "fPIC"
326         ]
327   || any (flip prefixMatch f) [
328         "fliberate-case-threshold",
329         "fmax-worker-args",
330         "fhistory-size",
331         "funfolding-creation-threshold",
332         "funfolding-use-threshold",
333         "funfolding-fun-discount",
334         "funfolding-keeness-factor"
335      ]
336
337
338
339 -- Misc functions for command-line options
340
341 startsWith :: String -> String -> Maybe String
342 -- startsWith pfx (pfx++rest) = Just rest
343
344 startsWith []     str = Just str
345 startsWith (c:cs) (s:ss)
346   = if c /= s then Nothing else startsWith cs ss
347 startsWith  _     []  = Nothing
348
349
350 -----------------------------------------------------------------------------
351 -- convert sizes like "3.5M" into integers
352
353 decodeSize :: String -> Integer
354 decodeSize str
355   | c == ""              = truncate n
356   | c == "K" || c == "k" = truncate (n * 1000)
357   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
358   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
359   | otherwise            = throwDyn (CmdLineError ("can't decode size: " ++ str))
360   where (m, c) = span pred str
361         n      = read m  :: Double
362         pred c = isDigit c || c == '.'
363
364
365 -----------------------------------------------------------------------------
366 -- RTS Hooks
367
368 #if __GLASGOW_HASKELL__ >= 504
369 foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
370 foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
371 #else
372 foreign import "setHeapSize"       unsafe setHeapSize       :: Int -> IO ()
373 foreign import "enableTimingStats" unsafe enableTimingStats :: IO ()
374 #endif
375
376 -----------------------------------------------------------------------------
377 -- Ways
378
379 -- The central concept of a "way" is that all objects in a given
380 -- program must be compiled in the same "way".  Certain options change
381 -- parameters of the virtual machine, eg. profiling adds an extra word
382 -- to the object header, so profiling objects cannot be linked with
383 -- non-profiling objects.
384
385 -- After parsing the command-line options, we determine which "way" we
386 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
387
388 -- We then find the "build-tag" associated with this way, and this
389 -- becomes the suffix used to find .hi files and libraries used in
390 -- this compilation.
391
392 GLOBAL_VAR(v_Build_tag, "", String)
393
394 -- The RTS has its own build tag, because there are some ways that
395 -- affect the RTS only.
396 GLOBAL_VAR(v_RTS_Build_tag, "", String)
397
398 data WayName
399   = WayThreaded
400   | WayDebug
401   | WayProf
402   | WayUnreg
403   | WayTicky
404   | WayPar
405   | WayGran
406   | WayNDP
407   | WayUser_a
408   | WayUser_b
409   | WayUser_c
410   | WayUser_d
411   | WayUser_e
412   | WayUser_f
413   | WayUser_g
414   | WayUser_h
415   | WayUser_i
416   | WayUser_j
417   | WayUser_k
418   | WayUser_l
419   | WayUser_m
420   | WayUser_n
421   | WayUser_o
422   | WayUser_A
423   | WayUser_B
424   deriving (Eq,Ord)
425
426 GLOBAL_VAR(v_Ways, [] ,[WayName])
427
428 allowed_combination way = and [ x `allowedWith` y 
429                               | x <- way, y <- way, x < y ]
430   where
431         -- Note ordering in these tests: the left argument is
432         -- <= the right argument, according to the Ord instance
433         -- on Way above.
434
435         -- debug is allowed with everything
436         _ `allowedWith` WayDebug                = True
437         WayDebug `allowedWith` _                = True
438
439         WayProf `allowedWith` WayUnreg          = True
440         WayProf `allowedWith` WayNDP            = True
441         _ `allowedWith` _                       = False
442
443
444 findBuildTag :: IO [String]  -- new options
445 findBuildTag = do
446   way_names <- readIORef v_Ways
447   let ws = sort (nub way_names)
448   if not (allowed_combination ws)
449       then throwDyn (CmdLineError $
450                     "combination not supported: "  ++
451                     foldr1 (\a b -> a ++ '/':b) 
452                     (map (wayName . lkupWay) ws))
453       else let ways    = map lkupWay ws
454                tag     = mkBuildTag (filter (not.wayRTSOnly) ways)
455                rts_tag = mkBuildTag ways
456                flags   = map wayOpts ways
457            in do
458            writeIORef v_Build_tag tag
459            writeIORef v_RTS_Build_tag rts_tag
460            return (concat flags)
461
462 mkBuildTag :: [Way] -> String
463 mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
464
465 lkupWay w = 
466    case lookup w way_details of
467         Nothing -> error "findBuildTag"
468         Just details -> details
469
470 data Way = Way {
471   wayTag     :: String,
472   wayRTSOnly :: Bool,
473   wayName    :: String,
474   wayOpts    :: [String]
475   }
476
477 way_details :: [ (WayName, Way) ]
478 way_details =
479   [ (WayThreaded, Way "thr" True "Threaded" [
480 #if defined(freebsd_TARGET_OS)
481 --        "-optc-pthread"
482 --      , "-optl-pthread"
483         -- FreeBSD's default threading library is the KSE-based M:N libpthread,
484         -- which GHC has some problems with.  It's currently not clear whether
485         -- the problems are our fault or theirs, but it seems that using the
486         -- alternative 1:1 threading library libthr works around it:
487           "-optl-lthr"
488 #elif defined(solaris2_TARGET_OS)
489           "-optl-lrt"
490 #endif
491         ] ),
492
493     (WayDebug, Way "debug" True "Debug" [] ),
494
495     (WayProf, Way  "p" False "Profiling"
496         [ "-fscc-profiling"
497         , "-DPROFILING"
498         , "-optc-DPROFILING" ]),
499
500     (WayTicky, Way  "t" False "Ticky-ticky Profiling"  
501         [ "-fticky-ticky"
502         , "-DTICKY_TICKY"
503         , "-optc-DTICKY_TICKY" ]),
504
505     (WayUnreg, Way  "u" False "Unregisterised" 
506         unregFlags ),
507
508     -- optl's below to tell linker where to find the PVM library -- HWL
509     (WayPar, Way  "mp" False "Parallel" 
510         [ "-fparallel"
511         , "-D__PARALLEL_HASKELL__"
512         , "-optc-DPAR"
513         , "-package concurrent"
514         , "-optc-w"
515         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
516         , "-optl-lpvm3"
517         , "-optl-lgpvm3" ]),
518
519     -- at the moment we only change the RTS and could share compiler and libs!
520     (WayPar, Way  "mt" False "Parallel ticky profiling" 
521         [ "-fparallel"
522         , "-D__PARALLEL_HASKELL__"
523         , "-optc-DPAR"
524         , "-optc-DPAR_TICKY"
525         , "-package concurrent"
526         , "-optc-w"
527         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
528         , "-optl-lpvm3"
529         , "-optl-lgpvm3" ]),
530
531     (WayPar, Way  "md" False "Distributed" 
532         [ "-fparallel"
533         , "-D__PARALLEL_HASKELL__"
534         , "-D__DISTRIBUTED_HASKELL__"
535         , "-optc-DPAR"
536         , "-optc-DDIST"
537         , "-package concurrent"
538         , "-optc-w"
539         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
540         , "-optl-lpvm3"
541         , "-optl-lgpvm3" ]),
542
543     (WayGran, Way  "mg" False "GranSim"
544         [ "-fgransim"
545         , "-D__GRANSIM__"
546         , "-optc-DGRAN"
547         , "-package concurrent" ]),
548
549     (WayNDP, Way  "ndp" False "Nested data parallelism"
550         [ "-fparr"
551         , "-fflatten"]),
552
553     (WayUser_a,  Way  "a"  False "User way 'a'"  ["$WAY_a_REAL_OPTS"]), 
554     (WayUser_b,  Way  "b"  False "User way 'b'"  ["$WAY_b_REAL_OPTS"]), 
555     (WayUser_c,  Way  "c"  False "User way 'c'"  ["$WAY_c_REAL_OPTS"]), 
556     (WayUser_d,  Way  "d"  False "User way 'd'"  ["$WAY_d_REAL_OPTS"]), 
557     (WayUser_e,  Way  "e"  False "User way 'e'"  ["$WAY_e_REAL_OPTS"]), 
558     (WayUser_f,  Way  "f"  False "User way 'f'"  ["$WAY_f_REAL_OPTS"]), 
559     (WayUser_g,  Way  "g"  False "User way 'g'"  ["$WAY_g_REAL_OPTS"]), 
560     (WayUser_h,  Way  "h"  False "User way 'h'"  ["$WAY_h_REAL_OPTS"]), 
561     (WayUser_i,  Way  "i"  False "User way 'i'"  ["$WAY_i_REAL_OPTS"]), 
562     (WayUser_j,  Way  "j"  False "User way 'j'"  ["$WAY_j_REAL_OPTS"]), 
563     (WayUser_k,  Way  "k"  False "User way 'k'"  ["$WAY_k_REAL_OPTS"]), 
564     (WayUser_l,  Way  "l"  False "User way 'l'"  ["$WAY_l_REAL_OPTS"]), 
565     (WayUser_m,  Way  "m"  False "User way 'm'"  ["$WAY_m_REAL_OPTS"]), 
566     (WayUser_n,  Way  "n"  False "User way 'n'"  ["$WAY_n_REAL_OPTS"]), 
567     (WayUser_o,  Way  "o"  False "User way 'o'"  ["$WAY_o_REAL_OPTS"]), 
568     (WayUser_A,  Way  "A"  False "User way 'A'"  ["$WAY_A_REAL_OPTS"]), 
569     (WayUser_B,  Way  "B"  False "User way 'B'"  ["$WAY_B_REAL_OPTS"]) 
570   ]
571
572 unregFlags = 
573    [ "-optc-DNO_REGS"
574    , "-optc-DUSE_MINIINTERPRETER"
575    , "-fno-asm-mangling"
576    , "-funregisterised"
577    , "-fvia-C" ]