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