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_RuntimeTypes,
  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   | HscILX
 364   | HscInterpreted
 365     deriving (Eq, Show)
 366
 367 dopt_HscLang :: DynFlags -> HscLang
 368 dopt_HscLang = hscLang
 369 \end{code}
 370
 371 %************************************************************************
 372 %*                                                                      *
 373 \subsection{Warnings}
 374 %*                                                                      *
 375 %************************************************************************
 376
 377 \begin{code}
 378 standardWarnings
 379     = [ Opt_WarnDeprecations,
 380         Opt_WarnOverlappingPatterns,
 381         Opt_WarnMissingFields,
 382         Opt_WarnMissingMethods,
 383         Opt_WarnDuplicateExports
 384       ]
 385
 386 minusWOpts
 387     = standardWarnings ++
 388       [ Opt_WarnUnusedBinds,
 389         Opt_WarnUnusedMatches,
 390         Opt_WarnUnusedImports,
 391         Opt_WarnIncompletePatterns,
 392         Opt_WarnMisc
 393       ]
 394
 395 minusWallOpts
 396     = minusWOpts ++
 397       [ Opt_WarnTypeDefaults,
 398         Opt_WarnNameShadowing,
 399         Opt_WarnMissingSigs,
 400         Opt_WarnHiShadows
 401       ]
 402 \end{code}
 403
 404 %************************************************************************
 405 %*                                                                      *
 406 \subsection{Classifying command-line options}
 407 %*                                                                      *
 408 %************************************************************************
 409
 410 \begin{code}
 411 -- v_Statis_hsc_opts is here to avoid a circular dependency with
 412 -- main/DriverState.
 413 GLOBAL_VAR(v_Static_hsc_opts, [], [String])
 414
 415 lookUp           :: FAST_STRING -> Bool
 416 lookup_int       :: String -> Maybe Int
 417 lookup_def_int   :: String -> Int -> Int
 418 lookup_def_float :: String -> Float -> Float
 419 lookup_str       :: String -> Maybe String
 420
 421 unpacked_static_opts = unsafePerformIO (readIORef v_Static_hsc_opts)
 422 packed_static_opts   = map _PK_ unpacked_static_opts
 423
 424 lookUp     sw = sw `elem` packed_static_opts
 425
 426 lookup_str sw = firstJust (map (startsWith sw) unpacked_static_opts)
 427
 428 lookup_int sw = case (lookup_str sw) of
 429                   Nothing -> Nothing
 430                   Just xx -> Just (read xx)
 431
 432 lookup_def_int sw def = case (lookup_str sw) of
 433                             Nothing -> def              -- Use default
 434                             Just xx -> read xx
 435
 436 lookup_def_float sw def = case (lookup_str sw) of
 437                             Nothing -> def              -- Use default
 438                             Just xx -> read xx
 439
 440
 441 {-
 442  Putting the compiler options into temporary at-files
 443  may turn out to be necessary later on if we turn hsc into
 444  a pure Win32 application where I think there's a command-line
 445  length limit of 255. unpacked_opts understands the @ option.
 446
 447 unpacked_opts :: [String]
 448 unpacked_opts =
 449   concat $
 450   map (expandAts) $
 451   map _UNPK_ argv  -- NOT ARGV any more: v_Static_hsc_opts
 452   where
 453    expandAts ('@':fname) = words (unsafePerformIO (readFile fname))
 454    expandAts l = [l]
 455 -}
 456 \end{code}
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection{Static options}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 \begin{code}
 465 -- debugging opts
 466 opt_PprStyle_NoPrags            = lookUp  SLIT("-dppr-noprags")
 467 opt_PprStyle_Debug              = lookUp  SLIT("-dppr-debug")
 468 opt_PprStyle_RawTypes           = lookUp  SLIT("-dppr-rawtypes")
 469 opt_PprUserLength               = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
 470
 471 -- profiling opts
 472 opt_AutoSccsOnAllToplevs        = lookUp  SLIT("-fauto-sccs-on-all-toplevs")
 473 opt_AutoSccsOnExportedToplevs   = lookUp  SLIT("-fauto-sccs-on-exported-toplevs")
 474 opt_AutoSccsOnIndividualCafs    = lookUp  SLIT("-fauto-sccs-on-individual-cafs")
 475 opt_AutoSccsOnDicts             = lookUp  SLIT("-fauto-sccs-on-dicts")
 476 opt_SccProfilingOn              = lookUp  SLIT("-fscc-profiling")
 477 opt_DoTickyProfiling            = lookUp  SLIT("-fticky-ticky")
 478
 479 -- language opts
 480 opt_AllStrict                   = lookUp  SLIT("-fall-strict")
 481 opt_NoMonomorphismRestriction   = lookUp  SLIT("-fno-monomorphism-restriction")
 482 opt_DictsStrict                 = lookUp  SLIT("-fdicts-strict")
 483 opt_IrrefutableTuples           = lookUp  SLIT("-firrefutable-tuples")
 484 opt_MaxContextReductionDepth    = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
 485 opt_NumbersStrict               = lookUp  SLIT("-fnumbers-strict")
 486 opt_Parallel                    = lookUp  SLIT("-fparallel")
 487 opt_SMP                         = lookUp  SLIT("-fsmp")
 488
 489 -- optimisation opts
 490 opt_NoMethodSharing             = lookUp  SLIT("-fno-method-sharing")
 491 opt_DoSemiTagging               = lookUp  SLIT("-fsemi-tagging")
 492 opt_FoldrBuildOn                = lookUp  SLIT("-ffoldr-build-on")
 493 opt_LiberateCaseThreshold       = lookup_def_int "-fliberate-case-threshold" (10::Int)
 494 opt_StgDoLetNoEscapes           = lookUp  SLIT("-flet-no-escape")
 495 opt_UnfoldCasms                 = lookUp  SLIT("-funfold-casms-in-hi-file")
 496 opt_UsageSPOn                   = lookUp  SLIT("-fusagesp-on")
 497 opt_UnboxStrictFields           = lookUp  SLIT("-funbox-strict-fields")
 498
 499 {-
 500    The optional '-inpackage=P' flag tells what package
 501    we are compiling this module for.
 502    The Prelude, for example is compiled with '-inpackage std'
 503 -}
 504 opt_InPackage                   = case lookup_str "-inpackage=" of
 505                                     Just p  -> _PK_ p
 506                                     Nothing -> SLIT("Main")     -- The package name if none is specified
 507
 508 opt_EmitCExternDecls            = lookUp  SLIT("-femit-extern-decls")
 509 opt_EnsureSplittableC           = lookUp  SLIT("-fglobalise-toplev-names")
 510 opt_GranMacros                  = lookUp  SLIT("-fgransim")
 511 opt_HiVersion                   = read cProjectVersionInt :: Int
 512 opt_HistorySize                 = lookup_def_int "-fhistory-size" 20
 513 opt_IgnoreAsserts               = lookUp  SLIT("-fignore-asserts")
 514 opt_IgnoreIfacePragmas          = lookUp  SLIT("-fignore-interface-pragmas")
 515 opt_NoHiCheck                   = lookUp  SLIT("-fno-hi-version-check")
 516 opt_OmitBlackHoling             = lookUp  SLIT("-dno-black-holing")
 517 opt_OmitInterfacePragmas        = lookUp  SLIT("-fomit-interface-pragmas")
 518 opt_RuntimeTypes                = lookUp  SLIT("-fruntime-types")
 519
 520 -- Simplifier switches
 521 opt_SimplNoPreInlining          = lookUp  SLIT("-fno-pre-inlining")
 522         -- NoPreInlining is there just to see how bad things
 523         -- get if you don't do it!
 524 opt_SimplDoEtaReduction         = lookUp  SLIT("-fdo-eta-reduction")
 525 opt_SimplDoLambdaEtaExpansion   = lookUp  SLIT("-fdo-lambda-eta-expansion")
 526 opt_SimplCaseMerge              = lookUp  SLIT("-fcase-merge")
 527 opt_SimplExcessPrecision        = lookUp  SLIT("-fexcess-precision")
 528
 529 -- Unfolding control
 530 opt_UF_CreationThreshold        = lookup_def_int "-funfolding-creation-threshold"  (45::Int)
 531 opt_UF_UseThreshold             = lookup_def_int "-funfolding-use-threshold"       (8::Int)     -- Discounts can be big
 532 opt_UF_FunAppDiscount           = lookup_def_int "-funfolding-fun-discount"        (6::Int)     -- It's great to inline a fn
 533 opt_UF_KeenessFactor            = lookup_def_float "-funfolding-keeness-factor"    (1.5::Float)
 534 opt_UF_UpdateInPlace            = lookUp  SLIT("-funfolding-update-in-place")
 535
 536 opt_UF_CheapOp  = ( 1 :: Int)   -- Only one instruction; and the args are charged for
 537 opt_UF_DearOp   = ( 4 :: Int)
 538
 539 opt_NoPruneDecls                = lookUp  SLIT("-fno-prune-decls")
 540 opt_NoPruneTyDecls              = lookUp  SLIT("-fno-prune-tydecls")
 541 opt_Static                      = lookUp  SLIT("-static")
 542 opt_Unregisterised              = lookUp  SLIT("-funregisterised")
 543 \end{code}
 544
 545 %************************************************************************
 546 %*                                                                      *
 547 \subsection{List of static hsc flags}
 548 %*                                                                      *
 549 %************************************************************************
 550
 551 \begin{code}
 552 isStaticHscFlag f =
 553   f `elem` [
 554         "fauto-sccs-on-all-toplevs",
 555         "fauto-sccs-on-exported-toplevs",
 556         "fauto-sccs-on-individual-cafs",
 557         "fauto-sccs-on-dicts",
 558         "fscc-profiling",
 559         "fticky-ticky",
 560         "fall-strict",
 561         "fdicts-strict",
 562         "firrefutable-tuples",
 563         "fnumbers-strict",
 564         "fparallel",
 565         "fsmp",
 566         "fsemi-tagging",
 567         "ffoldr-build-on",
 568         "flet-no-escape",
 569         "funfold-casms-in-hi-file",
 570         "fusagesp-on",
 571         "funbox-strict-fields",
 572         "femit-extern-decls",
 573         "fglobalise-toplev-names",
 574         "fgransim",
 575         "fignore-asserts",
 576         "fignore-interface-pragmas",
 577         "fno-hi-version-check",
 578         "dno-black-holing",
 579         "fno-method-sharing",
 580         "fno-monomorphism-restriction",
 581         "fomit-interface-pragmas",
 582         "fkeep-stg-types",
 583         "fno-pre-inlining",
 584         "fdo-eta-reduction",
 585         "fdo-lambda-eta-expansion",
 586         "fcase-merge",
 587         "fexcess-precision",
 588         "funfolding-update-in-place",
 589         "fno-prune-decls",
 590         "fno-prune-tydecls",
 591         "static",
 592         "funregisterised"
 593         ]
 594   || any (flip prefixMatch f) [
 595         "fcontext-stack",
 596         "fliberate-case-threshold",
 597         "fhistory-size",
 598         "funfolding-creation-threshold",
 599         "funfolding-use-threshold",
 600         "funfolding-fun-discount",
 601         "funfolding-keeness-factor"
 602      ]
 603 \end{code}
 604
 605 %************************************************************************
 606 %*                                                                      *
 607 \subsection{Switch ordering}
 608 %*                                                                      *
 609 %************************************************************************
 610
 611 These things behave just like enumeration types.
 612
 613 \begin{code}
 614 instance Eq SimplifierSwitch where
 615     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
 616
 617 instance Ord SimplifierSwitch where
 618     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
 619     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
 620
 621
 622 tagOf_SimplSwitch (SimplInlinePhase _)          = _ILIT(1)
 623 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(2)
 624 tagOf_SimplSwitch DontApplyRules                = _ILIT(3)
 625 tagOf_SimplSwitch SimplLetToCase                = _ILIT(4)
 626 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(5)
 627
 628 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 629
 630 lAST_SIMPL_SWITCH_TAG = 5
 631 \end{code}
 632
 633 %************************************************************************
 634 %*                                                                      *
 635 \subsection{Switch lookup}
 636 %*                                                                      *
 637 %************************************************************************
 638
 639 \begin{code}
 640 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 641 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
 642                                         -- in the list; defaults right at the end.
 643   = let
 644         tidied_on_switches = foldl rm_dups [] on_switches
 645                 -- The fold*l* ensures that we keep the latest switches;
 646                 -- ie the ones that occur earliest in the list.
 647
 648         sw_tbl :: Array Int SwitchResult
 649         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
 650                         all_undefined)
 651                  // defined_elems
 652
 653         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
 654
 655         defined_elems = map mk_assoc_elem tidied_on_switches
 656     in
 657     -- (avoid some unboxing, bounds checking, and other horrible things:)
 658 #if __GLASGOW_HASKELL__ < 405
 659     case sw_tbl of { Array bounds_who_needs_'em stuff ->
 660 #else
 661     case sw_tbl of { Array _ _ stuff ->
 662 #endif
 663     \ switch ->
 664         case (indexArray# stuff (tagOf_SimplSwitch switch)) of
 665 #if __GLASGOW_HASKELL__ < 400
 666           Lift v -> v
 667 #elif __GLASGOW_HASKELL__ < 403
 668           (# _, v #) -> v
 669 #else
 670           (# v #) -> v
 671 #endif
 672     }
 673   where
 674     mk_assoc_elem k@(MaxSimplifierIterations lvl)
 675         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
 676     mk_assoc_elem k@(SimplInlinePhase n)
 677         = (iBox (tagOf_SimplSwitch k), SwInt n)
 678     mk_assoc_elem k
 679         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 680
 681     -- cannot have duplicates if we are going to use the array thing
 682     rm_dups switches_so_far switch
 683       = if switch `is_elem` switches_so_far
 684         then switches_so_far
 685         else switch : switches_so_far
 686       where
 687         sw `is_elem` []     = False
 688         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
 689                             || sw `is_elem` ss
 690 \end{code}
 691
 692
 693 %************************************************************************
 694 %*                                                                      *
 695 \subsection{Misc functions for command-line options}
 696 %*                                                                      *
 697 %************************************************************************
 698
 699
 700 \begin{code}
 701 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 702
 703 switchIsOn lookup_fn switch
 704   = case (lookup_fn switch) of
 705       SwBool False -> False
 706       _            -> True
 707
 708 intSwitchSet :: (switch -> SwitchResult)
 709              -> (Int -> switch)
 710              -> Maybe Int
 711
 712 intSwitchSet lookup_fn switch
 713   = case (lookup_fn (switch (panic "intSwitchSet"))) of
 714       SwInt int -> Just int
 715       _         -> Nothing
 716 \end{code}
 717
 718 \begin{code}
 719 startsWith :: String -> String -> Maybe String
 720 -- startsWith pfx (pfx++rest) = Just rest
 721
 722 startsWith []     str = Just str
 723 startsWith (c:cs) (s:ss)
 724   = if c /= s then Nothing else startsWith cs ss
 725 startsWith  _     []  = Nothing
 726
 727 endsWith  :: String -> String -> Maybe String
 728 endsWith cs ss
 729   = case (startsWith (reverse cs) (reverse ss)) of
 730       Nothing -> Nothing
 731       Just rs -> Just (reverse rs)
 732 \end{code}