StaticFlags.hs 21.6 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
-----------------------------------------------------------------------------
--
-- Static flags
--
-- Static flags can only be set once, on the command-line.  Inside GHC,
-- each static flag corresponds to a top-level value, usually of type Bool.
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------

module StaticFlags (
	parseStaticFlags,
	staticFlags,
15
        initStaticOpts,
16
17

	-- Ways
18
	WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag, isRTSWay,
19
20
21

	-- Output style options
	opt_PprUserLength,
22
	opt_SuppressUniques,
23
	opt_PprStyle_Debug,
Simon Marlow's avatar
Simon Marlow committed
24
        opt_NoDebugOutput,
25
26
27
28
29
30
31
32

	-- profiling opts
	opt_AutoSccsOnAllToplevs,
	opt_AutoSccsOnExportedToplevs,
	opt_AutoSccsOnIndividualCafs,
	opt_SccProfilingOn,
	opt_DoTickyProfiling,

andy@galois.com's avatar
andy@galois.com committed
33
34
35
        -- Hpc opts
	opt_Hpc,

36
37
38
39
40
41
	-- language opts
	opt_DictsStrict,
	opt_IrrefutableTuples,
	opt_Parallel,

	-- optimisation opts
42
	opt_DsMultiTyVar,
43
	opt_NoStateHack,
44
	opt_SpecInlineJoinPoints,
45
46
47
48
49
50
51
52
53
54
55
56
	opt_CprOff,
	opt_SimplNoPreInlining,
	opt_SimplExcessPrecision,
	opt_MaxWorkerArgs,

	-- Unfolding control
	opt_UF_CreationThreshold,
	opt_UF_UseThreshold,
	opt_UF_FunAppDiscount,
	opt_UF_KeenessFactor,
	opt_UF_DearOp,

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
57
58
59
	-- Optimization fuel controls
	opt_Fuel,

60
61
62
63
	-- Related to linking
	opt_PIC,
	opt_Static,

64
65
66
67
68
69
70
71
72
73
	-- misc opts
	opt_IgnoreDotGhci,
	opt_ErrorSpans,
	opt_GranMacros,
	opt_HiVersion,
	opt_HistorySize,
	opt_OmitBlackHoling,
	opt_Unregisterised,
	opt_EmitExternalCore,
	v_Ld_inputs,
74
	tablesNextToCode
75
76
77
78
79
  ) where

#include "HsVersions.h"

import CmdLineParser
80
import Config
81
import FastString
82
83
import Util
import Maybes		( firstJust )
84
import Panic
85

Simon Marlow's avatar
Simon Marlow committed
86
87
88
89
90
import Control.Exception ( throwDyn )
import Data.IORef
import System.IO.Unsafe	( unsafePerformIO )
import Control.Monad	( when )
import Data.Char	( isDigit )
91
import Data.List
92
93
94
95

-----------------------------------------------------------------------------
-- Static flags

96
parseStaticFlags :: [String] -> IO ([String], [String])
97
parseStaticFlags args = do
98
99
100
  ready <- readIORef v_opt_C_ready
  when ready $ throwDyn (ProgramError "Too late for parseStaticFlags: call it before newSession")

101
  (leftover, errs, warns1) <- processArgs static_flags args
102
103
104
  when (not (null errs)) $ throwDyn (UsageError (unlines errs))

    -- deal with the way flags: the way (eg. prof) gives rise to
105
    -- further flags, some of which might be static.
106
107
108
109
110
111
  way_flags <- findBuildTag

    -- if we're unregisterised, add some more flags
  let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
		  | otherwise = []

112
  (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags)
Simon Marlow's avatar
Simon Marlow committed
113

114
115
116
    -- see sanity code in staticOpts
  writeIORef v_opt_C_ready True

117
    -- TABLES_NEXT_TO_CODE affects the info table layout.
Simon Marlow's avatar
Simon Marlow committed
118
119
120
    -- Be careful to do this *after* all processArgs,
    -- because evaluating tablesNextToCode involves looking at the global
    -- static flags.  Those pesky global variables...
121
122
123
  let cg_flags | tablesNextToCode = ["-optc-DTABLES_NEXT_TO_CODE"]
	       | otherwise	  = []

Simon Marlow's avatar
Simon Marlow committed
124
125
126
127
128
129
    -- HACK: -fexcess-precision is both a static and a dynamic flag.  If
    -- the static flag parser has slurped it, we must return it as a 
    -- leftover too.  ToDo: make -fexcess-precision dynamic only.
  let excess_prec | opt_SimplExcessPrecision = ["-fexcess-precision"]
                  | otherwise                = []

130
  when (not (null errs)) $ ghcError (UsageError (unlines errs))
131
132
  return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
          warns1 ++ warns2)
133

134
135
initStaticOpts :: IO ()
initStaticOpts = writeIORef v_opt_C_ready True
136

137
static_flags :: [Flag IO]
138
139
140
141
142
143
144
-- All the static flags should appear in this list.  It describes how each
-- static flag should be processed.  Two main purposes:
-- (a) if a command-line flag doesn't appear in the list, GHC can complain
-- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" things
--
-- The common (PassFlag addOpt) action puts the static flag into the bunch of
-- things that are searched up by the top-level definitions like
145
--	opt_foo = lookUp (fsLit "-dfoo")
146
147

-- Note that ordering is important in the following list: any flag which
148
149
150
151
-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
-- flags further down the list with the same prefix.

static_flags = [
152
        ------- GHCi -------------------------------------------------------
153
154
    Flag "ignore-dot-ghci" (PassFlag addOpt) Supported
  , Flag "read-dot-ghci"   (NoArg (removeOpt "-ignore-dot-ghci")) Supported
155
156

        ------- ways --------------------------------------------------------
157
158
159
160
161
162
163
164
165
  , Flag "prof"           (NoArg (addWay WayProf)) Supported
  , Flag "ticky"          (NoArg (addWay WayTicky)) Supported
  , Flag "parallel"       (NoArg (addWay WayPar)) Supported
  , Flag "gransim"        (NoArg (addWay WayGran)) Supported
  , Flag "smp"            (NoArg (addWay WayThreaded))
         (Deprecated "Use -threaded instead")
  , Flag "debug"          (NoArg (addWay WayDebug)) Supported
  , Flag "ndp"            (NoArg (addWay WayNDP)) Supported
  , Flag "threaded"       (NoArg (addWay WayThreaded)) Supported
166
167
168
        -- ToDo: user ways

        ------ Debugging ----------------------------------------------------
169
170
171
172
173
  , Flag "dppr-debug"        (PassFlag addOpt) Supported
  , Flag "dsuppress-uniques" (PassFlag addOpt) Supported
  , Flag "dppr-user-length"  (AnySuffix addOpt) Supported
  , Flag "dopt-fuel"         (AnySuffix addOpt) Supported
  , Flag "dno-debug-output"  (PassFlag addOpt) Supported
174
175
      -- rest of the debugging flags are dynamic

176
177
        --------- Profiling --------------------------------------------------
  , Flag "auto-all"       (NoArg (addOpt "-fauto-sccs-on-all-toplevs"))
178
         Supported
179
  , Flag "auto"           (NoArg (addOpt "-fauto-sccs-on-exported-toplevs"))
180
         Supported
181
  , Flag "caf-all"        (NoArg (addOpt "-fauto-sccs-on-individual-cafs"))
182
         Supported
183
184
         -- "ignore-sccs"  doesn't work  (ToDo)

185
  , Flag "no-auto-all"    (NoArg (removeOpt "-fauto-sccs-on-all-toplevs"))
186
         Supported
187
  , Flag "no-auto"        (NoArg (removeOpt "-fauto-sccs-on-exported-toplevs"))
188
         Supported
189
  , Flag "no-caf-all"     (NoArg (removeOpt "-fauto-sccs-on-individual-cafs"))
190
         Supported
191

192
        ----- Linker --------------------------------------------------------
193
194
195
196
  , Flag "static"         (PassFlag addOpt) Supported
  , Flag "dynamic"        (NoArg (removeOpt "-static")) Supported
    -- ignored for compat w/ gcc:
  , Flag "rdynamic"       (NoArg (return ())) Supported
197

198
199
        ----- RTS opts ------------------------------------------------------
  , Flag "H"              (HasArg (setHeapSize . fromIntegral . decodeSize))
200
201
         Supported
  , Flag "Rghc-timing"    (NoArg  (enableTimingStats)) Supported
202
203

        ------ Compiler flags -----------------------------------------------
204
205
206
        -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
  , Flag "fno-"
         (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
207
         Supported
208

209
210
        -- Pass all remaining "-f<blah>" options to hsc
  , Flag "f"                      (AnySuffixPred (isStaticFlag) addOpt)
211
         Supported
212
213
  ]

Ian Lynagh's avatar
Ian Lynagh committed
214
addOpt :: String -> IO ()
215
216
addOpt = consIORef v_opt_C

Ian Lynagh's avatar
Ian Lynagh committed
217
addWay :: WayName -> IO ()
218
219
addWay = consIORef v_Ways

Ian Lynagh's avatar
Ian Lynagh committed
220
removeOpt :: String -> IO ()
221
222
223
224
225
226
227
228
229
230
231
232
removeOpt f = do
  fs <- readIORef v_opt_C
  writeIORef v_opt_C $! filter (/= f) fs    

lookUp	       	 :: FastString -> Bool
lookup_def_int   :: String -> Int -> Int
lookup_def_float :: String -> Float -> Float
lookup_str       :: String -> Maybe String

-- holds the static opts while they're being collected, before
-- being unsafely read by unpacked_static_opts below.
GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String])
233
GLOBAL_VAR(v_opt_C_ready, False, Bool)
Ian Lynagh's avatar
Ian Lynagh committed
234
235

staticFlags :: [String]
236
237
238
staticFlags = unsafePerformIO $ do
  ready <- readIORef v_opt_C_ready
  if (not ready)
239
        then panic "Static flags have not been initialised!\n        Please call GHC.newSession or GHC.parseStaticFlags early enough."
240
        else readIORef v_opt_C
241
242

-- -static is the default
Ian Lynagh's avatar
Ian Lynagh committed
243
defaultStaticOpts :: [String]
244
245
defaultStaticOpts = ["-static"]

Ian Lynagh's avatar
Ian Lynagh committed
246
packed_static_opts :: [FastString]
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
packed_static_opts   = map mkFastString staticFlags

lookUp     sw = sw `elem` packed_static_opts
	
-- (lookup_str "foo") looks for the flag -foo=X or -fooX, 
-- and returns the string X
lookup_str sw 
   = case firstJust (map (startsWith sw) staticFlags) of
	Just ('=' : str) -> Just str
	Just str         -> Just str
	Nothing		 -> Nothing	

lookup_def_int sw def = case (lookup_str sw) of
			    Nothing -> def		-- Use default
		  	    Just xx -> try_read sw xx

lookup_def_float sw def = case (lookup_str sw) of
			    Nothing -> def		-- Use default
		  	    Just xx -> try_read sw xx


try_read :: Read a => String -> String -> a
-- (try_read sw str) tries to read s; if it fails, it
-- bleats about flag sw
try_read sw str
  = case reads str of
	((x,_):_) -> x	-- Be forgiving: ignore trailing goop, and alternative parses
	[]	  -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw))
			-- ToDo: hack alert. We should really parse the arugments
			-- 	 and announce errors in a more civilised way.


{-
 Putting the compiler options into temporary at-files
 may turn out to be necessary later on if we turn hsc into
 a pure Win32 application where I think there's a command-line
 length limit of 255. unpacked_opts understands the @ option.

unpacked_opts :: [String]
unpacked_opts =
  concat $
  map (expandAts) $
  map unpackFS argv  -- NOT ARGV any more: v_Static_hsc_opts
  where
   expandAts ('@':fname) = words (unsafePerformIO (readFile fname))
   expandAts l = [l]
-}

Ian Lynagh's avatar
Ian Lynagh committed
295
opt_IgnoreDotGhci :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
296
opt_IgnoreDotGhci		= lookUp (fsLit "-ignore-dot-ghci")
297
298

-- debugging opts
Ian Lynagh's avatar
Ian Lynagh committed
299
opt_SuppressUniques :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
300
opt_SuppressUniques		= lookUp  (fsLit "-dsuppress-uniques")
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
301
opt_PprStyle_Debug  :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
302
opt_PprStyle_Debug		= lookUp  (fsLit "-dppr-debug")
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
303
opt_PprUserLength   :: Int
304
opt_PprUserLength	        = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
305
306
opt_Fuel            :: Int
opt_Fuel                        = lookup_def_int "-dopt-fuel" maxBound
Simon Marlow's avatar
Simon Marlow committed
307
308
309
opt_NoDebugOutput   :: Bool
opt_NoDebugOutput               = lookUp  (fsLit "-dno-debug-output")

310
311

-- profiling opts
Ian Lynagh's avatar
Ian Lynagh committed
312
opt_AutoSccsOnAllToplevs :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
313
opt_AutoSccsOnAllToplevs	= lookUp  (fsLit "-fauto-sccs-on-all-toplevs")
Ian Lynagh's avatar
Ian Lynagh committed
314
opt_AutoSccsOnExportedToplevs :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
315
opt_AutoSccsOnExportedToplevs	= lookUp  (fsLit "-fauto-sccs-on-exported-toplevs")
Ian Lynagh's avatar
Ian Lynagh committed
316
opt_AutoSccsOnIndividualCafs :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
317
opt_AutoSccsOnIndividualCafs	= lookUp  (fsLit "-fauto-sccs-on-individual-cafs")
Ian Lynagh's avatar
Ian Lynagh committed
318
opt_SccProfilingOn :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
319
opt_SccProfilingOn		= lookUp  (fsLit "-fscc-profiling")
Ian Lynagh's avatar
Ian Lynagh committed
320
opt_DoTickyProfiling :: Bool
321
opt_DoTickyProfiling            = WayTicky `elem` (unsafePerformIO $ readIORef v_Ways)
andy@galois.com's avatar
andy@galois.com committed
322

323
-- Hpc opts
Ian Lynagh's avatar
Ian Lynagh committed
324
opt_Hpc :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
325
opt_Hpc				= lookUp (fsLit "-fhpc")  
andy@galois.com's avatar
andy@galois.com committed
326

327
-- language opts
Ian Lynagh's avatar
Ian Lynagh committed
328
opt_DictsStrict :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
329
opt_DictsStrict			= lookUp  (fsLit "-fdicts-strict")
Ian Lynagh's avatar
Ian Lynagh committed
330
opt_IrrefutableTuples :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
331
opt_IrrefutableTuples		= lookUp  (fsLit "-firrefutable-tuples")
Ian Lynagh's avatar
Ian Lynagh committed
332
opt_Parallel :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
333
opt_Parallel			= lookUp  (fsLit "-fparallel")
334
335

-- optimisation opts
336
337
338
339
opt_DsMultiTyVar :: Bool
opt_DsMultiTyVar		= not (lookUp (fsLit "-fno-ds-multi-tyvar"))
	-- On by default

Ian Lynagh's avatar
Ian Lynagh committed
340
opt_SpecInlineJoinPoints :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
341
opt_SpecInlineJoinPoints	= lookUp  (fsLit "-fspec-inline-join-points")
342

Ian Lynagh's avatar
Ian Lynagh committed
343
opt_NoStateHack :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
344
opt_NoStateHack			= lookUp  (fsLit "-fno-state-hack")
Ian Lynagh's avatar
Ian Lynagh committed
345
opt_CprOff :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
346
opt_CprOff			= lookUp  (fsLit "-fcpr-off")
347
	-- Switch off CPR analysis in the new demand analyser
Ian Lynagh's avatar
Ian Lynagh committed
348
opt_MaxWorkerArgs :: Int
349
350
opt_MaxWorkerArgs		= lookup_def_int "-fmax-worker-args" (10::Int)

Ian Lynagh's avatar
Ian Lynagh committed
351
opt_GranMacros :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
352
opt_GranMacros			= lookUp  (fsLit "-fgransim")
Ian Lynagh's avatar
Ian Lynagh committed
353
opt_HiVersion :: Integer
354
opt_HiVersion			= read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
Ian Lynagh's avatar
Ian Lynagh committed
355
opt_HistorySize :: Int
356
opt_HistorySize			= lookup_def_int "-fhistory-size" 20
Ian Lynagh's avatar
Ian Lynagh committed
357
opt_OmitBlackHoling :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
358
opt_OmitBlackHoling		= lookUp  (fsLit "-dno-black-holing")
359
360

-- Simplifier switches
Ian Lynagh's avatar
Ian Lynagh committed
361
opt_SimplNoPreInlining :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
362
opt_SimplNoPreInlining		= lookUp  (fsLit "-fno-pre-inlining")
363
364
	-- NoPreInlining is there just to see how bad things
	-- get if you don't do it!
Ian Lynagh's avatar
Ian Lynagh committed
365
opt_SimplExcessPrecision :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
366
opt_SimplExcessPrecision	= lookUp  (fsLit "-fexcess-precision")
367
368

-- Unfolding control
Ian Lynagh's avatar
Ian Lynagh committed
369
opt_UF_CreationThreshold :: Int
370
opt_UF_CreationThreshold	= lookup_def_int "-funfolding-creation-threshold"  (45::Int)
Ian Lynagh's avatar
Ian Lynagh committed
371
opt_UF_UseThreshold :: Int
372
opt_UF_UseThreshold		= lookup_def_int "-funfolding-use-threshold"	   (8::Int)	-- Discounts can be big
Ian Lynagh's avatar
Ian Lynagh committed
373
opt_UF_FunAppDiscount :: Int
374
opt_UF_FunAppDiscount		= lookup_def_int "-funfolding-fun-discount"	   (6::Int)	-- It's great to inline a fn
Ian Lynagh's avatar
Ian Lynagh committed
375
opt_UF_KeenessFactor :: Float
376
377
opt_UF_KeenessFactor		= lookup_def_float "-funfolding-keeness-factor"	   (1.5::Float)

Ian Lynagh's avatar
Ian Lynagh committed
378
opt_UF_DearOp :: Int
379
opt_UF_DearOp   = ( 4 :: Int)
Ian Lynagh's avatar
Ian Lynagh committed
380

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
381
382

-- Related to linking
Ian Lynagh's avatar
Ian Lynagh committed
383
opt_PIC :: Bool
384
385
386
#if darwin_TARGET_OS && x86_64_TARGET_ARCH
opt_PIC                         = True
#else
Ian Lynagh's avatar
Ian Lynagh committed
387
opt_PIC                         = lookUp (fsLit "-fPIC")
388
#endif
Ian Lynagh's avatar
Ian Lynagh committed
389
opt_Static :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
390
opt_Static			= lookUp  (fsLit "-static")
Ian Lynagh's avatar
Ian Lynagh committed
391
opt_Unregisterised :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
392
opt_Unregisterised		= lookUp  (fsLit "-funregisterised")
393
394
395
396
397

-- Derived, not a real option.  Determines whether we will be compiling
-- info tables that reside just before the entry code, or with an
-- indirection to the entry code.  See TABLES_NEXT_TO_CODE in 
-- includes/InfoTables.h.
Ian Lynagh's avatar
Ian Lynagh committed
398
tablesNextToCode :: Bool
399
400
401
tablesNextToCode 		= not opt_Unregisterised
		 		  && cGhcEnableTablesNextToCode == "YES"

Ian Lynagh's avatar
Ian Lynagh committed
402
opt_EmitExternalCore :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
403
opt_EmitExternalCore		= lookUp  (fsLit "-fext-core")
404
405

-- Include full span info in error messages, instead of just the start position.
Ian Lynagh's avatar
Ian Lynagh committed
406
opt_ErrorSpans :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
407
opt_ErrorSpans			= lookUp (fsLit "-ferror-spans")
408
409
410
411
412
413
414


-- object files and libraries to be linked in are collected here.
-- ToDo: perhaps this could be done without a global, it wasn't obvious
-- how to do it though --SDM.
GLOBAL_VAR(v_Ld_inputs,	[],      [String])

Ian Lynagh's avatar
Ian Lynagh committed
415
isStaticFlag :: String -> Bool
416
417
418
419
420
421
422
isStaticFlag f =
  f `elem` [
	"fauto-sccs-on-all-toplevs",
	"fauto-sccs-on-exported-toplevs",
	"fauto-sccs-on-individual-cafs",
	"fscc-profiling",
	"fdicts-strict",
423
	"fspec-inline-join-points",
424
425
426
427
428
429
430
	"firrefutable-tuples",
	"fparallel",
	"fgransim",
	"fno-hi-version-check",
	"dno-black-holing",
	"fno-method-sharing",
	"fno-state-hack",
431
	"fno-ds-multi-tyvar",
432
433
434
435
	"fruntime-types",
	"fno-pre-inlining",
	"fexcess-precision",
	"static",
436
	"fhardwire-lib-paths",
437
438
439
440
	"funregisterised",
	"fext-core",
	"fcpr-off",
	"ferror-spans",
441
442
	"fPIC",
	"fhpc"
443
	]
444
  || any (`isPrefixOf` f) [
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
	"fliberate-case-threshold",
	"fmax-worker-args",
	"fhistory-size",
	"funfolding-creation-threshold",
	"funfolding-use-threshold",
	"funfolding-fun-discount",
	"funfolding-keeness-factor"
     ]



-- Misc functions for command-line options

startsWith :: String -> String -> Maybe String
-- startsWith pfx (pfx++rest) = Just rest

startsWith []     str = Just str
startsWith (c:cs) (s:ss)
  = if c /= s then Nothing else startsWith cs ss
startsWith  _	  []  = Nothing


-----------------------------------------------------------------------------
-- convert sizes like "3.5M" into integers

decodeSize :: String -> Integer
decodeSize str
  | c == ""		 = truncate n
  | c == "K" || c == "k" = truncate (n * 1000)
  | c == "M" || c == "m" = truncate (n * 1000 * 1000)
  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
  | otherwise            = throwDyn (CmdLineError ("can't decode size: " ++ str))
  where (m, c) = span pred str
478
        n      = readRational m
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
	pred c = isDigit c || c == '.'


-----------------------------------------------------------------------------
-- RTS Hooks

foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()

-----------------------------------------------------------------------------
-- Ways

-- The central concept of a "way" is that all objects in a given
-- program must be compiled in the same "way".  Certain options change
-- parameters of the virtual machine, eg. profiling adds an extra word
-- to the object header, so profiling objects cannot be linked with
-- non-profiling objects.

-- After parsing the command-line options, we determine which "way" we
-- are building - this might be a combination way, eg. profiling+ticky-ticky.

-- We then find the "build-tag" associated with this way, and this
-- becomes the suffix used to find .hi files and libraries used in
-- this compilation.

GLOBAL_VAR(v_Build_tag, "", String)

-- The RTS has its own build tag, because there are some ways that
-- affect the RTS only.
GLOBAL_VAR(v_RTS_Build_tag, "", String)

data WayName
  = WayThreaded
  | WayDebug
  | WayProf
  | WayTicky
  | WayPar
  | WayGran
  | WayNDP
  | WayUser_a
  | WayUser_b
  | WayUser_c
  | WayUser_d
  | WayUser_e
  | WayUser_f
  | WayUser_g
  | WayUser_h
  | WayUser_i
  | WayUser_j
  | WayUser_k
  | WayUser_l
  | WayUser_m
  | WayUser_n
  | WayUser_o
  | WayUser_A
  | WayUser_B
  deriving (Eq,Ord)

GLOBAL_VAR(v_Ways, [] ,[WayName])

Ian Lynagh's avatar
Ian Lynagh committed
539
allowed_combination :: [WayName] -> Bool
540
541
542
543
544
545
546
547
548
549
550
551
allowed_combination way = and [ x `allowedWith` y 
			      | x <- way, y <- way, x < y ]
  where
	-- Note ordering in these tests: the left argument is
	-- <= the right argument, according to the Ord instance
	-- on Way above.

	-- debug is allowed with everything
	_ `allowedWith` WayDebug		= True
	WayDebug `allowedWith` _		= True

	WayProf `allowedWith` WayNDP		= True
Simon Marlow's avatar
Simon Marlow committed
552
	WayThreaded `allowedWith` WayProf	= True
553
554
555
556
557
558
	_ `allowedWith` _ 			= False


findBuildTag :: IO [String]  -- new options
findBuildTag = do
  way_names <- readIORef v_Ways
559
  let ws = sort (nub way_names)
560
561

  if not (allowed_combination ws)
562
563
564
565
566
567
568
569
570
571
572
573
574
      then throwDyn (CmdLineError $
      		    "combination not supported: "  ++
      		    foldr1 (\a b -> a ++ '/':b) 
      		    (map (wayName . lkupWay) ws))
      else let ways    = map lkupWay ws
      	       tag     = mkBuildTag (filter (not.wayRTSOnly) ways)
      	       rts_tag = mkBuildTag ways
      	       flags   = map wayOpts ways
      	   in do
      	   writeIORef v_Build_tag tag
      	   writeIORef v_RTS_Build_tag rts_tag
      	   return (concat flags)

575
576


577
578
579
mkBuildTag :: [Way] -> String
mkBuildTag ways = concat (intersperse "_" (map wayTag ways))

Ian Lynagh's avatar
Ian Lynagh committed
580
lkupWay :: WayName -> Way
581
582
583
584
585
lkupWay w = 
   case lookup w way_details of
	Nothing -> error "findBuildTag"
	Just details -> details

Ian Lynagh's avatar
Ian Lynagh committed
586
isRTSWay :: WayName -> Bool
587
588
isRTSWay = wayRTSOnly . lkupWay 

589
590
591
592
593
594
595
596
597
598
599
data Way = Way {
  wayTag     :: String,
  wayRTSOnly :: Bool,
  wayName    :: String,
  wayOpts    :: [String]
  }

way_details :: [ (WayName, Way) ]
way_details =
  [ (WayThreaded, Way "thr" True "Threaded" [
#if defined(freebsd_TARGET_OS)
600
601
602
603
604
605
606
--	  "-optc-pthread"
--      , "-optl-pthread"
	-- FreeBSD's default threading library is the KSE-based M:N libpthread,
	-- which GHC has some problems with.  It's currently not clear whether
	-- the problems are our fault or theirs, but it seems that using the
	-- alternative 1:1 threading library libthr works around it:
	  "-optl-lthr"
607
608
#elif defined(solaris2_TARGET_OS)
          "-optl-lrt"
609
610
611
612
613
614
615
616
#endif
	] ),

    (WayDebug, Way "debug" True "Debug" [] ),

    (WayProf, Way  "p" False "Profiling"
	[ "-fscc-profiling"
	, "-DPROFILING"
617
	, "-optc-DPROFILING" ]),
618

619
    (WayTicky, Way  "t" True "Ticky-ticky Profiling"  
620
	[ "-DTICKY_TICKY"
621
	, "-optc-DTICKY_TICKY" ]),
622
623
624
625
626
627
628
629
630
631

    -- optl's below to tell linker where to find the PVM library -- HWL
    (WayPar, Way  "mp" False "Parallel" 
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
632
        , "-optl-lgpvm3" ]),
633
634
635
636
637
638
639
640
641
642
643

    -- at the moment we only change the RTS and could share compiler and libs!
    (WayPar, Way  "mt" False "Parallel ticky profiling" 
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DPAR_TICKY"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
644
        , "-optl-lgpvm3" ]),
645
646
647
648
649
650
651
652
653
654
655

    (WayPar, Way  "md" False "Distributed" 
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-D__DISTRIBUTED_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DDIST"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
656
        , "-optl-lgpvm3" ]),
657
658
659
660
661

    (WayGran, Way  "mg" False "GranSim"
	[ "-fgransim"
	, "-D__GRANSIM__"
	, "-optc-DGRAN"
662
	, "-package concurrent" ]),
663
664
665

    (WayNDP, Way  "ndp" False "Nested data parallelism"
	[ "-fparr"
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
666
	, "-fvectorise"]),
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686

    (WayUser_a,  Way  "a"  False "User way 'a'"  ["$WAY_a_REAL_OPTS"]),	
    (WayUser_b,  Way  "b"  False "User way 'b'"  ["$WAY_b_REAL_OPTS"]),	
    (WayUser_c,  Way  "c"  False "User way 'c'"  ["$WAY_c_REAL_OPTS"]),	
    (WayUser_d,  Way  "d"  False "User way 'd'"  ["$WAY_d_REAL_OPTS"]),	
    (WayUser_e,  Way  "e"  False "User way 'e'"  ["$WAY_e_REAL_OPTS"]),	
    (WayUser_f,  Way  "f"  False "User way 'f'"  ["$WAY_f_REAL_OPTS"]),	
    (WayUser_g,  Way  "g"  False "User way 'g'"  ["$WAY_g_REAL_OPTS"]),	
    (WayUser_h,  Way  "h"  False "User way 'h'"  ["$WAY_h_REAL_OPTS"]),	
    (WayUser_i,  Way  "i"  False "User way 'i'"  ["$WAY_i_REAL_OPTS"]),	
    (WayUser_j,  Way  "j"  False "User way 'j'"  ["$WAY_j_REAL_OPTS"]),	
    (WayUser_k,  Way  "k"  False "User way 'k'"  ["$WAY_k_REAL_OPTS"]),	
    (WayUser_l,  Way  "l"  False "User way 'l'"  ["$WAY_l_REAL_OPTS"]),	
    (WayUser_m,  Way  "m"  False "User way 'm'"  ["$WAY_m_REAL_OPTS"]),	
    (WayUser_n,  Way  "n"  False "User way 'n'"  ["$WAY_n_REAL_OPTS"]),	
    (WayUser_o,  Way  "o"  False "User way 'o'"  ["$WAY_o_REAL_OPTS"]),	
    (WayUser_A,  Way  "A"  False "User way 'A'"  ["$WAY_A_REAL_OPTS"]),	
    (WayUser_B,  Way  "B"  False "User way 'B'"  ["$WAY_B_REAL_OPTS"]) 
  ]

Ian Lynagh's avatar
Ian Lynagh committed
687
unregFlags :: [String]
688
689
690
691
692
693
unregFlags = 
   [ "-optc-DNO_REGS"
   , "-optc-DUSE_MINIINTERPRETER"
   , "-fno-asm-mangling"
   , "-funregisterised"
   , "-fvia-C" ]