StaticFlags.hs 13.7 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_SuppressModulePrefixes,
27
	opt_PprStyle_Debug, opt_TraceLevel,
Simon Marlow's avatar
Simon Marlow committed
28
        opt_NoDebugOutput,
29
30
31
32

	-- profiling opts
	opt_SccProfilingOn,

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_SimpleListLiterals,
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
        opt_Ticky,
77
78

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

#include "HsVersions.h"

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

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

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

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

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

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

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

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

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

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

-- debugging opts
Ian Lynagh's avatar
Ian Lynagh committed
186
opt_SuppressUniques :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
187
opt_SuppressUniques		= lookUp  (fsLit "-dsuppress-uniques")
benl@ouroborus.net's avatar
benl@ouroborus.net committed
188

189
190
opt_SuppressCoercions :: Bool
opt_SuppressCoercions           = lookUp  (fsLit "-dsuppress-coercions")
benl@ouroborus.net's avatar
benl@ouroborus.net committed
191

192
193
194
opt_SuppressModulePrefixes :: Bool
opt_SuppressModulePrefixes	= lookUp  (fsLit "-dsuppress-module-prefixes")

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
195
opt_PprStyle_Debug  :: Bool
196
197
198
199
200
opt_PprStyle_Debug              = lookUp  (fsLit "-dppr-debug")

opt_TraceLevel :: Int
opt_TraceLevel = lookup_def_int "-dtrace-level" 1  	-- Standard level is 1
	       	 			    	        -- Less verbose is 0
benl@ouroborus.net's avatar
benl@ouroborus.net committed
201

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
202
opt_PprUserLength   :: Int
203
opt_PprUserLength	        = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
benl@ouroborus.net's avatar
benl@ouroborus.net committed
204

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
205
206
opt_Fuel            :: Int
opt_Fuel                        = lookup_def_int "-dopt-fuel" maxBound
benl@ouroborus.net's avatar
benl@ouroborus.net committed
207

Simon Marlow's avatar
Simon Marlow committed
208
209
210
opt_NoDebugOutput   :: Bool
opt_NoDebugOutput               = lookUp  (fsLit "-dno-debug-output")

211
212

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

216
-- Hpc opts
Ian Lynagh's avatar
Ian Lynagh committed
217
opt_Hpc :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
218
opt_Hpc				= lookUp (fsLit "-fhpc")  
andy@galois.com's avatar
andy@galois.com committed
219

220
-- language opts
Ian Lynagh's avatar
Ian Lynagh committed
221
opt_DictsStrict :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
222
opt_DictsStrict			= lookUp  (fsLit "-fdicts-strict")
223

Ian Lynagh's avatar
Ian Lynagh committed
224
opt_IrrefutableTuples :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
225
opt_IrrefutableTuples		= lookUp  (fsLit "-firrefutable-tuples")
226

Ian Lynagh's avatar
Ian Lynagh committed
227
opt_Parallel :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
228
opt_Parallel			= lookUp  (fsLit "-fparallel")
229
230

-- optimisation opts
231
232
233
234
opt_DsMultiTyVar :: Bool
opt_DsMultiTyVar		= not (lookUp (fsLit "-fno-ds-multi-tyvar"))
	-- On by default

235
236
237
opt_SimpleListLiterals :: Bool
opt_SimpleListLiterals	        = lookUp  (fsLit "-fsimple-list-literals")

Ian Lynagh's avatar
Ian Lynagh committed
238
opt_NoStateHack :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
239
opt_NoStateHack			= lookUp  (fsLit "-fno-state-hack")
240

Ian Lynagh's avatar
Ian Lynagh committed
241
opt_CprOff :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
242
opt_CprOff			= lookUp  (fsLit "-fcpr-off")
243
	-- Switch off CPR analysis in the new demand analyser
Ian Lynagh's avatar
Ian Lynagh committed
244
opt_MaxWorkerArgs :: Int
245
246
opt_MaxWorkerArgs		= lookup_def_int "-fmax-worker-args" (10::Int)

Ian Lynagh's avatar
Ian Lynagh committed
247
opt_GranMacros :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
248
opt_GranMacros			= lookUp  (fsLit "-fgransim")
249

Ian Lynagh's avatar
Ian Lynagh committed
250
opt_HiVersion :: Integer
251
opt_HiVersion			= read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
252

Ian Lynagh's avatar
Ian Lynagh committed
253
opt_HistorySize :: Int
254
opt_HistorySize			= lookup_def_int "-fhistory-size" 20
255

Ian Lynagh's avatar
Ian Lynagh committed
256
opt_OmitBlackHoling :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
257
opt_OmitBlackHoling		= lookUp  (fsLit "-dno-black-holing")
258

259
260
opt_StubDeadValues  :: Bool
opt_StubDeadValues		= lookUp  (fsLit "-dstub-dead-values")
261
262

-- Simplifier switches
Ian Lynagh's avatar
Ian Lynagh committed
263
opt_SimplNoPreInlining :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
264
opt_SimplNoPreInlining		= lookUp  (fsLit "-fno-pre-inlining")
265
266
	-- NoPreInlining is there just to see how bad things
	-- get if you don't do it!
Ian Lynagh's avatar
Ian Lynagh committed
267
opt_SimplExcessPrecision :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
268
opt_SimplExcessPrecision	= lookUp  (fsLit "-fexcess-precision")
269
270

-- Unfolding control
271
272
273
274
-- 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
275
opt_UF_KeenessFactor :: Float
276

277
278
279
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)
280
281
282
283
284

opt_UF_DictDiscount	 = lookup_def_int "-funfolding-dict-discount"	   (3::Int)
   -- Be fairly keen to inline a fuction if that means
   -- we'll be able to pick the right method from a dictionary

285
286
opt_UF_KeenessFactor	 = lookup_def_float "-funfolding-keeness-factor"   (1.5::Float)
opt_UF_DearOp            = ( 4 :: Int)
Ian Lynagh's avatar
Ian Lynagh committed
287

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
288
289

-- Related to linking
Ian Lynagh's avatar
Ian Lynagh committed
290
opt_PIC :: Bool
291
292
#if darwin_TARGET_OS && x86_64_TARGET_ARCH
opt_PIC                         = True
293
294
#elif darwin_TARGET_OS
opt_PIC                         = lookUp (fsLit "-fPIC") || not opt_Static
295
#else
Ian Lynagh's avatar
Ian Lynagh committed
296
opt_PIC                         = lookUp (fsLit "-fPIC")
297
#endif
Ian Lynagh's avatar
Ian Lynagh committed
298
opt_Static :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
299
opt_Static			= lookUp  (fsLit "-static")
Ian Lynagh's avatar
Ian Lynagh committed
300
opt_Unregisterised :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
301
opt_Unregisterised		= lookUp  (fsLit "-funregisterised")
302
303
304
305

-- 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
306
-- includes/rts/storage/InfoTables.h.
Ian Lynagh's avatar
Ian Lynagh committed
307
tablesNextToCode :: Bool
308
309
310
tablesNextToCode 		= not opt_Unregisterised
		 		  && cGhcEnableTablesNextToCode == "YES"

311
-- Include full span info in error messages, instead of just the start position.
Ian Lynagh's avatar
Ian Lynagh committed
312
opt_ErrorSpans :: Bool
Ian Lynagh's avatar
Ian Lynagh committed
313
opt_ErrorSpans			= lookUp (fsLit "-ferror-spans")
314

315
316
opt_Ticky :: Bool
opt_Ticky                       = lookUp (fsLit "-ticky")
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

-- 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
333
-- are building - this might be a combination way, eg. profiling+threaded.
334
335
336
337
338
339
340
341
342

-- 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
343
  | WayEventLog
344
345
346
  | WayPar
  | WayGran
  | WayNDP
347
  | WayDyn
348
349
  deriving (Eq,Ord)

350
GLOBAL_VAR(v_Ways, [] ,[Way])
351

Ian Lynagh's avatar
Ian Lynagh committed
352
allowed_combination :: [WayName] -> Bool
353
354
355
356
357
358
359
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.

360
361
362
363
	-- dyn is allowed with everything
	_ `allowedWith` WayDyn  		= True
	WayDyn `allowedWith` _		        = True

364
365
366
367
368
	-- debug is allowed with everything
	_ `allowedWith` WayDebug		= True
	WayDebug `allowedWith` _		= True

	WayProf `allowedWith` WayNDP		= True
Simon Marlow's avatar
Simon Marlow committed
369
	WayThreaded `allowedWith` WayProf	= True
Simon Marlow's avatar
Simon Marlow committed
370
	WayThreaded `allowedWith` WayEventLog	= True
371
372
373
	_ `allowedWith` _ 			= False


374
375
376
377
378
379
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
380

381
  if not (allowed_combination (map wayName ways))
382
      then ghcError (CmdLineError $
383
384
      		    "combination not supported: "  ++
      		    foldr1 (\a b -> a ++ '/':b) 
385
386
387
      		    (map wayDesc ways))
      else
      	   return (concatMap wayOpts ways)
388

389
390
391
mkBuildTag :: [Way] -> String
mkBuildTag ways = concat (intersperse "_" (map wayTag ways))

Ian Lynagh's avatar
Ian Lynagh committed
392
lkupWay :: WayName -> Way
393
lkupWay w = 
394
   case listToMaybe (filter ((==) w . wayName) way_details) of
395
396
397
	Nothing -> error "findBuildTag"
	Just details -> details

Ian Lynagh's avatar
Ian Lynagh committed
398
isRTSWay :: WayName -> Bool
399
400
isRTSWay = wayRTSOnly . lkupWay 

401
data Way = Way {
402
  wayName    :: WayName,
403
404
  wayTag     :: String,
  wayRTSOnly :: Bool,
405
  wayDesc    :: String,
406
407
408
  wayOpts    :: [String]
  }

409
way_details :: [ Way ]
410
way_details =
411
  [ Way WayThreaded "thr" True "Threaded" [
412
#if defined(freebsd_TARGET_OS)
413
414
415
416
417
418
419
--	  "-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"
kili's avatar
kili committed
420
421
422
#elif defined(openbsd_TARGET_OS)
	  "-optc-pthread"
	, "-optl-pthread"
423
424
#elif defined(solaris2_TARGET_OS)
          "-optl-lrt"
425
#endif
426
427
428
	],

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

430
431
    Way WayDyn "dyn" False "Dynamic"
	[ "-DDYNAMIC"
432
433
434
435
436
437
	, "-optc-DDYNAMIC" 
#if defined(mingw32_TARGET_OS)
	-- On Windows, code that is to be linked into a dynamic library must be compiled
	--	with -fPIC. Labels not in the current package are assumed to be in a DLL 
	--	different from the current one.
	, "-fPIC"
kili's avatar
kili committed
438
439
440
441
#elif defined(openbsd_TARGET_OS)
	-- Without this, linking the shared libHSffi fails because
	-- it uses pthread mutexes.
	, "-optl-pthread"
442
443
#endif
	],
444

445
    Way WayProf "p" False "Profiling"
446
447
	[ "-fscc-profiling"
	, "-DPROFILING"
448
	, "-optc-DPROFILING" ],
449

450
    Way WayEventLog "l" True "RTS Event Logging"
451
452
	[ "-DTRACING"
	, "-optc-DTRACING" ],
Simon Marlow's avatar
Simon Marlow committed
453

454
    Way WayPar "mp" False "Parallel" 
455
456
457
458
459
460
461
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
462
        , "-optl-lgpvm3" ],
463
464

    -- at the moment we only change the RTS and could share compiler and libs!
465
    Way WayPar "mt" False "Parallel ticky profiling" 
466
467
468
469
470
471
472
473
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DPAR_TICKY"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
474
        , "-optl-lgpvm3" ],
475

476
    Way WayPar "md" False "Distributed" 
477
478
479
480
481
482
483
484
485
	[ "-fparallel"
	, "-D__PARALLEL_HASKELL__"
	, "-D__DISTRIBUTED_HASKELL__"
	, "-optc-DPAR"
	, "-optc-DDIST"
	, "-package concurrent"
        , "-optc-w"
        , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
        , "-optl-lpvm3"
486
        , "-optl-lgpvm3" ],
487

488
    Way WayGran "mg" False "GranSim"
489
490
491
	[ "-fgransim"
	, "-D__GRANSIM__"
	, "-optc-DGRAN"
492
	, "-package concurrent" ],
493

494
    Way WayNDP "ndp" False "Nested data parallelism"
495
	[ "-XParr"
496
	, "-fvectorise"]
497
  ]