StaticFlags.hs 21.4 KB
Newer Older
1
2
3
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

4
5
6
7
8
9
10
11
12
13
14
15
16
17
-----------------------------------------------------------------------------
--
-- 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,
18
        initStaticOpts,
19
20

	-- Ways
21
	WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag, isRTSWay,
22
23
24

	-- Output style options
	opt_PprUserLength,
25
	opt_SuppressUniques,
26
	opt_PprStyle_Debug,
Simon Marlow's avatar
Simon Marlow committed
27
        opt_NoDebugOutput,
28
29
30
31
32
33
34
35

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

andy@galois.com's avatar
andy@galois.com committed
36
37
38
        -- Hpc opts
	opt_Hpc,

39
40
41
42
43
44
	-- language opts
	opt_DictsStrict,
	opt_IrrefutableTuples,
	opt_Parallel,

	-- optimisation opts
45
	opt_DsMultiTyVar,
46
	opt_NoStateHack,
47
	opt_SpecInlineJoinPoints,
48
49
50
51
52
53
54
55
56
57
58
59
	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
60
61
62
	-- Optimization fuel controls
	opt_Fuel,

63
64
65
66
	-- Related to linking
	opt_PIC,
	opt_Static,

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

#include "HsVersions.h"

import CmdLineParser
83
import Config
84
import FastString
85
86
import Util
import Maybes		( firstJust )
87
import Panic
88

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

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

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

103
  (leftover, errs, warns1) <- processArgs static_flags args
104
  when (not (null errs)) $ ghcError (UsageError (unlines errs))
105
106

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

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

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

116
117
118
    -- see sanity code in staticOpts
  writeIORef v_opt_C_ready True

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

Simon Marlow's avatar
Simon Marlow committed
126
127
128
129
130
131
    -- 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                = []

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

136
137
initStaticOpts :: IO ()
initStaticOpts = writeIORef v_opt_C_ready True
138

139
static_flags :: [Flag IO]
140
141
142
143
144
145
146
-- 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
147
--	opt_foo = lookUp (fsLit "-dfoo")
148
149

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

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

        ------- ways --------------------------------------------------------
159
160
161
162
163
164
165
166
167
  , 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
168
169
170
        -- ToDo: user ways

        ------ Debugging ----------------------------------------------------
171
172
173
174
175
  , 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
176
177
      -- rest of the debugging flags are dynamic

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

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

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

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
222
removeOpt :: String -> IO ()
223
224
225
226
227
228
229
230
231
232
233
234
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])
235
GLOBAL_VAR(v_opt_C_ready, False, Bool)
Ian Lynagh's avatar
Ian Lynagh committed
236
237

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

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

Ian Lynagh's avatar
Ian Lynagh committed
248
packed_static_opts :: [FastString]
249
250
251
252
253
254
255
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 
256
   = case firstJust (map (maybePrefixMatch sw) staticFlags) of
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
295
296
	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
297
opt_IgnoreDotGhci :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
298
opt_IgnoreDotGhci		= lookUp (fsLit "-ignore-dot-ghci")
299
300

-- debugging opts
Ian Lynagh's avatar
Ian Lynagh committed
301
opt_SuppressUniques :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
302
opt_SuppressUniques		= lookUp  (fsLit "-dsuppress-uniques")
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
303
opt_PprStyle_Debug  :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
304
opt_PprStyle_Debug		= lookUp  (fsLit "-dppr-debug")
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
305
opt_PprUserLength   :: Int
306
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
307
308
opt_Fuel            :: Int
opt_Fuel                        = lookup_def_int "-dopt-fuel" maxBound
Simon Marlow's avatar
Simon Marlow committed
309
310
311
opt_NoDebugOutput   :: Bool
opt_NoDebugOutput               = lookUp  (fsLit "-dno-debug-output")

312
313

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

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

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

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

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

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

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

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

-- Unfolding control
Ian Lynagh's avatar
Ian Lynagh committed
371
opt_UF_CreationThreshold :: Int
372
opt_UF_CreationThreshold	= lookup_def_int "-funfolding-creation-threshold"  (45::Int)
Ian Lynagh's avatar
Ian Lynagh committed
373
opt_UF_UseThreshold :: Int
374
opt_UF_UseThreshold		= lookup_def_int "-funfolding-use-threshold"	   (8::Int)	-- Discounts can be big
Ian Lynagh's avatar
Ian Lynagh committed
375
opt_UF_FunAppDiscount :: Int
376
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
377
opt_UF_KeenessFactor :: Float
378
379
opt_UF_KeenessFactor		= lookup_def_float "-funfolding-keeness-factor"	   (1.5::Float)

Ian Lynagh's avatar
Ian Lynagh committed
380
opt_UF_DearOp :: Int
381
opt_UF_DearOp   = ( 4 :: Int)
Ian Lynagh's avatar
Ian Lynagh committed
382

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
383
384

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

-- 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
400
tablesNextToCode :: Bool
401
402
403
tablesNextToCode 		= not opt_Unregisterised
		 		  && cGhcEnableTablesNextToCode == "YES"

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

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


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

-----------------------------------------------------------------------------
-- 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)
465
  | otherwise            = ghcError (CmdLineError ("can't decode size: " ++ str))
466
  where (m, c) = span pred str
467
        n      = readRational m
468
469
470
471
472
473
474
475
476
477
478
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
	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
528
allowed_combination :: [WayName] -> Bool
529
530
531
532
533
534
535
536
537
538
539
540
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
541
	WayThreaded `allowedWith` WayProf	= True
542
543
544
545
546
547
	_ `allowedWith` _ 			= False


findBuildTag :: IO [String]  -- new options
findBuildTag = do
  way_names <- readIORef v_Ways
548
  let ws = sort (nub way_names)
549
550

  if not (allowed_combination ws)
551
      then ghcError (CmdLineError $
552
553
554
555
556
557
558
559
560
561
562
563
      		    "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)

564
565


566
567
568
mkBuildTag :: [Way] -> String
mkBuildTag ways = concat (intersperse "_" (map wayTag ways))

Ian Lynagh's avatar
Ian Lynagh committed
569
lkupWay :: WayName -> Way
570
571
572
573
574
lkupWay w = 
   case lookup w way_details of
	Nothing -> error "findBuildTag"
	Just details -> details

Ian Lynagh's avatar
Ian Lynagh committed
575
isRTSWay :: WayName -> Bool
576
577
isRTSWay = wayRTSOnly . lkupWay 

578
579
580
581
582
583
584
585
586
587
588
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)
589
590
591
592
593
594
595
--	  "-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"
596
597
#elif defined(solaris2_TARGET_OS)
          "-optl-lrt"
598
599
600
601
602
603
604
605
#endif
	] ),

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

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

608
    (WayTicky, Way  "t" True "Ticky-ticky Profiling"  
609
	[ "-DTICKY_TICKY"
610
	, "-optc-DTICKY_TICKY" ]),
611
612
613
614
615
616
617
618
619
620

    -- 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"
621
        , "-optl-lgpvm3" ]),
622
623
624
625
626
627
628
629
630
631
632

    -- 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"
633
        , "-optl-lgpvm3" ]),
634
635
636
637
638
639
640
641
642
643
644

    (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"
645
        , "-optl-lgpvm3" ]),
646
647
648
649
650

    (WayGran, Way  "mg" False "GranSim"
	[ "-fgransim"
	, "-D__GRANSIM__"
	, "-optc-DGRAN"
651
	, "-package concurrent" ]),
652
653

    (WayNDP, Way  "ndp" False "Nested data parallelism"
654
	[ "-XParr"
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
655
	, "-fvectorise"]),
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675

    (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
676
unregFlags :: [String]
677
678
679
680
681
682
unregFlags = 
   [ "-optc-DNO_REGS"
   , "-optc-DUSE_MINIINTERPRETER"
   , "-fno-asm-mangling"
   , "-funregisterised"
   , "-fvia-C" ]