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