StaticFlags.hs 12.8 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
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
	-- misc opts
	opt_IgnoreDotGhci,
	opt_ErrorSpans,
	opt_GranMacros,
	opt_HiVersion,
	opt_HistorySize,
	opt_OmitBlackHoling,
	opt_Unregisterised,
	v_Ld_inputs,
73
	tablesNextToCode,
74
        opt_StubDeadValues,
75
76

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

#include "HsVersions.h"

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

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

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

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

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
131
packed_static_opts :: [FastString]
132
133
134
135
136
137
138
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 
139
   = case firstJust (map (stripPrefix sw) staticFlags) of
140
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
	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
180
opt_IgnoreDotGhci :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
181
opt_IgnoreDotGhci		= lookUp (fsLit "-ignore-dot-ghci")
182
183

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

197
198

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

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

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

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

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

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

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

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

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

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

-- Unfolding control
Ian Lynagh's avatar
Ian Lynagh committed
254
opt_UF_CreationThreshold :: Int
255
opt_UF_CreationThreshold	= lookup_def_int "-funfolding-creation-threshold"  (45::Int)
Ian Lynagh's avatar
Ian Lynagh committed
256
opt_UF_UseThreshold :: Int
257
opt_UF_UseThreshold		= lookup_def_int "-funfolding-use-threshold"	   (6::Int)	-- Discounts can be big
Ian Lynagh's avatar
Ian Lynagh committed
258
opt_UF_FunAppDiscount :: Int
259
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
260
opt_UF_KeenessFactor :: Float
261
262
opt_UF_KeenessFactor		= lookup_def_float "-funfolding-keeness-factor"	   (1.5::Float)

Ian Lynagh's avatar
Ian Lynagh committed
263
opt_UF_DearOp :: Int
264
opt_UF_DearOp   = ( 4 :: Int)
Ian Lynagh's avatar
Ian Lynagh committed
265

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
266
267

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

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

287
-- Include full span info in error messages, instead of just the start position.
Ian Lynagh's avatar
Ian Lynagh committed
288
opt_ErrorSpans :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
289
opt_ErrorSpans			= lookUp (fsLit "-ferror-spans")
290
291
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


-- 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
317
  | WayEventLog
318
319
320
321
  | WayTicky
  | WayPar
  | WayGran
  | WayNDP
322
  | WayDyn
323
324
  deriving (Eq,Ord)

325
GLOBAL_VAR(v_Ways, [] ,[Way])
326

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

335
336
337
338
	-- dyn is allowed with everything
	_ `allowedWith` WayDyn  		= True
	WayDyn `allowedWith` _		        = True

339
340
341
342
343
	-- debug is allowed with everything
	_ `allowedWith` WayDebug		= True
	WayDebug `allowedWith` _		= True

	WayProf `allowedWith` WayNDP		= True
Simon Marlow's avatar
Simon Marlow committed
344
	WayThreaded `allowedWith` WayProf	= True
Simon Marlow's avatar
Simon Marlow committed
345
	WayThreaded `allowedWith` WayEventLog	= True
346
347
348
	_ `allowedWith` _ 			= False


349
350
351
352
353
354
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
355

356
  if not (allowed_combination (map wayName ways))
357
      then ghcError (CmdLineError $
358
359
      		    "combination not supported: "  ++
      		    foldr1 (\a b -> a ++ '/':b) 
360
361
362
      		    (map wayDesc ways))
      else
      	   return (concatMap wayOpts ways)
363

364
365
366
mkBuildTag :: [Way] -> String
mkBuildTag ways = concat (intersperse "_" (map wayTag ways))

Ian Lynagh's avatar
Ian Lynagh committed
367
lkupWay :: WayName -> Way
368
lkupWay w = 
369
   case listToMaybe (filter ((==) w . wayName) way_details) of
370
371
372
	Nothing -> error "findBuildTag"
	Just details -> details

Ian Lynagh's avatar
Ian Lynagh committed
373
isRTSWay :: WayName -> Bool
374
375
isRTSWay = wayRTSOnly . lkupWay 

376
data Way = Way {
377
  wayName    :: WayName,
378
379
  wayTag     :: String,
  wayRTSOnly :: Bool,
380
  wayDesc    :: String,
381
382
383
  wayOpts    :: [String]
  }

384
way_details :: [ Way ]
385
way_details =
386
  [ Way WayThreaded "thr" True "Threaded" [
387
#if defined(freebsd_TARGET_OS)
388
389
390
391
392
393
394
--	  "-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"
395
396
#elif defined(solaris2_TARGET_OS)
          "-optl-lrt"
397
#endif
398
399
400
	],

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

402
403
404
    Way WayDyn "dyn" False "Dynamic"
	[ "-DDYNAMIC"
	, "-optc-DDYNAMIC" ],
405

406
    Way WayProf "p" False "Profiling"
407
408
	[ "-fscc-profiling"
	, "-DPROFILING"
409
	, "-optc-DPROFILING" ],
410

411
    Way WayEventLog "l" True "RTS Event Logging"
412
413
	[ "-DTRACING"
	, "-optc-DTRACING" ],
Simon Marlow's avatar
Simon Marlow committed
414

415
    Way WayTicky "t" True "Ticky-ticky Profiling"  
416
	[ "-DTICKY_TICKY"
417
	, "-optc-DTICKY_TICKY" ],
418

419
    Way WayPar "mp" False "Parallel" 
420
421
422
423
424
425
426
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
427
        , "-optl-lgpvm3" ],
428
429

    -- at the moment we only change the RTS and could share compiler and libs!
430
    Way WayPar "mt" False "Parallel ticky profiling" 
431
432
433
434
435
436
437
438
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DPAR_TICKY"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
439
        , "-optl-lgpvm3" ],
440

441
    Way WayPar "md" False "Distributed" 
442
443
444
445
446
447
448
449
450
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-D__DISTRIBUTED_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DDIST"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
451
        , "-optl-lgpvm3" ],
452

453
    Way WayGran "mg" False "GranSim"
454
455
456
	[ "-fgransim"
	, "-D__GRANSIM__"
	, "-optc-DGRAN"
457
	, "-package concurrent" ],
458

459
    Way WayNDP "ndp" False "Nested data parallelism"
460
	[ "-XParr"
461
	, "-fvectorise"]
462
  ]