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