DriverFlags.hs 29.3 KB
Newer Older
1
2
3
4
-----------------------------------------------------------------------------
--
-- Driver flags
--
5
-- (c) The University of Glasgow 2000-2003
6
7
8
--
-----------------------------------------------------------------------------

9
module DriverFlags ( 
10
11
12
	processDynamicFlags,
 	processStaticFlags,

13
	addCmdlineHCInclude,
14
	buildStaticHscOpts, 
15
16
17
	machdepCCOpts,

	processArgs, OptKind(..), -- for DriverMkDepend only
18
  ) where
19
20

#include "HsVersions.h"
21
#include "../includes/ghcconfig.h"
22

23
import MkIface		( showIface )
24
import DriverState
25
import DriverPhases
26
import DriverUtil
27
import SysTools
28
29
30
import CmdLineOpts
import Config
import Util
31
import Panic
32
import FastString	( mkFastString )
33

34
import EXCEPTION
35
import DATA_IOREF	( IORef, readIORef, writeIORef )
36

37
import System		( exitWith, ExitCode(..) )
38
import IO
39
import Maybe
40
import Monad
41
42
43
44
45
46
47
48
49
import Char

-----------------------------------------------------------------------------
-- Flags

-- Flag parsing is now done in stages:
--
--     * parse the initial list of flags and remove any flags understood
--	 by the driver only.  Determine whether we're in multi-compilation
50
--	 or single-compilation mode (done in Main.main).
51
52
53
54
55
56
57
58
59
60
61
62
63
64
--
--     * gather the list of "static" hsc flags, and assign them to the global
--	 static hsc flags variable.
--
--     * build the inital DynFlags from the remaining flags.
--
--     * complain if we've got any flags left over.
--
--     * for each source file: grab the OPTIONS, and build a new DynFlags
--       to pass to the compiler.

-----------------------------------------------------------------------------
-- Process command-line  

65
66
67
processStaticFlags :: [String] -> IO [String]
processStaticFlags opts = processArgs static_flags opts []

68
69
70
71
72
73
74
75
76
77
78
79
data OptKind
	= NoArg (IO ()) 		    -- flag with no argument
	| HasArg (String -> IO ())	    -- flag has an argument (maybe prefix)
	| SepArg (String -> IO ())	    -- flag has a separate argument
	| Prefix (String -> IO ())	    -- flag is a prefix only
	| OptPrefix (String -> IO ())       -- flag may be a prefix
	| AnySuffix (String -> IO ())       -- flag is a prefix, pass whole arg to fn
	| PassFlag  (String -> IO ())       -- flag with no arg, pass flag to fn
	| PrefixPred (String -> Bool) (String -> IO ())
	| AnySuffixPred (String -> Bool) (String -> IO ())

processArgs :: [(String,OptKind)] -> [String] -> [String]
80
	    -> IO [String]  -- returns spare args
81
processArgs _spec [] spare = return (reverse spare)
82

83
processArgs spec args@(('-':arg):args') spare = do
84
  case findArg spec arg of
85
86
    Just (rest,action) -> do args' <- processOneArg action rest args
			     processArgs spec args' spare
87
88
    Nothing	       -> processArgs spec args' (('-':arg):spare)

89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
processArgs spec (arg:args) spare = 
  processArgs spec args (arg:spare)

processOneArg :: OptKind -> String -> [String] -> IO [String]
processOneArg action rest (dash_arg@('-':arg):args) =
  case action of
	NoArg  io -> 
		if rest == ""
			then io >> return args
			else unknownFlagErr dash_arg

	HasArg fio -> 
		if rest /= "" 
			then fio rest >> return args
			else case args of
104
				[] -> missingArgErr dash_arg
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
				(arg1:args1) -> fio arg1 >> return args1

	SepArg fio -> 
		case args of
			[] -> unknownFlagErr dash_arg
			(arg1:args1) -> fio arg1 >> return args1

	Prefix fio -> 
		if rest /= ""
			then fio rest >> return args
			else unknownFlagErr dash_arg
	
	PrefixPred p fio -> 
		if rest /= ""
			then fio rest >> return args
			else unknownFlagErr dash_arg
	
	OptPrefix fio       -> fio rest >> return args

	AnySuffix fio       -> fio dash_arg >> return args

	AnySuffixPred p fio -> fio dash_arg >> return args

	PassFlag fio  -> 
		if rest /= ""
			then unknownFlagErr dash_arg
			else fio dash_arg >> return args

findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind)
findArg spec arg
135
  = case [ (remove_spaces rest, k) 
136
	 | (pat,k)   <- spec, 
137
	   Just rest <- [maybePrefixMatch pat arg],
138
	   arg_ok k rest arg ] 
139
140
141
142
143
144
145
    of
	[]      -> Nothing
	(one:_) -> Just one

arg_ok (NoArg _)            rest arg = null rest
arg_ok (HasArg _)           rest arg = True
arg_ok (SepArg _)           rest arg = null rest
sof's avatar
sof committed
146
147
arg_ok (Prefix _)	    rest arg = notNull rest
arg_ok (PrefixPred p _)     rest arg = notNull rest && p rest
148
149
arg_ok (OptPrefix _)	    rest arg = True
arg_ok (PassFlag _)         rest arg = null rest 
150
151
arg_ok (AnySuffix _)        rest arg = True
arg_ok (AnySuffixPred p _)  rest arg = p arg
152
153
154
155
156
157
158
159
160

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

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

static_flags = 
161
162
163
164
165
  [  ------- help / version ----------------------------------------------
     ( "?"    		 , NoArg showGhcUsage)
  ,  ( "-help"	 	 , NoArg showGhcUsage)
  ,  ( "-print-libdir"   , NoArg (do getTopDir >>= putStrLn
				     exitWith ExitSuccess))  
166
167
  ,  ( "V"	 	 , NoArg showVersion)
  ,  ( "-version"	 , NoArg showVersion)
168
  ,  ( "-numeric-version", NoArg (do putStrLn cProjectVersion
169
170
				     exitWith ExitSuccess))

171
172
173
174
      ------- interfaces ----------------------------------------------------
  ,  ( "-show-iface"     , HasArg (\f -> do showIface f
					    exitWith ExitSuccess))

175
      ------- verbosity ----------------------------------------------------
176
  ,  ( "n"              , NoArg setDryRun )
177

178
179
180
181
182
183
184
185
186
187
      ------- primary modes ------------------------------------------------
  ,  ( "M"		, PassFlag (setMode DoMkDependHS))
  ,  ( "E"		, PassFlag (setMode (StopBefore Hsc)))
  ,  ( "C"		, PassFlag (\f -> do setMode (StopBefore HCc) f
					     setLang HscC))
  ,  ( "S"		, PassFlag (setMode (StopBefore As)))
  ,  ( "c"		, PassFlag (setMode (StopBefore Ln)))
  ,  ( "-make"		, PassFlag (setMode DoMake))
  ,  ( "-interactive"	, PassFlag (setMode DoInteractive))
  ,  ( "-mk-dll"	, PassFlag (setMode DoMkDLL))
188
  ,  ( "e"              , HasArg   (\s -> setMode (DoEval s) "-e"))
189
190
191
192
193
194

	-- -fno-code says to stop after Hsc but don't generate any code.
  ,  ( "fno-code"	, PassFlag (\f -> do setMode (StopBefore HCc) f
				             setLang HscNothing
				             writeIORef v_Recomp False))

195
196
197
198
	------- GHCi -------------------------------------------------------
  ,  ( "ignore-dot-ghci", NoArg (writeIORef v_Read_DotGHCi False) )
  ,  ( "read-dot-ghci"  , NoArg (writeIORef v_Read_DotGHCi True) )

199
	------- recompilation checker --------------------------------------
200
201
  ,  ( "recomp"		, NoArg (writeIORef v_Recomp True) )
  ,  ( "no-recomp"  	, NoArg (writeIORef v_Recomp False) )
202
203

	------- ways --------------------------------------------------------
204
205
206
207
208
209
210
  ,  ( "prof"		, NoArg (addNoDups v_Ways	WayProf) )
  ,  ( "unreg"		, NoArg (addNoDups v_Ways	WayUnreg) )
  ,  ( "ticky"		, NoArg (addNoDups v_Ways	WayTicky) )
  ,  ( "parallel"	, NoArg (addNoDups v_Ways	WayPar) )
  ,  ( "gransim"	, NoArg (addNoDups v_Ways	WayGran) )
  ,  ( "smp"		, NoArg (addNoDups v_Ways	WaySMP) )
  ,  ( "debug"		, NoArg (addNoDups v_Ways	WayDebug) )
chak's avatar
chak committed
211
  ,  ( "ndp"		, NoArg (addNoDups v_Ways	WayNDP) )
212
  ,  ( "threaded"	, NoArg (addNoDups v_Ways	WayThreaded) )
213
214
 	-- ToDo: user ways

215
216
	------ RTS ways -----------------------------------------------------

217
	------ Debugging ----------------------------------------------------
218
219
220
  ,  ( "dppr-noprags",     PassFlag (add v_Opt_C) )
  ,  ( "dppr-debug",       PassFlag (add v_Opt_C) )
  ,  ( "dppr-user-length", AnySuffix (add v_Opt_C) )
221
222
223
      -- rest of the debugging flags are dynamic

	--------- Profiling --------------------------------------------------
224
225
226
227
  ,  ( "auto-dicts"	, NoArg (add v_Opt_C "-fauto-sccs-on-dicts") )
  ,  ( "auto-all"	, NoArg (add v_Opt_C "-fauto-sccs-on-all-toplevs") )
  ,  ( "auto"		, NoArg (add v_Opt_C "-fauto-sccs-on-exported-toplevs") )
  ,  ( "caf-all"	, NoArg (add v_Opt_C "-fauto-sccs-on-individual-cafs") )
228
229
         -- "ignore-sccs"  doesn't work  (ToDo)

230
231
232
233
  ,  ( "no-auto-dicts"	, NoArg (add v_Anti_opt_C "-fauto-sccs-on-dicts") )
  ,  ( "no-auto-all"	, NoArg (add v_Anti_opt_C "-fauto-sccs-on-all-toplevs") )
  ,  ( "no-auto"	, NoArg (add v_Anti_opt_C "-fauto-sccs-on-exported-toplevs") )
  ,  ( "no-caf-all"	, NoArg (add v_Anti_opt_C "-fauto-sccs-on-individual-cafs") )
234
235
236

	------- Miscellaneous -----------------------------------------------
  ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
rrt's avatar
rrt committed
237
  ,  ( "no-hs-main"     , NoArg (writeIORef v_NoHsMain True) )
238
  ,  ( "main-is"   	, SepArg setMainIs )
239
240

	------- Output Redirection ------------------------------------------
241
242
  ,  ( "odir"		, HasArg (writeIORef v_Output_dir  . Just) )
  ,  ( "o"		, SepArg (writeIORef v_Output_file . Just) )
243
  ,  ( "osuf"		, HasArg (writeIORef v_Object_suf) )
244
  ,  ( "hcsuf"		, HasArg (writeIORef v_HC_suf      . Just) )
245
  ,  ( "hisuf"		, HasArg (writeIORef v_Hi_suf) )
246
  ,  ( "hidir"		, HasArg (writeIORef v_Hi_dir . Just) )
247
  ,  ( "buildtag"	, HasArg (writeIORef v_Build_tag) )
248
  ,  ( "tmpdir"		, HasArg setTmpDir)
249
  ,  ( "ohi"		, HasArg (writeIORef v_Output_hi   . Just) )
250
251
	-- -odump?

252
253
254
  ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef v_Keep_hc_files True) )
  ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef v_Keep_s_files  True) )
  ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef v_Keep_raw_s_files  True) )
sof's avatar
sof committed
255
#ifdef ILX
rrt's avatar
rrt committed
256
  ,  ( "keep-il-file"   , AnySuffix (\_ -> writeIORef v_Keep_il_files True) )
sof's avatar
sof committed
257
258
  ,  ( "keep-ilx-file"  , AnySuffix (\_ -> writeIORef v_Keep_ilx_files True) )
#endif
259
  ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef v_Keep_tmp_files True) )
260
261

  ,  ( "split-objs"	, NoArg (if can_split
262
263
				    then do writeIORef v_Split_object_files True
					    add v_Opt_C "-fglobalise-toplev-names"
264
				    else hPutStrLn stderr
265
					    "warning: don't know how to split object files on this architecture"
266
				) )
267

268
	------- Include/Import Paths ----------------------------------------
269
  ,  ( "I" 		, Prefix    (addToDirList v_Include_paths) )
270
271

	------- Libraries ---------------------------------------------------
272
  ,  ( "L"		, Prefix (addToDirList v_Library_paths) )
273
  ,  ( "l"		, AnySuffix (\s -> add v_Opt_l s >> add v_Opt_dll s) )
274

275
276
277
278
279
280
#ifdef darwin_TARGET_OS
	------- Frameworks --------------------------------------------------
        -- -framework-path should really be -F ...
  ,  ( "framework-path" , HasArg (addToDirList v_Framework_paths) )
  ,  ( "framework"	, HasArg (add v_Cmdline_frameworks) )
#endif
281
        ------- Specific phases  --------------------------------------------
282
283
  ,  ( "pgmL"           , HasArg setPgmL )
  ,  ( "pgmP"           , HasArg setPgmP )
284
285
286
287
288
289
  ,  ( "pgmF"           , HasArg setPgmF )
  ,  ( "pgmc"           , HasArg setPgmc )
  ,  ( "pgmm"           , HasArg setPgmm )
  ,  ( "pgms"           , HasArg setPgms )
  ,  ( "pgma"           , HasArg setPgma )
  ,  ( "pgml"           , HasArg setPgml )
290
  ,  ( "pgmdll"		, HasArg setPgmDLL )
291
292
293
294
#ifdef ILX
  ,  ( "pgmI"           , HasArg setPgmI )
  ,  ( "pgmi"           , HasArg setPgmi )
#endif
295
296
297
298

  ,  ( "optdep"		, HasArg (add v_Opt_dep) )
  ,  ( "optl"		, HasArg (add v_Opt_l) )
  ,  ( "optdll"		, HasArg (add v_Opt_dll) )
299
300

	----- Linker --------------------------------------------------------
301
  ,  ( "no-link"	, NoArg (writeIORef v_NoLink True) )
302
  ,  ( "static" 	, NoArg (writeIORef v_Static True) )
rrt's avatar
rrt committed
303
  ,  ( "dynamic"        , NoArg (writeIORef v_Static False) )
rrt's avatar
rrt committed
304
  ,  ( "rdynamic"       , NoArg (return ()) ) -- ignored for compat w/ gcc
305

306
307
	----- RTS opts ------------------------------------------------------
  ,  ( "H"                 , HasArg (setHeapSize . fromIntegral . decodeSize) )
308
  ,  ( "Rghc-timing"	   , NoArg  (enableTimingStats) )
309

310
        ------ Compiler flags -----------------------------------------------
311
  ,  ( "fno-asm-mangling"  , NoArg (writeIORef v_Do_asm_mangling False) )
312

313
314
  ,  ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
				       add v_Opt_C "-fexcess-precision"))
315
316
317

	-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
  ,  ( "fno-",			PrefixPred (\s -> isStaticHscFlag ("f"++s))
318
				    (\s -> add v_Anti_opt_C ("-f"++s)) )
319
320

	-- Pass all remaining "-f<blah>" options to hsc
321
  ,  ( "f", 			AnySuffixPred (isStaticHscFlag) (add v_Opt_C) )
322
323
324
325
  ]

dynamic_flags = [

326
     ( "cpp",		NoArg  (updDynFlags (\s -> s{ cppFlag = True })) )
sof's avatar
sof committed
327
  ,  ( "F",             NoArg  (updDynFlags (\s -> s{ ppFlag = True })) )
328
329
  ,  ( "#include",	HasArg (addCmdlineHCInclude) )

330
331
  ,  ( "v",		OptPrefix (setVerbosity) )

332
333
  ,  ( "optL",		HasArg (addOpt_L) )
  ,  ( "optP",		HasArg (addOpt_P) )
sof's avatar
sof committed
334
  ,  ( "optF",          HasArg (addOpt_F) )
335
336
337
  ,  ( "optc",		HasArg (addOpt_c) )
  ,  ( "optm",		HasArg (addOpt_m) )
  ,  ( "opta",		HasArg (addOpt_a) )
rrt's avatar
rrt committed
338
339
340
341
#ifdef ILX
  ,  ( "optI",		HasArg (addOpt_I) )
  ,  ( "opti",		HasArg (addOpt_i) )
#endif
342

343
344
345
346
347
348
349
350
351
        ------- Packages ----------------------------------------------------
  ,  ( "package-conf"   , HasArg extraPkgConf_ )
  ,  ( "no-user-package-conf", NoArg noUserPkgConf_ )
  ,  ( "package-name"   , HasArg ignorePackage ) -- for compatibility
  ,  ( "package"        , HasArg exposePackage )
  ,  ( "hide-package"   , HasArg hidePackage )
  ,  ( "ignore-package" , HasArg ignorePackage )
  ,  ( "syslib"         , HasArg exposePackage )  -- for compatibility

352
	------ HsCpp opts ---------------------------------------------------
353
354
  ,  ( "D",		AnySuffix addOpt_P )
  ,  ( "U",		AnySuffix addOpt_P )
355

356
357
358
        ------- Paths & stuff -----------------------------------------------
  ,  ( "i"		, OptPrefix addImportPath )

359
	------ Debugging ----------------------------------------------------
360
  ,  ( "dstg-stats",	NoArg (writeIORef v_StgStats True) )
361

362
  ,  ( "ddump-cmm",         	 NoArg (setDynFlag Opt_D_dump_cmm) )
363
364
365
366
367
368
369
370
371
372
373
374
375
  ,  ( "ddump-asm",          	 NoArg (setDynFlag Opt_D_dump_asm) )
  ,  ( "ddump-cpranal",      	 NoArg (setDynFlag Opt_D_dump_cpranal) )
  ,  ( "ddump-deriv",        	 NoArg (setDynFlag Opt_D_dump_deriv) )
  ,  ( "ddump-ds",           	 NoArg (setDynFlag Opt_D_dump_ds) )
  ,  ( "ddump-flatC",        	 NoArg (setDynFlag Opt_D_dump_flatC) )
  ,  ( "ddump-foreign",      	 NoArg (setDynFlag Opt_D_dump_foreign) )
  ,  ( "ddump-inlinings",    	 NoArg (setDynFlag Opt_D_dump_inlinings) )
  ,  ( "ddump-occur-anal",   	 NoArg (setDynFlag Opt_D_dump_occur_anal) )
  ,  ( "ddump-parsed",       	 NoArg (setDynFlag Opt_D_dump_parsed) )
  ,  ( "ddump-rn",           	 NoArg (setDynFlag Opt_D_dump_rn) )
  ,  ( "ddump-simpl",        	 NoArg (setDynFlag Opt_D_dump_simpl) )
  ,  ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) )
  ,  ( "ddump-spec",         	 NoArg (setDynFlag Opt_D_dump_spec) )
376
  ,  ( "ddump-prep",          	 NoArg (setDynFlag Opt_D_dump_prep) )
377
378
379
380
381
382
383
  ,  ( "ddump-stg",          	 NoArg (setDynFlag Opt_D_dump_stg) )
  ,  ( "ddump-stranal",      	 NoArg (setDynFlag Opt_D_dump_stranal) )
  ,  ( "ddump-tc",           	 NoArg (setDynFlag Opt_D_dump_tc) )
  ,  ( "ddump-types",        	 NoArg (setDynFlag Opt_D_dump_types) )
  ,  ( "ddump-rules",        	 NoArg (setDynFlag Opt_D_dump_rules) )
  ,  ( "ddump-cse",          	 NoArg (setDynFlag Opt_D_dump_cse) )
  ,  ( "ddump-worker-wrapper",   NoArg (setDynFlag Opt_D_dump_worker_wrapper) )
384
  ,  ( "dshow-passes",           NoArg (setVerbosity "2") )
385
  ,  ( "ddump-rn-trace",         NoArg (setDynFlag Opt_D_dump_rn_trace) )
386
  ,  ( "ddump-if-trace",         NoArg (setDynFlag Opt_D_dump_if_trace) )
387
  ,  ( "ddump-tc-trace",         NoArg (setDynFlag Opt_D_dump_tc_trace) )
388
  ,  ( "ddump-splices",          NoArg (setDynFlag Opt_D_dump_splices) )
389
  ,  ( "ddump-rn-stats",         NoArg (setDynFlag Opt_D_dump_rn_stats) )
390
  ,  ( "ddump-opt-cmm",          NoArg (setDynFlag Opt_D_dump_opt_cmm) )
391
  ,  ( "ddump-simpl-stats",      NoArg (setDynFlag Opt_D_dump_simpl_stats) )
392
  ,  ( "ddump-bcos",             NoArg (setDynFlag Opt_D_dump_BCOs) )
393
394
395
396
  ,  ( "dsource-stats",          NoArg (setDynFlag Opt_D_source_stats) )
  ,  ( "dverbose-core2core",     NoArg (setDynFlag Opt_D_verbose_core2core) )
  ,  ( "dverbose-stg2stg",       NoArg (setDynFlag Opt_D_verbose_stg2stg) )
  ,  ( "ddump-hi-diffs",         NoArg (setDynFlag Opt_D_dump_hi_diffs) )
397
  ,  ( "ddump-hi",               NoArg (setDynFlag Opt_D_dump_hi) )
398
  ,  ( "ddump-minimal-imports",  NoArg (setDynFlag Opt_D_dump_minimal_imports) )
chak's avatar
chak committed
399
  ,  ( "ddump-vect",         	 NoArg (setDynFlag Opt_D_dump_vect) )
400
401
  ,  ( "dcore-lint",       	 NoArg (setDynFlag Opt_DoCoreLinting) )
  ,  ( "dstg-lint",        	 NoArg (setDynFlag Opt_DoStgLinting) )
402
  ,  ( "dcmm-lint",		 NoArg (setDynFlag Opt_DoCmmLinting) )
403
404
405

	------ Machine dependant (-m<blah>) stuff ---------------------------

406
407
408
  ,  ( "monly-2-regs", 	NoArg (updDynFlags (\s -> s{stolen_x86_regs = 2}) ))
  ,  ( "monly-3-regs", 	NoArg (updDynFlags (\s -> s{stolen_x86_regs = 3}) ))
  ,  ( "monly-4-regs", 	NoArg (updDynFlags (\s -> s{stolen_x86_regs = 4}) ))
409

410
411
	------ Warning opts -------------------------------------------------
  ,  ( "W"		, NoArg (mapM_ setDynFlag   minusWOpts)    )
412
  ,  ( "Werror"		, NoArg (setDynFlag   	    Opt_WarnIsError) )
413
414
415
416
  ,  ( "Wall"		, NoArg (mapM_ setDynFlag   minusWallOpts) )
  ,  ( "Wnot"		, NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */
  ,  ( "w"		, NoArg (mapM_ unSetDynFlag minusWallOpts) )

417
418
419
420
421
422
423
424
425
426
427
428
429
	------ Optimisation flags ------------------------------------------
  ,  ( "O"		   , NoArg (setOptLevel 1))
  ,  ( "Onot"		   , NoArg (setOptLevel 0))
  ,  ( "O"		   , PrefixPred (all isDigit) (setOptLevel . read))

  ,  ( "fmax-simplifier-iterations", 
		PrefixPred (all isDigit) 
		  (\n -> updDynFlags (\dfs -> 
			dfs{ maxSimplIterations = read n })) )

  ,  ( "frule-check", 
		SepArg (\s -> updDynFlags (\dfs -> dfs{ ruleCheck = Just s })))

430
431
        ------ Compiler flags -----------------------------------------------

432
433
434
  ,  ( "fasm",		AnySuffix (\_ -> setLang HscAsm) )
  ,  ( "fvia-c",	NoArg (setLang HscC) )
  ,  ( "fvia-C",	NoArg (setLang HscC) )
435
  ,  ( "filx",		NoArg (setLang HscILX) )
436

437
438
439
  ,  ( "fglasgow-exts",    NoArg (mapM_ setDynFlag   glasgowExtsFlags) )
  ,  ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )

440
441
	-- the rest of the -f* and -fno-* flags
  ,  ( "fno-", 		PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
442
  ,  ( "f",		PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
443
 ]
444

445
446
447
448
449
450
-- these -f<blah> flags can all be reversed with -fno-<blah>

fFlags = [
  ( "warn-duplicate-exports",    	Opt_WarnDuplicateExports ),
  ( "warn-hi-shadowing",         	Opt_WarnHiShadows ),
  ( "warn-incomplete-patterns",  	Opt_WarnIncompletePatterns ),
451
  ( "warn-incomplete-record-updates",  	Opt_WarnIncompletePatternsRecUpd ),
452
453
454
455
456
457
458
459
460
461
462
  ( "warn-missing-fields",       	Opt_WarnMissingFields ),
  ( "warn-missing-methods",      	Opt_WarnMissingMethods ),
  ( "warn-missing-signatures",   	Opt_WarnMissingSigs ),
  ( "warn-name-shadowing",       	Opt_WarnNameShadowing ),
  ( "warn-overlapping-patterns", 	Opt_WarnOverlappingPatterns ),
  ( "warn-simple-patterns",      	Opt_WarnSimplePatterns ),
  ( "warn-type-defaults",        	Opt_WarnTypeDefaults ),
  ( "warn-unused-binds",         	Opt_WarnUnusedBinds ),
  ( "warn-unused-imports",       	Opt_WarnUnusedImports ),
  ( "warn-unused-matches",       	Opt_WarnUnusedMatches ),
  ( "warn-deprecations",         	Opt_WarnDeprecations ),
463
  ( "warn-orphans",	         	Opt_WarnOrphans ),
chak's avatar
chak committed
464
465
  ( "fi",				Opt_FFI ),  -- support `-ffi'...
  ( "ffi",				Opt_FFI ),  -- ...and also `-fffi'
466
  ( "arrows",				Opt_Arrows ), -- arrow syntax
chak's avatar
chak committed
467
  ( "parr",				Opt_PArr ),
468
  ( "th",				Opt_TH ),
469
  ( "implicit-prelude",  		Opt_ImplicitPrelude ),
470
  ( "scoped-type-variables",  		Opt_ScopedTypeVariables ),
471
  ( "monomorphism-restriction",		Opt_MonomorphismRestriction ),
472
  ( "implicit-params",			Opt_ImplicitParams ),
473
474
  ( "allow-overlapping-instances", 	Opt_AllowOverlappingInstances ),
  ( "allow-undecidable-instances", 	Opt_AllowUndecidableInstances ),
475
  ( "allow-incoherent-instances", 	Opt_AllowIncoherentInstances ),
476
477
  ( "generics",  			Opt_Generics ),
  ( "strictness",			Opt_Strictness ),
478
  ( "full-laziness",			Opt_FullLaziness ),
479
480
481
482
483
484
485
486
  ( "cse",				Opt_CSE ),
  ( "ignore-interface-pragmas",		Opt_IgnoreInterfacePragmas ),
  ( "omit-interface-pragmas",		Opt_OmitInterfacePragmas ),
  ( "do-lambda-eta-expansion",		Opt_DoLambdaEtaExpansion ),
  ( "ignore-asserts",			Opt_IgnoreAsserts ),
  ( "do-eta-reduction",			Opt_DoEtaReduction ),
  ( "case-merge",			Opt_CaseMerge ),
  ( "unbox-strict-fields",		Opt_UnboxStrictFields )
487
  ]
488

489
glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams, Opt_ScopedTypeVariables ]
490

491
492
isFFlag f = f `elem` (map fst fFlags)
getFFlag f = fromJust (lookup f fFlags)
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
539
540
541
542
543
544
545
-- -----------------------------------------------------------------------------
-- Parsing the dynamic flags.

-- we use a temporary global variable, for convenience

GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)

processDynamicFlags :: [String] -> DynFlags -> IO (DynFlags,[String])
processDynamicFlags args dflags = do
  writeIORef v_DynFlags dflags
  spare <- processArgs dynamic_flags args []
  dflags <- readIORef v_DynFlags
  return (dflags,spare)

updDynFlags :: (DynFlags -> DynFlags) -> IO ()
updDynFlags f = do dfs <- readIORef v_DynFlags
		   writeIORef v_DynFlags (f dfs)

setDynFlag, unSetDynFlag :: DynFlag -> IO ()
setDynFlag f   = updDynFlags (\dfs -> dopt_set dfs f)
unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f)

addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s})
addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s})
addOpt_F a = updDynFlags (\s -> s{opt_F = a : opt_F s})
addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s})
addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s})
addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s})
#ifdef ILX
addOpt_I a = updDynFlags (\s -> s{opt_I = a : opt_I s})
addOpt_i a = updDynFlags (\s -> s{opt_i = a : opt_i s})
#endif

setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 })
setVerbosity n 
  | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n })
  | otherwise     = throwDyn (UsageError "can't parse verbosity flag (-v<n>)")

addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes =  a : cmdlineHcIncludes s})

extraPkgConf_  p = updDynFlags (\s -> s{ extraPkgConfs = p : extraPkgConfs s })
noUserPkgConf_   = updDynFlags (\s -> s{ readUserPkgConf = False })

exposePackage p = 
  updDynFlags (\s -> s{ packageFlags = ExposePackage p : packageFlags s })
hidePackage p = 
  updDynFlags (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p = 
  updDynFlags (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })

-- -i on its own deletes the import paths
addImportPath "" = updDynFlags (\s -> s{importPaths = []})
546
547
548
addImportPath p  = do
  paths <- splitPathList p
  updDynFlags (\s -> s{importPaths = importPaths s ++ paths})
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564

-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags 
-- (-fvia-C, -fasm, -filx respectively).
setLang l = updDynFlags (\dfs -> case hscLang dfs of
					HscC   -> dfs{ hscLang = l }
					HscAsm -> dfs{ hscLang = l }
					HscILX -> dfs{ hscLang = l }
					_      -> dfs)

setOptLevel :: Int -> IO ()
setOptLevel n 
   = do dflags <- readIORef v_DynFlags
	if hscLang dflags == HscInterpreted && n > 0
	  then putStr "warning: -O conflicts with --interactive; -O ignored.\n"
	  else writeIORef v_DynFlags (updOptLevel n dflags)

565
566
567
568
569
570
571
572
573
-----------------------------------------------------------------------------
-- 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)
574
  | otherwise            = throwDyn (CmdLineError ("can't decode size: " ++ str))
575
576
577
578
  where (m, c) = span pred str
        n      = read m  :: Double
	pred c = isDigit c || c == '.'

579
580
581
582

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

583
584
585
586
#if __GLASGOW_HASKELL__ >= 504
foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
#else
587
588
foreign import "setHeapSize"       unsafe setHeapSize       :: Int -> IO ()
foreign import "enableTimingStats" unsafe enableTimingStats :: IO ()
589
#endif
590

591
592
593
-----------------------------------------------------------------------------
-- Build the Hsc static command line opts

594
595
buildStaticHscOpts :: IO [String]
buildStaticHscOpts = do
596

597
  opt_C_ <- getStaticOpts v_Opt_C	-- misc hsc opts from the command line
598
599
600

	-- take into account -fno-* flags by removing the equivalent -f*
	-- flag from our list.
601
  anti_flags <- getStaticOpts v_Anti_opt_C
602
  let basic_opts = opt_C_
603
604
      filtered_opts = filter (`notElem` anti_flags) basic_opts

605
606
  static <- (do s <- readIORef v_Static; if s then return "-static" 
					      else return "")
607

608
  return ( static : filtered_opts )
609

610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
setMainIs :: String -> IO ()
setMainIs arg
  | not (null main_mod)		-- The arg looked like "Foo.baz"
  = do { writeIORef v_MainFunIs (Just main_fn) ;
	 writeIORef v_MainModIs (Just main_mod) }

  | isUpper (head main_fn)	-- The arg looked like "Foo"
  = writeIORef v_MainModIs (Just main_fn)
  
  | otherwise			-- The arg looked like "baz"
  = writeIORef v_MainFunIs (Just main_fn)
  where
    (main_mod, main_fn) = split_longest_prefix arg (== '.')
  

625
626
627
628
629
630
631
-----------------------------------------------------------------------------
-- Via-C compilation stuff

-- flags returned are: ( all C compilations
--		       , registerised HC compilations
--		       )

632
machdepCCOpts dflags
633
   | prefixMatch "alpha"   cTARGETPLATFORM  
634
	= return ( ["-w", "-mieee"
ken's avatar
ken committed
635
636
637
638
#ifdef HAVE_THREADED_RTS_SUPPORT
		    , "-D_REENTRANT"
#endif
		   ], [] )
ken's avatar
ken committed
639
640
641
	-- For now, to suppress the gcc warning "call-clobbered
	-- register used for global register variable", we simply
	-- disable all warnings altogether using the -w flag. Oh well.
642
643
644
645

   | prefixMatch "hppa"    cTARGETPLATFORM  
        -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
        -- (very nice, but too bad the HP /usr/include files don't agree.)
646
	= return ( ["-D_HPUX_SOURCE"], [] )
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664

   | prefixMatch "m68k"    cTARGETPLATFORM
      -- -fno-defer-pop : for the .hc files, we want all the pushing/
      --    popping of args to routines to be explicit; if we let things
      --    be deferred 'til after an STGJUMP, imminent death is certain!
      --
      -- -fomit-frame-pointer : *don't*
      --     It's better to have a6 completely tied up being a frame pointer
      --     rather than let GCC pick random things to do with it.
      --     (If we want to steal a6, then we would try to do things
      --     as on iX86, where we *do* steal the frame pointer [%ebp].)
	= return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )

   | prefixMatch "i386"    cTARGETPLATFORM  
      -- -fno-defer-pop : basically the same game as for m68k
      --
      -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
      --   the fp (%ebp) for our register maps.
665
	= do let n_regs = stolen_x86_regs dflags
666
	     sta    <- readIORef v_Static
sof's avatar
sof committed
667
668
669
	     return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else ""
--                    , if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" 
		      ],
670
671
672
673
674
675
676
677
678
		      [ "-fno-defer-pop",
#ifdef HAVE_GCC_MNO_OMIT_LFPTR
			-- Some gccs are configured with
			-- -momit-leaf-frame-pointer on by default, and it
			-- apparently takes precedence over 
			-- -fomit-frame-pointer, so we disable it first here.
			"-mno-omit-leaf-frame-pointer",
#endif
			"-fomit-frame-pointer",
679
680
681
682
			-- we want -fno-builtin, because when gcc inlines
			-- built-in functions like memcpy() it tends to
			-- run out of registers, requiring -monly-n-regs
			"-fno-builtin",
683
684
685
	                "-DSTOLEN_X86_REGS="++show n_regs ]
		    )

686
687
688
   | prefixMatch "ia64"    cTARGETPLATFORM  
	= return ( [], ["-fomit-frame-pointer", "-G0"] )

689
690
691
   | prefixMatch "x86_64"  cTARGETPLATFORM
	= return ( [], ["-fomit-frame-pointer"] )

692
   | prefixMatch "mips"    cTARGETPLATFORM
ken's avatar
ken committed
693
	= return ( ["-static"], [] )
694

695
696
   | prefixMatch "sparc"    cTARGETPLATFORM
	= return ( [], ["-w"] )
ken's avatar
ken committed
697
698
699
	-- For now, to suppress the gcc warning "call-clobbered
	-- register used for global register variable", we simply
	-- disable all warnings altogether using the -w flag. Oh well.
700

sebc's avatar
sebc committed
701
   | prefixMatch "powerpc-apple-darwin" cTARGETPLATFORM
702
703
704
705
706
      -- -no-cpp-precomp:
      --     Disable Apple's precompiling preprocessor. It's a great thing
      --     for "normal" programs, but it doesn't support register variable
      --     declarations.
      -- -mdynamic-no-pic:
707
708
709
710
711
712
713
714
715
716
717
718
719
720
      --     Turn off PIC code generation to save space and time.
      -- -fno-common:
      --     Don't generate "common" symbols - these are unwanted
      --     in dynamic libraries.

        = if opt_PIC
            then return ( ["-no-cpp-precomp", "-fno-common"],
                          ["-fno-common"] )
            else return ( ["-no-cpp-precomp", "-mdynamic-no-pic"],
                          ["-mdynamic-no-pic"] )

   | prefixMatch "powerpc" cTARGETPLATFORM && opt_PIC
        = return ( ["-fPIC"], ["-fPIC"] )
  
721
722
   | otherwise
	= return ( [], [] )
723

724
725
-----------------------------------------------------------------------------
-- local utils
726

727
728
729
-- -----------------------------------------------------------------------------
-- Version and usage messages

730
731
732
733
showVersion :: IO ()
showVersion = do
  putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
  exitWith ExitSuccess
734
735
736
737
738
739
740
741
742
743
744
745
746
747

showGhcUsage = do 
  (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths
  mode <- readIORef v_GhcMode
  let usage_path 
	| mode == DoInteractive  = ghci_usage_path
	| otherwise		 = ghc_usage_path
  usage <- readFile usage_path
  dump usage
  exitWith ExitSuccess
  where
     dump ""	      = return ()
     dump ('$':'$':s) = hPutStr stderr progName >> dump s
     dump (c:s)	      = hPutChar stderr c >> dump s