StaticFlags.hs 13.1 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
-----------------------------------------------------------------------------
--
-- 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 (
	staticFlags,
17
        initStaticOpts,
18
19

	-- Ways
20
	WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag,
21
22
23

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

	-- profiling opts
	opt_SccProfilingOn,

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

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

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

	-- Unfolding control
	opt_UF_CreationThreshold,
	opt_UF_UseThreshold,
	opt_UF_FunAppDiscount,
54
	opt_UF_DictDiscount,
55
56
57
	opt_UF_KeenessFactor,
	opt_UF_DearOp,

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

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

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,
	v_Ld_inputs,
74
	tablesNextToCode,
75
        opt_StubDeadValues,
76
77

    -- For the parser
78
    addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready
79
80
81
82
  ) where

#include "HsVersions.h"

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

89
import Data.Maybe       ( listToMaybe )
Simon Marlow's avatar
Simon Marlow committed
90
91
import Data.IORef
import System.IO.Unsafe	( unsafePerformIO )
92
import Data.List
93
94
95
96

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

97
98
initStaticOpts :: IO ()
initStaticOpts = writeIORef v_opt_C_ready True
99

Ian Lynagh's avatar
Ian Lynagh committed
100
addOpt :: String -> IO ()
101
102
addOpt = consIORef v_opt_C

Ian Lynagh's avatar
Ian Lynagh committed
103
addWay :: WayName -> IO ()
104
addWay = consIORef v_Ways . lkupWay
105

Ian Lynagh's avatar
Ian Lynagh committed
106
removeOpt :: String -> IO ()
107
108
109
110
111
112
113
114
115
116
117
118
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])
119
GLOBAL_VAR(v_opt_C_ready, False, Bool)
Ian Lynagh's avatar
Ian Lynagh committed
120
121

staticFlags :: [String]
122
123
124
staticFlags = unsafePerformIO $ do
  ready <- readIORef v_opt_C_ready
  if (not ready)
125
        then panic "Static flags have not been initialised!\n        Please call GHC.newSession or GHC.parseStaticFlags early enough."
126
        else readIORef v_opt_C
127
128

-- -static is the default
Ian Lynagh's avatar
Ian Lynagh committed
129
defaultStaticOpts :: [String]
130
131
defaultStaticOpts = ["-static"]

Ian Lynagh's avatar
Ian Lynagh committed
132
packed_static_opts :: [FastString]
133
134
135
136
137
138
139
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 
140
   = case firstJust (map (stripPrefix sw) staticFlags) of
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
	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
181
opt_IgnoreDotGhci :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
182
opt_IgnoreDotGhci		= lookUp (fsLit "-ignore-dot-ghci")
183
184

-- debugging opts
Ian Lynagh's avatar
Ian Lynagh committed
185
opt_SuppressUniques :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
186
opt_SuppressUniques		= lookUp  (fsLit "-dsuppress-uniques")
187
188
opt_SuppressCoercions :: Bool
opt_SuppressCoercions           = lookUp  (fsLit "-dsuppress-coercions")
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
189
opt_PprStyle_Debug  :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
190
opt_PprStyle_Debug		= lookUp  (fsLit "-dppr-debug")
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
191
opt_PprUserLength   :: Int
192
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
193
194
opt_Fuel            :: Int
opt_Fuel                        = lookup_def_int "-dopt-fuel" maxBound
Simon Marlow's avatar
Simon Marlow committed
195
196
197
opt_NoDebugOutput   :: Bool
opt_NoDebugOutput               = lookUp  (fsLit "-dno-debug-output")

198
199

-- profiling opts
Ian Lynagh's avatar
Ian Lynagh committed
200
opt_SccProfilingOn :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
201
opt_SccProfilingOn		= lookUp  (fsLit "-fscc-profiling")
andy@galois.com's avatar
andy@galois.com committed
202

203
-- Hpc opts
Ian Lynagh's avatar
Ian Lynagh committed
204
opt_Hpc :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
205
opt_Hpc				= lookUp (fsLit "-fhpc")  
andy@galois.com's avatar
andy@galois.com committed
206

207
-- language opts
Ian Lynagh's avatar
Ian Lynagh committed
208
opt_DictsStrict :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
209
opt_DictsStrict			= lookUp  (fsLit "-fdicts-strict")
Ian Lynagh's avatar
Ian Lynagh committed
210
opt_IrrefutableTuples :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
211
opt_IrrefutableTuples		= lookUp  (fsLit "-firrefutable-tuples")
Ian Lynagh's avatar
Ian Lynagh committed
212
opt_Parallel :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
213
opt_Parallel			= lookUp  (fsLit "-fparallel")
214
215

-- optimisation opts
216
217
218
219
opt_DsMultiTyVar :: Bool
opt_DsMultiTyVar		= not (lookUp (fsLit "-fno-ds-multi-tyvar"))
	-- On by default

Ian Lynagh's avatar
Ian Lynagh committed
220
opt_SpecInlineJoinPoints :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
221
opt_SpecInlineJoinPoints	= lookUp  (fsLit "-fspec-inline-join-points")
222

223
224
225
opt_SimpleListLiterals :: Bool
opt_SimpleListLiterals	        = lookUp  (fsLit "-fsimple-list-literals")

Ian Lynagh's avatar
Ian Lynagh committed
226
opt_NoStateHack :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
227
opt_NoStateHack			= lookUp  (fsLit "-fno-state-hack")
228

Ian Lynagh's avatar
Ian Lynagh committed
229
opt_CprOff :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
230
opt_CprOff			= lookUp  (fsLit "-fcpr-off")
231
	-- Switch off CPR analysis in the new demand analyser
Ian Lynagh's avatar
Ian Lynagh committed
232
opt_MaxWorkerArgs :: Int
233
234
opt_MaxWorkerArgs		= lookup_def_int "-fmax-worker-args" (10::Int)

Ian Lynagh's avatar
Ian Lynagh committed
235
opt_GranMacros :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
236
opt_GranMacros			= lookUp  (fsLit "-fgransim")
Ian Lynagh's avatar
Ian Lynagh committed
237
opt_HiVersion :: Integer
238
opt_HiVersion			= read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
Ian Lynagh's avatar
Ian Lynagh committed
239
opt_HistorySize :: Int
240
opt_HistorySize			= lookup_def_int "-fhistory-size" 20
Ian Lynagh's avatar
Ian Lynagh committed
241
opt_OmitBlackHoling :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
242
opt_OmitBlackHoling		= lookUp  (fsLit "-dno-black-holing")
243
244
opt_StubDeadValues  :: Bool
opt_StubDeadValues		= lookUp  (fsLit "-dstub-dead-values")
245
246

-- Simplifier switches
Ian Lynagh's avatar
Ian Lynagh committed
247
opt_SimplNoPreInlining :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
248
opt_SimplNoPreInlining		= lookUp  (fsLit "-fno-pre-inlining")
249
250
	-- NoPreInlining is there just to see how bad things
	-- get if you don't do it!
Ian Lynagh's avatar
Ian Lynagh committed
251
opt_SimplExcessPrecision :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
252
opt_SimplExcessPrecision	= lookUp  (fsLit "-fexcess-precision")
253
254

-- Unfolding control
255
256
257
258
-- See Note [Discounts and thresholds] in CoreUnfold

opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int
opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int
Ian Lynagh's avatar
Ian Lynagh committed
259
opt_UF_KeenessFactor :: Float
260

261
262
263
264
265
266
opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int)
opt_UF_UseThreshold	 = lookup_def_int "-funfolding-use-threshold"	   (6::Int)
opt_UF_FunAppDiscount	 = lookup_def_int "-funfolding-fun-discount"	   (6::Int)
opt_UF_DictDiscount	 = lookup_def_int "-funfolding-dict-discount"	   (1::Int)
opt_UF_KeenessFactor	 = lookup_def_float "-funfolding-keeness-factor"   (1.5::Float)
opt_UF_DearOp            = ( 4 :: Int)
Ian Lynagh's avatar
Ian Lynagh committed
267

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
268
269

-- Related to linking
Ian Lynagh's avatar
Ian Lynagh committed
270
opt_PIC :: Bool
271
272
273
#if darwin_TARGET_OS && x86_64_TARGET_ARCH
opt_PIC                         = True
#else
Ian Lynagh's avatar
Ian Lynagh committed
274
opt_PIC                         = lookUp (fsLit "-fPIC")
275
#endif
Ian Lynagh's avatar
Ian Lynagh committed
276
opt_Static :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
277
opt_Static			= lookUp  (fsLit "-static")
Ian Lynagh's avatar
Ian Lynagh committed
278
opt_Unregisterised :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
279
opt_Unregisterised		= lookUp  (fsLit "-funregisterised")
280
281
282
283

-- 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 
Simon Marlow's avatar
Simon Marlow committed
284
-- includes/rts/storage/InfoTables.h.
Ian Lynagh's avatar
Ian Lynagh committed
285
tablesNextToCode :: Bool
286
287
288
tablesNextToCode 		= not opt_Unregisterised
		 		  && cGhcEnableTablesNextToCode == "YES"

289
-- Include full span info in error messages, instead of just the start position.
Ian Lynagh's avatar
Ian Lynagh committed
290
opt_ErrorSpans :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
291
opt_ErrorSpans			= lookUp (fsLit "-ferror-spans")
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318


-- 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])

-----------------------------------------------------------------------------
-- 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.

data WayName
  = WayThreaded
  | WayDebug
  | WayProf
Simon Marlow's avatar
Simon Marlow committed
319
  | WayEventLog
320
321
322
323
  | WayTicky
  | WayPar
  | WayGran
  | WayNDP
324
  | WayDyn
325
326
  deriving (Eq,Ord)

327
GLOBAL_VAR(v_Ways, [] ,[Way])
328

Ian Lynagh's avatar
Ian Lynagh committed
329
allowed_combination :: [WayName] -> Bool
330
331
332
333
334
335
336
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.

337
338
339
340
	-- dyn is allowed with everything
	_ `allowedWith` WayDyn  		= True
	WayDyn `allowedWith` _		        = True

341
342
343
344
345
	-- ticky is (now) allowed with everything
	-- Indeed, ticky should no longer be a 'way' at all
	_ `allowedWith` WayTicky  		= True
	WayTicky `allowedWith` _	        = True

346
347
348
349
350
	-- debug is allowed with everything
	_ `allowedWith` WayDebug		= True
	WayDebug `allowedWith` _		= True

	WayProf `allowedWith` WayNDP		= True
Simon Marlow's avatar
Simon Marlow committed
351
	WayThreaded `allowedWith` WayProf	= True
Simon Marlow's avatar
Simon Marlow committed
352
	WayThreaded `allowedWith` WayEventLog	= True
353
354
355
	_ `allowedWith` _ 			= False


356
357
358
359
360
361
getWayFlags :: IO [String]  -- new options
getWayFlags = do
  unsorted <- readIORef v_Ways
  let ways = sortBy (compare `on` wayName) $
             nubBy  ((==) `on` wayName) $ unsorted
  writeIORef v_Ways ways
362

363
  if not (allowed_combination (map wayName ways))
364
      then ghcError (CmdLineError $
365
366
      		    "combination not supported: "  ++
      		    foldr1 (\a b -> a ++ '/':b) 
367
368
369
      		    (map wayDesc ways))
      else
      	   return (concatMap wayOpts ways)
370

371
372
373
mkBuildTag :: [Way] -> String
mkBuildTag ways = concat (intersperse "_" (map wayTag ways))

Ian Lynagh's avatar
Ian Lynagh committed
374
lkupWay :: WayName -> Way
375
lkupWay w = 
376
   case listToMaybe (filter ((==) w . wayName) way_details) of
377
378
379
	Nothing -> error "findBuildTag"
	Just details -> details

Ian Lynagh's avatar
Ian Lynagh committed
380
isRTSWay :: WayName -> Bool
381
382
isRTSWay = wayRTSOnly . lkupWay 

383
data Way = Way {
384
  wayName    :: WayName,
385
386
  wayTag     :: String,
  wayRTSOnly :: Bool,
387
  wayDesc    :: String,
388
389
390
  wayOpts    :: [String]
  }

391
way_details :: [ Way ]
392
way_details =
393
  [ Way WayThreaded "thr" True "Threaded" [
394
#if defined(freebsd_TARGET_OS)
395
396
397
398
399
400
401
--	  "-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"
402
403
#elif defined(solaris2_TARGET_OS)
          "-optl-lrt"
404
#endif
405
406
407
	],

    Way WayDebug "debug" True "Debug" [],
408

409
410
411
    Way WayDyn "dyn" False "Dynamic"
	[ "-DDYNAMIC"
	, "-optc-DDYNAMIC" ],
412

413
    Way WayProf "p" False "Profiling"
414
415
	[ "-fscc-profiling"
	, "-DPROFILING"
416
	, "-optc-DPROFILING" ],
417

418
    Way WayEventLog "l" True "RTS Event Logging"
419
420
	[ "-DTRACING"
	, "-optc-DTRACING" ],
Simon Marlow's avatar
Simon Marlow committed
421

422
    Way WayTicky "t" True "Ticky-ticky Profiling"  
423
	[ "-DTICKY_TICKY"
424
	, "-optc-DTICKY_TICKY" ],
425

426
    Way WayPar "mp" False "Parallel" 
427
428
429
430
431
432
433
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
434
        , "-optl-lgpvm3" ],
435
436

    -- at the moment we only change the RTS and could share compiler and libs!
437
    Way WayPar "mt" False "Parallel ticky profiling" 
438
439
440
441
442
443
444
445
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DPAR_TICKY"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
446
        , "-optl-lgpvm3" ],
447

448
    Way WayPar "md" False "Distributed" 
449
450
451
452
453
454
455
456
457
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-D__DISTRIBUTED_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DDIST"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
458
        , "-optl-lgpvm3" ],
459

460
    Way WayGran "mg" False "GranSim"
461
462
463
	[ "-fgransim"
	, "-D__GRANSIM__"
	, "-optc-DGRAN"
464
	, "-package concurrent" ],
465

466
    Way WayNDP "ndp" False "Nested data parallelism"
467
	[ "-XParr"
468
	, "-fvectorise"]
469
  ]