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