DriverFlags.hs 21.1 KB
Newer Older
1 2
{-# OPTIONS -#include "hschooks.h" #-}

3
-----------------------------------------------------------------------------
4
-- $Id: DriverFlags.hs,v 1.58 2001/06/14 12:50:06 simonpj Exp $
5 6 7 8 9 10 11
--
-- Driver flags
--
-- (c) Simon Marlow 2000
--
-----------------------------------------------------------------------------

12 13
module DriverFlags ( 
	processArgs, OptKind(..), static_flags, dynamic_flags, 
14
	getDynFlags, dynFlag, 
15 16 17 18
	getOpts, getVerbFlag, addCmdlineHCInclude,
	buildStaticHscOpts, 
	machdepCCOpts
  ) where
19 20 21 22 23

#include "HsVersions.h"

import DriverState
import DriverUtil
24
import SysTools		( setTmpDir, setPgm, setDryRun, showGhcUsage )
25 26 27
import CmdLineOpts
import Config
import Util
28 29
import Panic

30 31
import Exception
import IOExts
32
import System		( exitWith, ExitCode(..) )
33

34
import IO
35
import Maybe
36
import Monad
37 38 39 40 41 42 43 44 45
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
46
--	 or single-compilation mode (done in Main.main).
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
--
--     * 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  

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]
73
	    -> IO [String]  -- returns spare args
74
processArgs _spec [] spare = return (reverse spare)
75

76
processArgs spec args@(('-':arg):args') spare = do
77
  case findArg spec arg of
78 79 80 81
    Just (rest,action) ->  do args' <- processOneArg action rest args
			      processArgs spec args' spare
    Nothing	       -> processArgs spec args' (('-':arg):spare)

82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
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
				[] -> unknownFlagErr dash_arg
				(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
128
  = case [ (remove_spaces rest, k) 
129 130
	 | (pat,k)   <- spec, 
	   Just rest <- [my_prefix_match pat arg],
131
	   arg_ok k rest arg ] 
132 133 134 135 136 137 138 139 140 141 142
    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
arg_ok (Prefix _)	    rest arg = not (null rest)
arg_ok (PrefixPred p _)     rest arg = not (null rest) && p rest
arg_ok (OptPrefix _)	    rest arg = True
arg_ok (PassFlag _)         rest arg = null rest 
143 144
arg_ok (AnySuffix _)        rest arg = True
arg_ok (AnySuffixPred p _)  rest arg = p arg
145 146 147 148 149 150 151 152 153 154

-----------------------------------------------------------------------------
-- 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 = 
  [  ------- help -------------------------------------------------------
155 156
     ( "?"    		, NoArg showGhcUsage)
  ,  ( "-help"		, NoArg showGhcUsage)
157 158 159 160
  

      ------- version ----------------------------------------------------
  ,  ( "-version"	 , NoArg (do hPutStrLn stdout (cProjectName
161
				      ++ ", version " ++ cProjectVersion)
162
				     exitWith ExitSuccess))
163
  ,  ( "-numeric-version", NoArg (do hPutStrLn stdout cProjectVersion
164 165 166
				     exitWith ExitSuccess))

      ------- verbosity ----------------------------------------------------
167
  ,  ( "n"              , NoArg setDryRun )
168 169

	------- recompilation checker --------------------------------------
170 171
  ,  ( "recomp"		, NoArg (writeIORef v_Recomp True) )
  ,  ( "no-recomp"  	, NoArg (writeIORef v_Recomp False) )
172 173

	------- ways --------------------------------------------------------
174 175 176 177 178 179 180
  ,  ( "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) )
181 182 183
 	-- ToDo: user ways

	------ Debugging ----------------------------------------------------
184 185 186
  ,  ( "dppr-noprags",     PassFlag (add v_Opt_C) )
  ,  ( "dppr-debug",       PassFlag (add v_Opt_C) )
  ,  ( "dppr-user-length", AnySuffix (add v_Opt_C) )
187 188 189
      -- rest of the debugging flags are dynamic

	--------- Profiling --------------------------------------------------
190 191 192 193
  ,  ( "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") )
194 195
         -- "ignore-sccs"  doesn't work  (ToDo)

196 197 198 199
  ,  ( "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") )
200 201 202

	------- Miscellaneous -----------------------------------------------
  ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
rrt's avatar
rrt committed
203
  ,  ( "no-hs-main"     , NoArg (writeIORef v_NoHsMain True) )
204 205

	------- Output Redirection ------------------------------------------
206 207
  ,  ( "odir"		, HasArg (writeIORef v_Output_dir  . Just) )
  ,  ( "o"		, SepArg (writeIORef v_Output_file . Just) )
208
  ,  ( "osuf"		, HasArg (writeIORef v_Object_suf  . Just) )
209
  ,  ( "hcsuf"		, HasArg (writeIORef v_HC_suf      . Just) )
210
  ,  ( "hisuf"		, HasArg (writeIORef v_Hi_suf) )
211
  ,  ( "hidir"		, HasArg (writeIORef v_Hi_dir . Just) )
212
  ,  ( "buildtag"	, HasArg (writeIORef v_Build_tag) )
213
  ,  ( "tmpdir"		, HasArg setTmpDir)
214
  ,  ( "ohi"		, HasArg (writeIORef v_Output_hi   . Just) )
215 216
	-- -odump?

217 218 219 220
  ,  ( "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) )
  ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef v_Keep_tmp_files True) )
221 222

  ,  ( "split-objs"	, NoArg (if can_split
223 224
				    then do writeIORef v_Split_object_files True
					    add v_Opt_C "-fglobalise-toplev-names"
225 226 227 228
				    else hPutStrLn stderr
					    "warning: don't know how to  split \
					    \object files on this architecture"
				) )
229

230
	------- Include/Import Paths ----------------------------------------
231 232
  ,  ( "i"		, OptPrefix (addToDirList v_Import_paths) )
  ,  ( "I" 		, Prefix    (addToDirList v_Include_paths) )
233 234

	------- Libraries ---------------------------------------------------
235 236
  ,  ( "L"		, Prefix (addToDirList v_Library_paths) )
  ,  ( "l"		, Prefix (add v_Cmdline_libraries) )
237 238

        ------- Packages ----------------------------------------------------
239
  ,  ( "package-name"   , HasArg (\s -> add v_Opt_C ("-inpackage="++s)) )
240 241 242 243 244

  ,  ( "package"        , HasArg (addPackage) )
  ,  ( "syslib"         , HasArg (addPackage) )	-- for compatibility w/ old vsns

        ------- Specific phases  --------------------------------------------
245
  ,  ( "pgm"           , HasArg setPgm )
246 247 248 249

  ,  ( "optdep"		, HasArg (add v_Opt_dep) )
  ,  ( "optl"		, HasArg (add v_Opt_l) )
  ,  ( "optdll"		, HasArg (add v_Opt_dll) )
250 251

	----- Linker --------------------------------------------------------
252
  ,  ( "static" 	, NoArg (writeIORef v_Static True) )
rrt's avatar
rrt committed
253
  ,  ( "dynamic"        , NoArg (writeIORef v_Static False) )
rrt's avatar
rrt committed
254
  ,  ( "rdynamic"       , NoArg (return ()) ) -- ignored for compat w/ gcc
255

256 257
	----- RTS opts ------------------------------------------------------
  ,  ( "H"                 , HasArg (setHeapSize . fromIntegral . decodeSize) )
258
  ,  ( "Rghc-timing"	   , NoArg  (enableTimingStats) )
259

260
        ------ Compiler flags -----------------------------------------------
261
  ,  ( "O2-for-C"	   , NoArg (writeIORef v_minus_o2_for_C True) )
262 263
  ,  ( "O"		   , OptPrefix (setOptLevel) )

264
  ,  ( "fno-asm-mangling"  , NoArg (writeIORef v_Do_asm_mangling False) )
265 266

  ,  ( "fmax-simplifier-iterations", 
267
		Prefix (writeIORef v_MaxSimplifierIterations . read) )
268

269
  ,  ( "fusagesp"	   , NoArg (do writeIORef v_UsageSPInf True
270
				       add v_Opt_C "-fusagesp-on") )
271

272 273
  ,  ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
				       add v_Opt_C "-fexcess-precision"))
274

275 276 277 278 279 280 281
	-- Optimisation flags are treated specially, so the normal
	-- -fno-* pattern below doesn't work.  We therefore allow
	-- certain optimisation passes to be turned off explicitly:
  ,  ( "fno-strictness"	   , NoArg (writeIORef v_Strictness False) )
  ,  ( "fno-cpr"	   , NoArg (writeIORef v_CPR False) )
  ,  ( "fno-cse"	   , NoArg (writeIORef v_CSE False) )

282 283
	-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
  ,  ( "fno-",			PrefixPred (\s -> isStaticHscFlag ("f"++s))
284
				    (\s -> add v_Anti_opt_C ("-f"++s)) )
285 286

	-- Pass all remaining "-f<blah>" options to hsc
287
  ,  ( "f", 			AnySuffixPred (isStaticHscFlag) (add v_Opt_C) )
288 289 290 291
  ]

dynamic_flags = [

292
     ( "cpp",		NoArg  (updDynFlags (\s -> s{ cppFlag = True })) )
293 294
  ,  ( "#include",	HasArg (addCmdlineHCInclude) )

295 296
  ,  ( "v",		OptPrefix (setVerbosity) )

297 298 299 300 301 302 303 304 305 306 307
  ,  ( "optL",		HasArg (addOpt_L) )
  ,  ( "optP",		HasArg (addOpt_P) )
  ,  ( "optc",		HasArg (addOpt_c) )
  ,  ( "optm",		HasArg (addOpt_m) )
  ,  ( "opta",		HasArg (addOpt_a) )

	------ HsCpp opts ---------------------------------------------------
  ,  ( "D",		Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
  ,  ( "U",		Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )

	------ Debugging ----------------------------------------------------
308
  ,  ( "dstg-stats",	NoArg (writeIORef v_StgStats True) )
309

310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
  ,  ( "ddump-absC",         	 NoArg (setDynFlag Opt_D_dump_absC) )
  ,  ( "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-realC",        	 NoArg (setDynFlag Opt_D_dump_realC) )
  ,  ( "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) )
325
  ,  ( "ddump-sat",          	 NoArg (setDynFlag Opt_D_dump_sat) )
326 327 328 329 330 331 332 333
  ,  ( "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-usagesp",      	 NoArg (setDynFlag Opt_D_dump_usagesp) )
  ,  ( "ddump-cse",          	 NoArg (setDynFlag Opt_D_dump_cse) )
  ,  ( "ddump-worker-wrapper",   NoArg (setDynFlag Opt_D_dump_worker_wrapper) )
334
  ,  ( "dshow-passes",           NoArg (setVerbosity "2") )
335
  ,  ( "ddump-rn-trace",         NoArg (setDynFlag Opt_D_dump_rn_trace) )
336
  ,  ( "ddump-tc-trace",         NoArg (setDynFlag Opt_D_dump_tc_trace) )
337 338 339
  ,  ( "ddump-rn-stats",         NoArg (setDynFlag Opt_D_dump_rn_stats) )
  ,  ( "ddump-stix",             NoArg (setDynFlag Opt_D_dump_stix) )
  ,  ( "ddump-simpl-stats",      NoArg (setDynFlag Opt_D_dump_simpl_stats) )
340
  ,  ( "ddump-bcos",             NoArg (setDynFlag Opt_D_dump_BCOs) )
341 342 343 344
  ,  ( "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) )
345
  ,  ( "ddump-hi",               NoArg (setDynFlag Opt_D_dump_hi) )
346 347 348 349
  ,  ( "ddump-minimal-imports",  NoArg (setDynFlag Opt_D_dump_minimal_imports) )
  ,  ( "dcore-lint",       	 NoArg (setDynFlag Opt_DoCoreLinting) )
  ,  ( "dstg-lint",        	 NoArg (setDynFlag Opt_DoStgLinting) )
  ,  ( "dusagesp-lint",        	 NoArg (setDynFlag Opt_DoUSPLinting) )
350 351 352

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

353 354 355
  ,  ( "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}) ))
356

357 358 359 360 361 362
	------ Warning opts -------------------------------------------------
  ,  ( "W"		, NoArg (mapM_ setDynFlag   minusWOpts)    )
  ,  ( "Wall"		, NoArg (mapM_ setDynFlag   minusWallOpts) )
  ,  ( "Wnot"		, NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */
  ,  ( "w"		, NoArg (mapM_ unSetDynFlag minusWallOpts) )

363 364
        ------ Compiler flags -----------------------------------------------

365 366 367
  ,  ( "fasm",		AnySuffix (\_ -> setLang HscAsm) )
  ,  ( "fvia-c",	NoArg (setLang HscC) )
  ,  ( "fvia-C",	NoArg (setLang HscC) )
368
  ,  ( "filx",		NoArg (setLang HscILX) )
369

370 371
	-- "active negatives"
  ,  ( "fno-implicit-prelude",  NoArg (setDynFlag Opt_NoImplicitPrelude) )
372

373 374
	-- the rest of the -f* and -fno-* flags
  ,  ( "fno-", 		PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
375
  ,  ( "f",		PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
376
 ]
377

378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397
-- 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 ),
  ( "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 ),
  ( "glasgow-exts", 		 	Opt_GlasgowExts ),
  ( "allow-overlapping-instances", 	Opt_AllowOverlappingInstances ),
  ( "allow-undecidable-instances", 	Opt_AllowUndecidableInstances ),
398
  ( "generics",  			Opt_Generics )
399
  ]
400

401 402
isFFlag f = f `elem` (map fst fFlags)
getFFlag f = fromJust (lookup f fFlags)
403 404 405 406 407 408 409 410 411 412

-----------------------------------------------------------------------------
-- 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)
413
  | otherwise            = throwDyn (CmdLineError ("can't decode size: " ++ str))
414 415 416 417
  where (m, c) = span pred str
        n      = read m  :: Double
	pred c = isDigit c || c == '.'

418 419 420 421 422 423

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

foreign import "setHeapSize"       unsafe setHeapSize       :: Int -> IO ()
foreign import "enableTimingStats" unsafe enableTimingStats :: IO ()
424

425 426 427
-----------------------------------------------------------------------------
-- Build the Hsc static command line opts

428 429
buildStaticHscOpts :: IO [String]
buildStaticHscOpts = do
430

431
  opt_C_ <- getStaticOpts v_Opt_C	-- misc hsc opts from the command line
432 433

	-- optimisation
434 435
  minus_o <- readIORef v_OptLevel
  let optimisation_opts = 
436 437 438 439 440 441 442 443 444
        case minus_o of
	    0 -> hsc_minusNoO_flags
	    1 -> hsc_minusO_flags
	    2 -> hsc_minusO2_flags
	    _ -> error "unknown opt level"
	    -- ToDo: -Ofile
 
	-- take into account -fno-* flags by removing the equivalent -f*
	-- flag from our list.
445
  anti_flags <- getStaticOpts v_Anti_opt_C
446
  let basic_opts = opt_C_ ++ optimisation_opts
447 448
      filtered_opts = filter (`notElem` anti_flags) basic_opts

449 450
  static <- (do s <- readIORef v_Static; if s then return "-static" 
					      else return "")
451

452
  return ( static : filtered_opts )
453

454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489
-----------------------------------------------------------------------------
-- Via-C compilation stuff

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

machdepCCOpts 
   | prefixMatch "alpha"   cTARGETPLATFORM  
	= return ( ["-static"], [] )

   | 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.)
	= return ( ["-static", "-D_HPUX_SOURCE"], [] )

   | 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.
	= do n_regs <- dynFlag stolen_x86_regs
	     sta    <- readIORef v_Static
	     return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "",
sof's avatar
sof committed
490
                        if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" ],
491 492 493 494 495 496 497 498 499 500 501 502
		      [ "-fno-defer-pop", "-fomit-frame-pointer",
	                "-DSTOLEN_X86_REGS="++show n_regs ]
		    )

   | prefixMatch "mips"    cTARGETPLATFORM
	= return ( ["static"], [] )

   | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
	= return ( ["static"], ["-finhibit-size-directive"] )

   | otherwise
	= return ( [], [] )
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



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_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})

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

getOpts :: (DynFlags -> [a]) -> IO [a]
	-- We add to the options from the front, so we need to reverse the list
getOpts opts = dynFlag opts >>= return . reverse

-- we can only change HscC to HscAsm and vice-versa with dynamic flags 
-- (-fvia-C and -fasm).
-- NB: we can also set the new lang to ILX, via -filx.  I hope this is right
setLang l = updDynFlags (\ dfs -> case hscLang dfs of
					HscC   -> dfs{ hscLang = l }
					HscAsm -> dfs{ hscLang = l }
					HscILX -> dfs{ hscLang = l }
					_      -> dfs)

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

getVerbFlag = do
   verb <- dynFlag verbosity
   if verb >= 3  then return  "-v" else return ""