ghc/compiler/main/CmdLineOpts.lhs

   1 %
   2 % (c) The University of Glasgow, 1996-2000
   3 %
   4 \section[CmdLineOpts]{Things to do with command-line options}
   5
   6 \begin{code}
   7
   8 module CmdLineOpts (
   9         CoreToDo(..),
  10         SimplifierSwitch(..), isAmongSimpl,
  11         StgToDo(..),
  12         SwitchResult(..),
  13
  14         HscLang(..),
  15         DynFlag(..),    -- needed non-abstractly by DriverFlags
  16         DynFlags(..),
  17         defaultDynFlags,
  18
  19         v_Static_hsc_opts,
  20
  21         intSwitchSet,
  22         switchIsOn,
  23         isStaticHscFlag,
  24
  25         opt_PprStyle_NoPrags,
  26         opt_PprStyle_RawTypes,
  27         opt_PprUserLength,
  28         opt_PprStyle_Debug,
  29
  30         dopt,
  31
  32         -- other dynamic flags
  33         dopt_CoreToDo,
  34         dopt_StgToDo,
  35         dopt_HscLang,
  36         dopt_OutName,
  37
  38         -- profiling opts
  39         opt_AutoSccsOnAllToplevs,
  40         opt_AutoSccsOnExportedToplevs,
  41         opt_AutoSccsOnIndividualCafs,
  42         opt_AutoSccsOnDicts,
  43         opt_SccProfilingOn,
  44         opt_DoTickyProfiling,
  45
  46         -- language opts
  47         opt_AllStrict,
  48         opt_DictsStrict,
  49         opt_MaxContextReductionDepth,
  50         opt_IrrefutableTuples,
  51         opt_NumbersStrict,
  52         opt_Parallel,
  53         opt_SMP,
  54         opt_NoMonomorphismRestriction,
  55         opt_KeepStgTypes,
  56
  57         -- optimisation opts
  58         opt_NoMethodSharing,
  59         opt_DoSemiTagging,
  60         opt_FoldrBuildOn,
  61         opt_LiberateCaseThreshold,
  62         opt_StgDoLetNoEscapes,
  63         opt_UnfoldCasms,
  64         opt_UsageSPOn,
  65         opt_UnboxStrictFields,
  66         opt_SimplNoPreInlining,
  67         opt_SimplDoEtaReduction,
  68         opt_SimplDoLambdaEtaExpansion,
  69         opt_SimplCaseOfCase,
  70         opt_SimplCaseMerge,
  71         opt_SimplPedanticBottoms,
  72         opt_SimplExcessPrecision,
  73
  74         -- Unfolding control
  75         opt_UF_HiFileThreshold,
  76         opt_UF_CreationThreshold,
  77         opt_UF_UseThreshold,
  78         opt_UF_FunAppDiscount,
  79         opt_UF_KeenessFactor,
  80         opt_UF_UpdateInPlace,
  81         opt_UF_CheapOp,
  82         opt_UF_DearOp,
  83
  84         -- misc opts
  85         opt_InPackage,
  86         opt_EmitCExternDecls,
  87         opt_EnsureSplittableC,
  88         opt_GranMacros,
  89         opt_HiVersion,
  90         opt_HistorySize,
  91         opt_IgnoreAsserts,
  92         opt_IgnoreIfacePragmas,
  93         opt_NoHiCheck,
  94         opt_OmitBlackHoling,
  95         opt_OmitInterfacePragmas,
  96         opt_NoPruneTyDecls,
  97         opt_NoPruneDecls,
  98         opt_Static,
  99         opt_Unregisterised
 100     ) where
 101
 102 #include "HsVersions.h"
 103
 104 import Array    ( array, (//) )
 105 import GlaExts
 106 import IOExts   ( IORef, readIORef )
 107 import Constants        -- Default values for some flags
 108 import Util
 109 import FastTypes
 110 import Config
 111
 112 import Maybes           ( firstJust )
 113 import Panic            ( panic )
 114
 115 #if __GLASGOW_HASKELL__ < 301
 116 import ArrBase  ( Array(..) )
 117 #else
 118 import PrelArr  ( Array(..) )
 119 #endif
 120 \end{code}
 121
 122 %************************************************************************
 123 %*                                                                      *
 124 \subsection{Command-line options}
 125 %*                                                                      *
 126 %************************************************************************
 127
 128 The hsc command-line options are split into two categories:
 129
 130   - static flags
 131   - dynamic flags
 132
 133 Static flags are represented by top-level values of type Bool or Int,
 134 for example.  They therefore have the same value throughout the
 135 invocation of hsc.
 136
 137 Dynamic flags are represented by an abstract type, DynFlags, which is
 138 passed into hsc by the compilation manager for every compilation.
 139 Dynamic flags are those that change on a per-compilation basis,
 140 perhaps because they may be present in the OPTIONS pragma at the top
 141 of a module.
 142
 143 Other flag-related blurb:
 144
 145 A list of {\em ToDo}s is things to be done in a particular part of
 146 processing.  A (fictitious) example for the Core-to-Core simplifier
 147 might be: run the simplifier, then run the strictness analyser, then
 148 run the simplifier again (three ``todos'').
 149
 150 There are three ``to-do processing centers'' at the moment.  In the
 151 main loop (\tr{main/Main.lhs}), in the Core-to-Core processing loop
 152 (\tr{simplCore/SimplCore.lhs), and in the STG-to-STG processing loop
 153 (\tr{simplStg/SimplStg.lhs}).
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsection{Datatypes associated with command-line options}
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 \begin{code}
 162 data SwitchResult
 163   = SwBool      Bool            -- on/off
 164   | SwString    FAST_STRING     -- nothing or a String
 165   | SwInt       Int             -- nothing or an Int
 166 \end{code}
 167
 168 \begin{code}
 169 data CoreToDo           -- These are diff core-to-core passes,
 170                         -- which may be invoked in any order,
 171                         -- as many times as you like.
 172
 173   = CoreDoSimplify      -- The core-to-core simplifier.
 174         (SimplifierSwitch -> SwitchResult)
 175                         -- Each run of the simplifier can take a different
 176                         -- set of simplifier-specific flags.
 177   | CoreDoFloatInwards
 178   | CoreDoFloatOutwards Bool    -- True <=> float lambdas to top level
 179   | CoreLiberateCase
 180   | CoreDoPrintCore
 181   | CoreDoStaticArgs
 182   | CoreDoStrictness
 183   | CoreDoWorkerWrapper
 184   | CoreDoSpecialising
 185   | CoreDoUSPInf
 186   | CoreDoCPResult
 187   | CoreDoGlomBinds
 188   | CoreCSE
 189
 190   | CoreDoNothing        -- useful when building up lists of these things
 191 \end{code}
 192
 193 \begin{code}
 194 data StgToDo
 195   = StgDoMassageForProfiling  -- should be (next to) last
 196   -- There's also setStgVarInfo, but its absolute "lastness"
 197   -- is so critical that it is hardwired in (no flag).
 198   | D_stg_stats
 199 \end{code}
 200
 201 \begin{code}
 202 data SimplifierSwitch
 203   = MaxSimplifierIterations Int
 204   | SimplInlinePhase Int
 205   | DontApplyRules
 206   | NoCaseOfCase
 207   | SimplLetToCase
 208 \end{code}
 209
 210 %************************************************************************
 211 %*                                                                      *
 212 \subsection{Dynamic command-line options}
 213 %*                                                                      *
 214 %************************************************************************
 215
 216 \begin{code}
 217 data DynFlag
 218
 219    -- debugging flags
 220    = Opt_D_dump_absC
 221    | Opt_D_dump_asm
 222    | Opt_D_dump_cpranal
 223    | Opt_D_dump_deriv
 224    | Opt_D_dump_ds
 225    | Opt_D_dump_flatC
 226    | Opt_D_dump_foreign
 227    | Opt_D_dump_inlinings
 228    | Opt_D_dump_occur_anal
 229    | Opt_D_dump_parsed
 230    | Opt_D_dump_realC
 231    | Opt_D_dump_rn
 232    | Opt_D_dump_simpl
 233    | Opt_D_dump_simpl_iterations
 234    | Opt_D_dump_spec
 235    | Opt_D_dump_sat
 236    | Opt_D_dump_stg
 237    | Opt_D_dump_stranal
 238    | Opt_D_dump_tc
 239    | Opt_D_dump_types
 240    | Opt_D_dump_tc_trace
 241    | Opt_D_dump_rules
 242    | Opt_D_dump_usagesp
 243    | Opt_D_dump_cse
 244    | Opt_D_dump_worker_wrapper
 245    | Opt_D_dump_rn_trace
 246    | Opt_D_dump_rn_stats
 247    | Opt_D_dump_stix
 248    | Opt_D_dump_simpl_stats
 249    | Opt_D_dump_BCOs
 250    | Opt_D_source_stats
 251    | Opt_D_verbose_core2core
 252    | Opt_D_verbose_stg2stg
 253    | Opt_D_dump_hi
 254    | Opt_D_dump_hi_diffs
 255    | Opt_D_dump_minimal_imports
 256    | Opt_DoCoreLinting
 257    | Opt_DoStgLinting
 258    | Opt_DoUSPLinting
 259
 260    | Opt_WarnDuplicateExports
 261    | Opt_WarnHiShadows
 262    | Opt_WarnIncompletePatterns
 263    | Opt_WarnMissingFields
 264    | Opt_WarnMissingMethods
 265    | Opt_WarnMissingSigs
 266    | Opt_WarnNameShadowing
 267    | Opt_WarnOverlappingPatterns
 268    | Opt_WarnSimplePatterns
 269    | Opt_WarnTypeDefaults
 270    | Opt_WarnUnusedBinds
 271    | Opt_WarnUnusedImports
 272    | Opt_WarnUnusedMatches
 273    | Opt_WarnDeprecations
 274
 275    -- language opts
 276    | Opt_AllowOverlappingInstances
 277    | Opt_AllowUndecidableInstances
 278    | Opt_GlasgowExts
 279    | Opt_Generics
 280    | Opt_NoImplicitPrelude
 281
 282    -- misc
 283    | Opt_ReportCompile
 284    deriving (Eq)
 285
 286 data DynFlags = DynFlags {
 287   coreToDo              :: [CoreToDo],
 288   stgToDo               :: [StgToDo],
 289   hscLang               :: HscLang,
 290   hscOutName            :: String,      -- name of the output file
 291   verbosity             :: Int,         -- verbosity level
 292   cppFlag               :: Bool,        -- preprocess with cpp?
 293   stolen_x86_regs       :: Int,
 294   cmdlineHcIncludes     :: [String],    -- -#includes
 295
 296   -- options for particular phases
 297   opt_L                 :: [String],
 298   opt_P                 :: [String],
 299   opt_c                 :: [String],
 300   opt_a                 :: [String],
 301   opt_m                 :: [String],
 302
 303   -- hsc dynamic flags
 304   flags                 :: [DynFlag]
 305  }
 306
 307 defaultDynFlags = DynFlags {
 308   coreToDo = [], stgToDo = [],
 309   hscLang = HscC,
 310   hscOutName = "",
 311   verbosity = 0,
 312   cppFlag               = False,
 313   stolen_x86_regs       = 4,
 314   cmdlineHcIncludes     = [],
 315   opt_L                 = [],
 316   opt_P                 = [],
 317   opt_c                 = [],
 318   opt_a                 = [],
 319   opt_m                 = [],
 320   flags = []
 321   }
 322
 323 {-
 324     Verbosity levels:
 325
 326     0   |   print errors & warnings only
 327     1   |   minimal verbosity: print "compiling M ... done." for each module.
 328     2   |   equivalent to -dshow-passes
 329     3   |   equivalent to existing "ghc -v"
 330     4   |   "ghc -v -ddump-most"
 331     5   |   "ghc -v -ddump-all"
 332 -}
 333
 334 dopt :: DynFlag -> DynFlags -> Bool
 335 dopt f dflags  = f `elem` (flags dflags)
 336
 337 dopt_CoreToDo :: DynFlags -> [CoreToDo]
 338 dopt_CoreToDo = coreToDo
 339
 340 dopt_StgToDo :: DynFlags -> [StgToDo]
 341 dopt_StgToDo = stgToDo
 342
 343 dopt_OutName :: DynFlags -> String
 344 dopt_OutName = hscOutName
 345
 346 data HscLang
 347   = HscC
 348   | HscAsm
 349   | HscJava
 350   | HscInterpreted
 351     deriving (Eq, Show)
 352
 353 dopt_HscLang :: DynFlags -> HscLang
 354 dopt_HscLang = hscLang
 355 \end{code}
 356
 357 %************************************************************************
 358 %*                                                                      *
 359 \subsection{Classifying command-line options}
 360 %*                                                                      *
 361 %************************************************************************
 362
 363 \begin{code}
 364 -- v_Statis_hsc_opts is here to avoid a circular dependency with
 365 -- main/DriverState.
 366 GLOBAL_VAR(v_Static_hsc_opts, [], [String])
 367
 368 lookUp           :: FAST_STRING -> Bool
 369 lookup_int       :: String -> Maybe Int
 370 lookup_def_int   :: String -> Int -> Int
 371 lookup_def_float :: String -> Float -> Float
 372 lookup_str       :: String -> Maybe String
 373
 374 unpacked_static_opts = unsafePerformIO (readIORef v_Static_hsc_opts)
 375 packed_static_opts   = map _PK_ unpacked_static_opts
 376
 377 lookUp     sw = sw `elem` packed_static_opts
 378
 379 lookup_str sw = firstJust (map (startsWith sw) unpacked_static_opts)
 380
 381 lookup_int sw = case (lookup_str sw) of
 382                   Nothing -> Nothing
 383                   Just xx -> Just (read xx)
 384
 385 lookup_def_int sw def = case (lookup_str sw) of
 386                             Nothing -> def              -- Use default
 387                             Just xx -> read xx
 388
 389 lookup_def_float sw def = case (lookup_str sw) of
 390                             Nothing -> def              -- Use default
 391                             Just xx -> read xx
 392
 393
 394 {-
 395  Putting the compiler options into temporary at-files
 396  may turn out to be necessary later on if we turn hsc into
 397  a pure Win32 application where I think there's a command-line
 398  length limit of 255. unpacked_opts understands the @ option.
 399
 400 unpacked_opts :: [String]
 401 unpacked_opts =
 402   concat $
 403   map (expandAts) $
 404   map _UNPK_ argv  -- NOT ARGV any more: v_Static_hsc_opts
 405   where
 406    expandAts ('@':fname) = words (unsafePerformIO (readFile fname))
 407    expandAts l = [l]
 408 -}
 409 \end{code}
 410
 411 %************************************************************************
 412 %*                                                                      *
 413 \subsection{Static options}
 414 %*                                                                      *
 415 %************************************************************************
 416
 417 \begin{code}
 418 -- debugging opts
 419 opt_PprStyle_NoPrags            = lookUp  SLIT("-dppr-noprags")
 420 opt_PprStyle_Debug              = lookUp  SLIT("-dppr-debug")
 421 opt_PprStyle_RawTypes           = lookUp  SLIT("-dppr-rawtypes")
 422 opt_PprUserLength               = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
 423
 424 -- profiling opts
 425 opt_AutoSccsOnAllToplevs        = lookUp  SLIT("-fauto-sccs-on-all-toplevs")
 426 opt_AutoSccsOnExportedToplevs   = lookUp  SLIT("-fauto-sccs-on-exported-toplevs")
 427 opt_AutoSccsOnIndividualCafs    = lookUp  SLIT("-fauto-sccs-on-individual-cafs")
 428 opt_AutoSccsOnDicts             = lookUp  SLIT("-fauto-sccs-on-dicts")
 429 opt_SccProfilingOn              = lookUp  SLIT("-fscc-profiling")
 430 opt_DoTickyProfiling            = lookUp  SLIT("-fticky-ticky")
 431
 432 -- language opts
 433 opt_AllStrict                   = lookUp  SLIT("-fall-strict")
 434 opt_NoMonomorphismRestriction   = lookUp  SLIT("-fno-monomorphism-restriction")
 435 opt_DictsStrict                 = lookUp  SLIT("-fdicts-strict")
 436 opt_IrrefutableTuples           = lookUp  SLIT("-firrefutable-tuples")
 437 opt_MaxContextReductionDepth    = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
 438 opt_NumbersStrict               = lookUp  SLIT("-fnumbers-strict")
 439 opt_Parallel                    = lookUp  SLIT("-fparallel")
 440 opt_SMP                         = lookUp  SLIT("-fsmp")
 441
 442 -- optimisation opts
 443 opt_NoMethodSharing             = lookUp  SLIT("-fno-method-sharing")
 444 opt_DoSemiTagging               = lookUp  SLIT("-fsemi-tagging")
 445 opt_FoldrBuildOn                = lookUp  SLIT("-ffoldr-build-on")
 446 opt_LiberateCaseThreshold       = lookup_def_int "-fliberate-case-threshold" (10::Int)
 447 opt_StgDoLetNoEscapes           = lookUp  SLIT("-flet-no-escape")
 448 opt_UnfoldCasms                 = lookUp SLIT("-funfold-casms-in-hi-file")
 449 opt_UsageSPOn                   = lookUp  SLIT("-fusagesp-on")
 450 opt_UnboxStrictFields           = lookUp  SLIT("-funbox-strict-fields")
 451
 452 {-
 453    The optional '-inpackage=P' flag tells what package
 454    we are compiling this module for.
 455    The Prelude, for example is compiled with '-inpackage prelude'
 456 -}
 457 opt_InPackage                   = case lookup_str "-inpackage=" of
 458                                     Just p  -> _PK_ p
 459                                     Nothing -> SLIT("Main")     -- The package name if none is specified
 460
 461 opt_EmitCExternDecls            = lookUp  SLIT("-femit-extern-decls")
 462 opt_EnsureSplittableC           = lookUp  SLIT("-fglobalise-toplev-names")
 463 opt_GranMacros                  = lookUp  SLIT("-fgransim")
 464 opt_HiVersion                   = read cProjectVersionInt :: Int
 465 opt_HistorySize                 = lookup_def_int "-fhistory-size" 20
 466 opt_IgnoreAsserts               = lookUp  SLIT("-fignore-asserts")
 467 opt_IgnoreIfacePragmas          = lookUp  SLIT("-fignore-interface-pragmas")
 468 opt_NoHiCheck                   = lookUp  SLIT("-fno-hi-version-check")
 469 opt_OmitBlackHoling             = lookUp  SLIT("-dno-black-holing")
 470 opt_OmitInterfacePragmas        = lookUp  SLIT("-fomit-interface-pragmas")
 471 opt_KeepStgTypes                = lookUp  SLIT("-fkeep-stg-types")
 472
 473 -- Simplifier switches
 474 opt_SimplNoPreInlining          = lookUp SLIT("-fno-pre-inlining")
 475         -- NoPreInlining is there just to see how bad things
 476         -- get if you don't do it!
 477 opt_SimplDoEtaReduction         = lookUp SLIT("-fdo-eta-reduction")
 478 opt_SimplDoLambdaEtaExpansion   = lookUp SLIT("-fdo-lambda-eta-expansion")
 479 opt_SimplCaseOfCase             = lookUp SLIT("-fcase-of-case")
 480 opt_SimplCaseMerge              = lookUp SLIT("-fcase-merge")
 481 opt_SimplPedanticBottoms        = lookUp SLIT("-fpedantic-bottoms")
 482 opt_SimplExcessPrecision        = lookUp SLIT("-fexcess-precision")
 483
 484 -- Unfolding control
 485 opt_UF_HiFileThreshold          = lookup_def_int "-funfolding-interface-threshold" (45::Int)
 486 opt_UF_CreationThreshold        = lookup_def_int "-funfolding-creation-threshold"  (45::Int)
 487 opt_UF_UseThreshold             = lookup_def_int "-funfolding-use-threshold"       (8::Int)     -- Discounts can be big
 488 opt_UF_FunAppDiscount           = lookup_def_int "-funfolding-fun-discount"        (6::Int)     -- It's great to inline a fn
 489 opt_UF_KeenessFactor            = lookup_def_float "-funfolding-keeness-factor"    (1.5::Float)
 490 opt_UF_UpdateInPlace            = lookUp  SLIT("-funfolding-update-in-place")
 491
 492 opt_UF_CheapOp  = ( 1 :: Int)   -- Only one instruction; and the args are charged for
 493 opt_UF_DearOp   = ( 4 :: Int)
 494
 495 opt_NoPruneDecls                = lookUp SLIT("-fno-prune-decls")
 496 opt_NoPruneTyDecls              = lookUp SLIT("-fno-prune-tydecls")
 497 opt_Static                      = lookUp SLIT("-static")
 498 opt_Unregisterised              = lookUp SLIT("-funregisterised")
 499 \end{code}
 500
 501 %************************************************************************
 502 %*                                                                      *
 503 \subsection{List of static hsc flags}
 504 %*                                                                      *
 505 %************************************************************************
 506
 507 \begin{code}
 508 isStaticHscFlag f =
 509   f `elem` [
 510         "fauto-sccs-on-all-toplevs",
 511         "fauto-sccs-on-exported-toplevs",
 512         "fauto-sccs-on-individual-cafs",
 513         "fauto-sccs-on-dicts",
 514         "fscc-profiling",
 515         "fticky-ticky",
 516         "fall-strict",
 517         "fdicts-strict",
 518         "firrefutable-tuples",
 519         "fnumbers-strict",
 520         "fparallel",
 521         "fsmp",
 522         "fsemi-tagging",
 523         "ffoldr-build-on",
 524         "flet-no-escape",
 525         "funfold-casms-in-hi-file",
 526         "fusagesp-on",
 527         "funbox-strict-fields",
 528         "femit-extern-decls",
 529         "fglobalise-toplev-names",
 530         "fgransim",
 531         "fignore-asserts",
 532         "fignore-interface-pragmas",
 533         "fno-hi-version-check",
 534         "dno-black-holing",
 535         "fno-method-sharing",
 536         "fno-monomorphism-restriction",
 537         "fomit-interface-pragmas",
 538         "fkeep-stg-types",
 539         "fno-pre-inlining",
 540         "fdo-eta-reduction",
 541         "fdo-lambda-eta-expansion",
 542         "fcase-of-case",
 543         "fcase-merge",
 544         "fpedantic-bottoms",
 545         "fexcess-precision",
 546         "funfolding-update-in-place",
 547         "freport-compile",
 548         "fno-prune-decls",
 549         "fno-prune-tydecls",
 550         "static",
 551         "funregisterised"
 552         ]
 553   || any (flip prefixMatch f) [
 554         "fcontext-stack",
 555         "fliberate-case-threshold",
 556         "fhistory-size",
 557         "funfolding-interface-threshold",
 558         "funfolding-creation-threshold",
 559         "funfolding-use-threshold",
 560         "funfolding-fun-discount",
 561         "funfolding-keeness-factor"
 562      ]
 563 \end{code}
 564
 565 %************************************************************************
 566 %*                                                                      *
 567 \subsection{Switch ordering}
 568 %*                                                                      *
 569 %************************************************************************
 570
 571 These things behave just like enumeration types.
 572
 573 \begin{code}
 574 instance Eq SimplifierSwitch where
 575     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
 576
 577 instance Ord SimplifierSwitch where
 578     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
 579     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
 580
 581
 582 tagOf_SimplSwitch (SimplInlinePhase _)          = _ILIT(1)
 583 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(2)
 584 tagOf_SimplSwitch DontApplyRules                = _ILIT(3)
 585 tagOf_SimplSwitch SimplLetToCase                = _ILIT(4)
 586 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(5)
 587
 588 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 589
 590 lAST_SIMPL_SWITCH_TAG = 5
 591 \end{code}
 592
 593 %************************************************************************
 594 %*                                                                      *
 595 \subsection{Switch lookup}
 596 %*                                                                      *
 597 %************************************************************************
 598
 599 \begin{code}
 600 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 601 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
 602                                         -- in the list; defaults right at the end.
 603   = let
 604         tidied_on_switches = foldl rm_dups [] on_switches
 605                 -- The fold*l* ensures that we keep the latest switches;
 606                 -- ie the ones that occur earliest in the list.
 607
 608         sw_tbl :: Array Int SwitchResult
 609         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
 610                         all_undefined)
 611                  // defined_elems
 612
 613         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
 614
 615         defined_elems = map mk_assoc_elem tidied_on_switches
 616     in
 617     -- (avoid some unboxing, bounds checking, and other horrible things:)
 618 #if __GLASGOW_HASKELL__ < 405
 619     case sw_tbl of { Array bounds_who_needs_'em stuff ->
 620 #else
 621     case sw_tbl of { Array _ _ stuff ->
 622 #endif
 623     \ switch ->
 624         case (indexArray# stuff (tagOf_SimplSwitch switch)) of
 625 #if __GLASGOW_HASKELL__ < 400
 626           Lift v -> v
 627 #elif __GLASGOW_HASKELL__ < 403
 628           (# _, v #) -> v
 629 #else
 630           (# v #) -> v
 631 #endif
 632     }
 633   where
 634     mk_assoc_elem k@(MaxSimplifierIterations lvl)
 635         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
 636     mk_assoc_elem k@(SimplInlinePhase n)
 637         = (iBox (tagOf_SimplSwitch k), SwInt n)
 638     mk_assoc_elem k
 639         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 640
 641     -- cannot have duplicates if we are going to use the array thing
 642     rm_dups switches_so_far switch
 643       = if switch `is_elem` switches_so_far
 644         then switches_so_far
 645         else switch : switches_so_far
 646       where
 647         sw `is_elem` []     = False
 648         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
 649                             || sw `is_elem` ss
 650 \end{code}
 651
 652
 653 %************************************************************************
 654 %*                                                                      *
 655 \subsection{Misc functions for command-line options}
 656 %*                                                                      *
 657 %************************************************************************
 658
 659
 660 \begin{code}
 661 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 662
 663 switchIsOn lookup_fn switch
 664   = case (lookup_fn switch) of
 665       SwBool False -> False
 666       _            -> True
 667
 668 intSwitchSet :: (switch -> SwitchResult)
 669              -> (Int -> switch)
 670              -> Maybe Int
 671
 672 intSwitchSet lookup_fn switch
 673   = case (lookup_fn (switch (panic "intSwitchSet"))) of
 674       SwInt int -> Just int
 675       _         -> Nothing
 676 \end{code}
 677
 678 \begin{code}
 679 startsWith :: String -> String -> Maybe String
 680 -- startsWith pfx (pfx++rest) = Just rest
 681
 682 startsWith []     str = Just str
 683 startsWith (c:cs) (s:ss)
 684   = if c /= s then Nothing else startsWith cs ss
 685 startsWith  _     []  = Nothing
 686
 687 endsWith  :: String -> String -> Maybe String
 688 endsWith cs ss
 689   = case (startsWith (reverse cs) (reverse ss)) of
 690       Nothing -> Nothing
 691       Just rs -> Just (reverse rs)
 692 \end{code}