CmdLineOpts.lhs 19.6 KB
Newer Older
1

2
% (c) The University of Glasgow, 1996-2000
3 4 5 6
%
\section[CmdLineOpts]{Things to do with command-line options}

\begin{code}
7

8 9
module CmdLineOpts (
	CoreToDo(..),
10
	SimplifierSwitch(..), isAmongSimpl,
11 12
	StgToDo(..),
	SwitchResult(..),
13

14
	HscLang(..),
15
	DynFlag(..),	-- needed non-abstractly by DriverFlags
16
	DynFlags(..),
17
	defaultDynFlags,
18

19 20
	v_Static_hsc_opts,

21 22
	intSwitchSet,
	switchIsOn,
23
	isStaticHscFlag,
24

25
	opt_PprStyle_NoPrags,
26
	opt_PprStyle_RawTypes,
27
	opt_PprUserLength,
28 29
	opt_PprStyle_Debug,

30 31
	dopt,

32 33 34
	-- other dynamic flags
	dopt_CoreToDo,
	dopt_StgToDo,
35
	dopt_HscLang,
36
	dopt_OutName,
37

38 39 40 41 42
	-- sets of warning opts
 	standardWarnings,
	minusWOpts,
	minusWallOpts,

43 44 45 46 47 48
	-- profiling opts
	opt_AutoSccsOnAllToplevs,
	opt_AutoSccsOnExportedToplevs,
	opt_AutoSccsOnIndividualCafs,
	opt_AutoSccsOnDicts,
	opt_SccProfilingOn,
49
	opt_DoTickyProfiling,
50 51 52 53 54 55 56 57

	-- language opts
	opt_AllStrict,
	opt_DictsStrict,
        opt_MaxContextReductionDepth,
	opt_IrrefutableTuples,
	opt_NumbersStrict,
	opt_Parallel,
58
	opt_SMP,
59
	opt_NoMonomorphismRestriction,
60
	opt_KeepStgTypes,
61 62

	-- optimisation opts
63
	opt_NoMethodSharing,
64
	opt_DoSemiTagging,
65
	opt_FoldrBuildOn,
66 67 68
	opt_LiberateCaseThreshold,
	opt_StgDoLetNoEscapes,
	opt_UnfoldCasms,
69
        opt_UsageSPOn,
70
	opt_UnboxStrictFields,
71 72 73 74
	opt_SimplNoPreInlining,
	opt_SimplDoEtaReduction,
	opt_SimplDoLambdaEtaExpansion,
	opt_SimplCaseMerge,
75
	opt_SimplExcessPrecision,
76 77 78 79 80 81

	-- Unfolding control
	opt_UF_CreationThreshold,
	opt_UF_UseThreshold,
	opt_UF_FunAppDiscount,
	opt_UF_KeenessFactor,
82
	opt_UF_UpdateInPlace,
83 84
	opt_UF_CheapOp,
	opt_UF_DearOp,
85 86

	-- misc opts
87
	opt_InPackage,
88 89
	opt_EmitCExternDecls,
	opt_EnsureSplittableC,
90
	opt_GranMacros,
sof's avatar
sof committed
91
	opt_HiVersion,
92
	opt_HistorySize,
sof's avatar
sof committed
93
	opt_IgnoreAsserts,
94
	opt_IgnoreIfacePragmas,
sof's avatar
sof committed
95
        opt_NoHiCheck,
96 97
	opt_OmitBlackHoling,
	opt_OmitInterfacePragmas,
98
	opt_NoPruneTyDecls,
99
	opt_NoPruneDecls,
sof's avatar
sof committed
100
	opt_Static,
101
	opt_Unregisterised
102 103
    ) where

104 105 106
#include "HsVersions.h"

import Array	( array, (//) )
sof's avatar
sof committed
107
import GlaExts
108
import IOExts	( IORef, readIORef )
109
import Constants	-- Default values for some flags
110
import Util
111
import FastTypes
112
import Config
113

114 115
import Maybes		( firstJust )
import Panic		( panic )
116 117 118 119 120 121

#if __GLASGOW_HASKELL__ < 301
import ArrBase	( Array(..) )
#else
import PrelArr  ( Array(..) )
#endif
122 123
\end{code}

124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
%************************************************************************
%*									*
\subsection{Command-line options}
%*									*
%************************************************************************

The hsc command-line options are split into two categories:

  - static flags
  - dynamic flags

Static flags are represented by top-level values of type Bool or Int,
for example.  They therefore have the same value throughout the
invocation of hsc.

139 140 141 142 143
Dynamic flags are represented by an abstract type, DynFlags, which is
passed into hsc by the compilation manager for every compilation.
Dynamic flags are those that change on a per-compilation basis,
perhaps because they may be present in the OPTIONS pragma at the top
of a module.
144 145

Other flag-related blurb:
146 147 148 149 150 151 152 153 154 155 156 157 158

A list of {\em ToDo}s is things to be done in a particular part of
processing.  A (fictitious) example for the Core-to-Core simplifier
might be: run the simplifier, then run the strictness analyser, then
run the simplifier again (three ``todos'').

There are three ``to-do processing centers'' at the moment.  In the
main loop (\tr{main/Main.lhs}), in the Core-to-Core processing loop
(\tr{simplCore/SimplCore.lhs), and in the STG-to-STG processing loop
(\tr{simplStg/SimplStg.lhs}).

%************************************************************************
%*									*
159
\subsection{Datatypes associated with command-line options}
160 161 162 163 164
%*									*
%************************************************************************

\begin{code}
data SwitchResult
165 166 167
  = SwBool	Bool		-- on/off
  | SwString	FAST_STRING	-- nothing or a String
  | SwInt	Int		-- nothing or an Int
168 169 170 171 172 173 174 175 176 177 178 179
\end{code}

\begin{code}
data CoreToDo		-- These are diff core-to-core passes,
			-- which may be invoked in any order,
  			-- as many times as you like.

  = CoreDoSimplify	-- The core-to-core simplifier.
	(SimplifierSwitch -> SwitchResult)
			-- Each run of the simplifier can take a different
			-- set of simplifier-specific flags.
  | CoreDoFloatInwards
180
  | CoreDoFloatOutwards Bool	-- True <=> float lambdas to top level
181 182 183 184
  | CoreLiberateCase
  | CoreDoPrintCore
  | CoreDoStaticArgs
  | CoreDoStrictness
185
  | CoreDoWorkerWrapper
186
  | CoreDoSpecialising
187
  | CoreDoSpecConstr
188
  | CoreDoUSPInf
189
  | CoreDoCPResult
190
  | CoreDoGlomBinds
191
  | CoreCSE
192 193

  | CoreDoNothing 	 -- useful when building up lists of these things
194 195 196 197
\end{code}

\begin{code}
data StgToDo
198
  = StgDoMassageForProfiling  -- should be (next to) last
199 200 201 202 203 204 205
  -- There's also setStgVarInfo, but its absolute "lastness"
  -- is so critical that it is hardwired in (no flag).
  | D_stg_stats
\end{code}

\begin{code}
data SimplifierSwitch
206 207
  = MaxSimplifierIterations Int
  | SimplInlinePhase Int
208
  | DontApplyRules
209
  | NoCaseOfCase
210
  | SimplLetToCase
211 212
\end{code}

213 214 215 216 217 218 219 220 221 222
%************************************************************************
%*									*
\subsection{Dynamic command-line options}
%*									*
%************************************************************************

\begin{code}
data DynFlag

   -- debugging flags
223
   = Opt_D_dump_absC
224 225 226 227 228 229 230 231 232 233 234 235 236 237
   | Opt_D_dump_asm
   | Opt_D_dump_cpranal
   | Opt_D_dump_deriv
   | Opt_D_dump_ds
   | Opt_D_dump_flatC
   | Opt_D_dump_foreign
   | Opt_D_dump_inlinings
   | Opt_D_dump_occur_anal
   | Opt_D_dump_parsed
   | Opt_D_dump_realC
   | Opt_D_dump_rn
   | Opt_D_dump_simpl
   | Opt_D_dump_simpl_iterations
   | Opt_D_dump_spec
238
   | Opt_D_dump_sat
239 240 241 242 243 244 245 246 247 248 249 250
   | Opt_D_dump_stg
   | Opt_D_dump_stranal
   | Opt_D_dump_tc
   | Opt_D_dump_types
   | Opt_D_dump_rules
   | Opt_D_dump_usagesp
   | Opt_D_dump_cse
   | Opt_D_dump_worker_wrapper
   | Opt_D_dump_rn_trace
   | Opt_D_dump_rn_stats
   | Opt_D_dump_stix
   | Opt_D_dump_simpl_stats
251
   | Opt_D_dump_tc_trace
252
   | Opt_D_dump_BCOs
253 254 255
   | Opt_D_source_stats
   | Opt_D_verbose_core2core
   | Opt_D_verbose_stg2stg
256
   | Opt_D_dump_hi
257 258 259 260 261 262
   | Opt_D_dump_hi_diffs
   | Opt_D_dump_minimal_imports
   | Opt_DoCoreLinting
   | Opt_DoStgLinting
   | Opt_DoUSPLinting

263 264 265 266 267 268 269 270 271 272 273 274 275 276 277
   | Opt_WarnDuplicateExports
   | Opt_WarnHiShadows
   | Opt_WarnIncompletePatterns
   | Opt_WarnMissingFields
   | Opt_WarnMissingMethods
   | Opt_WarnMissingSigs
   | Opt_WarnNameShadowing
   | Opt_WarnOverlappingPatterns
   | Opt_WarnSimplePatterns
   | Opt_WarnTypeDefaults
   | Opt_WarnUnusedBinds
   | Opt_WarnUnusedImports
   | Opt_WarnUnusedMatches
   | Opt_WarnDeprecations

278 279 280 281
   -- language opts
   | Opt_AllowOverlappingInstances
   | Opt_AllowUndecidableInstances
   | Opt_GlasgowExts
282
   | Opt_Generics
283
   | Opt_NoImplicitPrelude 
284

285 286
   deriving (Eq)

287
data DynFlags = DynFlags {
288 289 290 291
  coreToDo   		:: [CoreToDo],
  stgToDo    		:: [StgToDo],
  hscLang    		:: HscLang,
  hscOutName 		:: String,  	-- name of the output file
292 293
  hscStubHOutName	:: String,  	-- name of the .stub_h output file
  hscStubCOutName	:: String,  	-- name of the .stub_c output file
294 295 296 297 298 299 300 301 302 303 304 305 306 307
  verbosity  		:: Int,	 	-- verbosity level
  cppFlag    		:: Bool,	-- preprocess with cpp?
  stolen_x86_regs	:: Int,		
  cmdlineHcIncludes	:: [String],	-- -#includes

  -- options for particular phases
  opt_L			:: [String],
  opt_P			:: [String],
  opt_c			:: [String],
  opt_a			:: [String],
  opt_m			:: [String],

  -- hsc dynamic flags
  flags      		:: [DynFlag]
308
 }
309

310 311
defaultDynFlags = DynFlags {
  coreToDo = [], stgToDo = [], 
312 313
  hscLang = HscC, 
  hscOutName = "", 
314
  hscStubHOutName = "", hscStubCOutName = "",
315 316 317 318 319 320 321 322 323
  verbosity = 0, 
  cppFlag		= False,
  stolen_x86_regs	= 4,
  cmdlineHcIncludes	= [],
  opt_L			= [],
  opt_P			= [],
  opt_c			= [],
  opt_a			= [],
  opt_m			= [],
324
  flags = standardWarnings,
325 326 327 328 329 330 331 332 333 334 335 336 337
  }

{- 
    Verbosity levels:
	
    0	|   print errors & warnings only
    1   |   minimal verbosity: print "compiling M ... done." for each module.
    2   |   equivalent to -dshow-passes
    3   |   equivalent to existing "ghc -v"
    4   |   "ghc -v -ddump-most"
    5   |   "ghc -v -ddump-all"
-}

338 339
dopt :: DynFlag -> DynFlags -> Bool
dopt f dflags  = f `elem` (flags dflags)
340

341
dopt_CoreToDo :: DynFlags -> [CoreToDo]
342
dopt_CoreToDo = coreToDo
343

344
dopt_StgToDo :: DynFlags -> [StgToDo]
345 346
dopt_StgToDo = stgToDo

347 348 349
dopt_OutName :: DynFlags -> String
dopt_OutName = hscOutName

350
data HscLang
351 352 353
  = HscC
  | HscAsm
  | HscJava
rrt's avatar
rrt committed
354 355 356
#ifdef ILX
  | HscILX
#endif
357
  | HscInterpreted
358
    deriving (Eq, Show)
359 360 361

dopt_HscLang :: DynFlags -> HscLang
dopt_HscLang = hscLang
362 363
\end{code}

364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395
%************************************************************************
%*									*
\subsection{Warnings}
%*									*
%************************************************************************

\begin{code}
standardWarnings
    = [ Opt_WarnDeprecations,
	Opt_WarnOverlappingPatterns,
	Opt_WarnMissingFields,
	Opt_WarnMissingMethods,
	Opt_WarnDuplicateExports
      ]

minusWOpts
    = standardWarnings ++ 
      [	Opt_WarnUnusedBinds,
	Opt_WarnUnusedMatches,
	Opt_WarnUnusedImports,
	Opt_WarnIncompletePatterns
      ]

minusWallOpts
    = minusWOpts ++
      [	Opt_WarnTypeDefaults,
	Opt_WarnNameShadowing,
	Opt_WarnMissingSigs,
	Opt_WarnHiShadows
      ]
\end{code}

396 397
%************************************************************************
%*									*
398
\subsection{Classifying command-line options}
399 400 401 402
%*									*
%************************************************************************

\begin{code}
403 404 405 406
-- v_Statis_hsc_opts is here to avoid a circular dependency with
-- main/DriverState.
GLOBAL_VAR(v_Static_hsc_opts, [], [String])

sof's avatar
sof committed
407 408 409 410 411
lookUp	       	 :: FAST_STRING -> Bool
lookup_int     	 :: String -> Maybe Int
lookup_def_int   :: String -> Int -> Int
lookup_def_float :: String -> Float -> Float
lookup_str       :: String -> Maybe String
412

413 414 415 416
unpacked_static_opts = unsafePerformIO (readIORef v_Static_hsc_opts)
packed_static_opts   = map _PK_ unpacked_static_opts

lookUp     sw = sw `elem` packed_static_opts
417
	
418
lookup_str sw = firstJust (map (startsWith sw) unpacked_static_opts)
419 420 421

lookup_int sw = case (lookup_str sw) of
		  Nothing -> Nothing
422
		  Just xx -> Just (read xx)
423

424 425 426 427
lookup_def_int sw def = case (lookup_str sw) of
			    Nothing -> def		-- Use default
		  	    Just xx -> read xx

sof's avatar
sof committed
428 429 430 431
lookup_def_float sw def = case (lookup_str sw) of
			    Nothing -> def		-- Use default
		  	    Just xx -> read xx

sof's avatar
sof committed
432 433 434 435 436 437 438 439 440 441 442

{-
 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) $
443
  map _UNPK_ argv  -- NOT ARGV any more: v_Static_hsc_opts
sof's avatar
sof committed
444 445 446 447
  where
   expandAts ('@':fname) = words (unsafePerformIO (readFile fname))
   expandAts l = [l]
-}
448 449
\end{code}

450 451 452 453 454
%************************************************************************
%*									*
\subsection{Static options}
%*									*
%************************************************************************
455

456
\begin{code}
457 458 459
-- debugging opts
opt_PprStyle_NoPrags		= lookUp  SLIT("-dppr-noprags")
opt_PprStyle_Debug		= lookUp  SLIT("-dppr-debug")
460
opt_PprStyle_RawTypes		= lookUp  SLIT("-dppr-rawtypes")
461 462 463 464 465 466 467 468 469 470 471 472
opt_PprUserLength	        = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name

-- profiling opts
opt_AutoSccsOnAllToplevs	= lookUp  SLIT("-fauto-sccs-on-all-toplevs")
opt_AutoSccsOnExportedToplevs	= lookUp  SLIT("-fauto-sccs-on-exported-toplevs")
opt_AutoSccsOnIndividualCafs	= lookUp  SLIT("-fauto-sccs-on-individual-cafs")
opt_AutoSccsOnDicts		= lookUp  SLIT("-fauto-sccs-on-dicts")
opt_SccProfilingOn		= lookUp  SLIT("-fscc-profiling")
opt_DoTickyProfiling		= lookUp  SLIT("-fticky-ticky")

-- language opts
opt_AllStrict			= lookUp  SLIT("-fall-strict")
473
opt_NoMonomorphismRestriction	= lookUp  SLIT("-fno-monomorphism-restriction")
474 475 476 477 478
opt_DictsStrict			= lookUp  SLIT("-fdicts-strict")
opt_IrrefutableTuples		= lookUp  SLIT("-firrefutable-tuples")
opt_MaxContextReductionDepth	= lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
opt_NumbersStrict		= lookUp  SLIT("-fnumbers-strict")
opt_Parallel			= lookUp  SLIT("-fparallel")
479
opt_SMP				= lookUp  SLIT("-fsmp")
480 481

-- optimisation opts
482
opt_NoMethodSharing		= lookUp  SLIT("-fno-method-sharing")
483 484
opt_DoSemiTagging		= lookUp  SLIT("-fsemi-tagging")
opt_FoldrBuildOn		= lookUp  SLIT("-ffoldr-build-on")
485
opt_LiberateCaseThreshold	= lookup_def_int "-fliberate-case-threshold" (10::Int)
486
opt_StgDoLetNoEscapes		= lookUp  SLIT("-flet-no-escape")
rrt's avatar
rrt committed
487
opt_UnfoldCasms		        = lookUp  SLIT("-funfold-casms-in-hi-file")
488
opt_UsageSPOn           	= lookUp  SLIT("-fusagesp-on")
489
opt_UnboxStrictFields		= lookUp  SLIT("-funbox-strict-fields")
490

491
{-
492
   The optional '-inpackage=P' flag tells what package
493
   we are compiling this module for.
494
   The Prelude, for example is compiled with '-inpackage std'
495 496 497 498 499
-}
opt_InPackage			= case lookup_str "-inpackage=" of
				    Just p  -> _PK_ p
				    Nothing -> SLIT("Main")	-- The package name if none is specified

500 501
opt_EmitCExternDecls	        = lookUp  SLIT("-femit-extern-decls")
opt_EnsureSplittableC		= lookUp  SLIT("-fglobalise-toplev-names")
502
opt_GranMacros			= lookUp  SLIT("-fgransim")
503
opt_HiVersion			= read cProjectVersionInt :: Int
504
opt_HistorySize			= lookup_def_int "-fhistory-size" 20
sof's avatar
sof committed
505
opt_IgnoreAsserts               = lookUp  SLIT("-fignore-asserts")
506
opt_IgnoreIfacePragmas		= lookUp  SLIT("-fignore-interface-pragmas")
507
opt_NoHiCheck                   = lookUp  SLIT("-fno-hi-version-check")
508 509
opt_OmitBlackHoling		= lookUp  SLIT("-dno-black-holing")
opt_OmitInterfacePragmas	= lookUp  SLIT("-fomit-interface-pragmas")
510
opt_KeepStgTypes		= lookUp  SLIT("-fkeep-stg-types")
511

512
-- Simplifier switches
rrt's avatar
rrt committed
513
opt_SimplNoPreInlining		= lookUp  SLIT("-fno-pre-inlining")
514 515
	-- NoPreInlining is there just to see how bad things
	-- get if you don't do it!
rrt's avatar
rrt committed
516 517 518 519
opt_SimplDoEtaReduction		= lookUp  SLIT("-fdo-eta-reduction")
opt_SimplDoLambdaEtaExpansion	= lookUp  SLIT("-fdo-lambda-eta-expansion")
opt_SimplCaseMerge		= lookUp  SLIT("-fcase-merge")
opt_SimplExcessPrecision	= lookUp  SLIT("-fexcess-precision")
520 521

-- Unfolding control
522
opt_UF_CreationThreshold	= lookup_def_int "-funfolding-creation-threshold"  (45::Int)
523 524
opt_UF_UseThreshold		= lookup_def_int "-funfolding-use-threshold"	   (8::Int)	-- Discounts can be big
opt_UF_FunAppDiscount		= lookup_def_int "-funfolding-fun-discount"	   (6::Int)	-- It's great to inline a fn
525
opt_UF_KeenessFactor		= lookup_def_float "-funfolding-keeness-factor"	   (1.5::Float)
526
opt_UF_UpdateInPlace		= lookUp  SLIT("-funfolding-update-in-place")
527

528
opt_UF_CheapOp  = ( 1 :: Int)	-- Only one instruction; and the args are charged for
529
opt_UF_DearOp   = ( 4 :: Int)
530
			
rrt's avatar
rrt committed
531 532 533 534
opt_NoPruneDecls		= lookUp  SLIT("-fno-prune-decls")
opt_NoPruneTyDecls		= lookUp  SLIT("-fno-prune-tydecls")
opt_Static			= lookUp  SLIT("-static")
opt_Unregisterised		= lookUp  SLIT("-funregisterised")
535 536
\end{code}

537 538 539 540 541 542 543
%************************************************************************
%*									*
\subsection{List of static hsc flags}
%*									*
%************************************************************************

\begin{code}
544
isStaticHscFlag f =
545
  f `elem` [
546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570
	"fauto-sccs-on-all-toplevs",
	"fauto-sccs-on-exported-toplevs",
	"fauto-sccs-on-individual-cafs",
	"fauto-sccs-on-dicts",
	"fscc-profiling",
	"fticky-ticky",
	"fall-strict",
	"fdicts-strict",
	"firrefutable-tuples",
	"fnumbers-strict",
	"fparallel",
	"fsmp",
	"fsemi-tagging",
	"ffoldr-build-on",
	"flet-no-escape",
	"funfold-casms-in-hi-file",
	"fusagesp-on",
	"funbox-strict-fields",
	"femit-extern-decls",
	"fglobalise-toplev-names",
	"fgransim",
	"fignore-asserts",
	"fignore-interface-pragmas",
	"fno-hi-version-check",
	"dno-black-holing",
571 572
	"fno-method-sharing",
        "fno-monomorphism-restriction",
573
	"fomit-interface-pragmas",
574
	"fkeep-stg-types",
575 576 577 578 579 580 581 582 583
	"fno-pre-inlining",
	"fdo-eta-reduction",
	"fdo-lambda-eta-expansion",
	"fcase-merge",
	"fexcess-precision",
	"funfolding-update-in-place",
	"fno-prune-decls",
	"fno-prune-tydecls",
	"static",
584 585
	"funregisterised"
	]
586
  || any (flip prefixMatch f) [
587 588 589 590 591 592 593
	"fcontext-stack",
	"fliberate-case-threshold",
	"fhistory-size",
	"funfolding-creation-threshold",
	"funfolding-use-threshold",
	"funfolding-fun-discount",
	"funfolding-keeness-factor"
594 595 596
     ]
\end{code}

597 598
%************************************************************************
%*									*
599
\subsection{Switch ordering}
600 601 602
%*									*
%************************************************************************

603
These things behave just like enumeration types.
604 605 606

\begin{code}
instance Eq SimplifierSwitch where
607
    a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
608 609

instance Ord SimplifierSwitch where
610 611
    a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
    a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
612

sof's avatar
sof committed
613

614 615 616 617 618
tagOf_SimplSwitch (SimplInlinePhase _)		= _ILIT(1)
tagOf_SimplSwitch (MaxSimplifierIterations _)	= _ILIT(2)
tagOf_SimplSwitch DontApplyRules		= _ILIT(3)
tagOf_SimplSwitch SimplLetToCase		= _ILIT(4)
tagOf_SimplSwitch NoCaseOfCase			= _ILIT(5)
619

620
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
621

622
lAST_SIMPL_SWITCH_TAG = 5
623 624 625 626
\end{code}

%************************************************************************
%*									*
627
\subsection{Switch lookup}
628 629 630 631 632
%*									*
%************************************************************************

\begin{code}
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
633 634
isAmongSimpl on_switches		-- Switches mentioned later occur *earlier*
					-- in the list; defaults right at the end.
635 636
  = let
	tidied_on_switches = foldl rm_dups [] on_switches
637 638
		-- The fold*l* ensures that we keep the latest switches;
		-- ie the ones that occur earliest in the list.
639 640 641 642 643 644

	sw_tbl :: Array Int SwitchResult
	sw_tbl = (array	(0, lAST_SIMPL_SWITCH_TAG) -- bounds...
			all_undefined)
		 // defined_elems

sof's avatar
sof committed
645
	all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
646 647 648 649

	defined_elems = map mk_assoc_elem tidied_on_switches
    in
    -- (avoid some unboxing, bounds checking, and other horrible things:)
650
#if __GLASGOW_HASKELL__ < 405
sof's avatar
sof committed
651
    case sw_tbl of { Array bounds_who_needs_'em stuff ->
652 653 654
#else
    case sw_tbl of { Array _ _ stuff ->
#endif
655 656
    \ switch ->
	case (indexArray# stuff (tagOf_SimplSwitch switch)) of
657
#if __GLASGOW_HASKELL__ < 400
sof's avatar
sof committed
658
	  Lift v -> v
659
#elif __GLASGOW_HASKELL__ < 403
660
	  (# _, v #) -> v
661 662
#else
	  (# v #) -> v
663
#endif
664 665
    }
  where
666
    mk_assoc_elem k@(MaxSimplifierIterations lvl)
667 668 669 670 671
	= (iBox (tagOf_SimplSwitch k), SwInt lvl)
    mk_assoc_elem k@(SimplInlinePhase n)
	= (iBox (tagOf_SimplSwitch k), SwInt n)
    mk_assoc_elem k
	= (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
672 673 674 675 676 677 678 679

    -- cannot have duplicates if we are going to use the array thing
    rm_dups switches_so_far switch
      = if switch `is_elem` switches_so_far
    	then switches_so_far
	else switch : switches_so_far
      where
	sw `is_elem` []     = False
680
	sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
681 682 683
			    || sw `is_elem` ss
\end{code}

684

685 686
%************************************************************************
%*									*
687
\subsection{Misc functions for command-line options}
688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704
%*									*
%************************************************************************


\begin{code}
switchIsOn :: (switch -> SwitchResult) -> switch -> Bool

switchIsOn lookup_fn switch
  = case (lookup_fn switch) of
      SwBool False -> False
      _	    	   -> True

intSwitchSet :: (switch -> SwitchResult)
	     -> (Int -> switch)
	     -> Maybe Int

intSwitchSet lookup_fn switch
705
  = case (lookup_fn (switch (panic "intSwitchSet"))) of
706 707 708
      SwInt int -> Just int
      _	    	-> Nothing
\end{code}
709 710

\begin{code}
711 712
startsWith :: String -> String -> Maybe String
-- startsWith pfx (pfx++rest) = Just rest
713 714 715 716 717 718

startsWith []     str = Just str
startsWith (c:cs) (s:ss)
  = if c /= s then Nothing else startsWith cs ss
startsWith  _	  []  = Nothing

719
endsWith  :: String -> String -> Maybe String
720 721 722 723 724
endsWith cs ss
  = case (startsWith (reverse cs) (reverse ss)) of
      Nothing -> Nothing
      Just rs -> Just (reverse rs)
\end{code}