compiler/simplCore/CoreMonad.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[CoreMonad]{The core pipeline monad}
   5
   6 \begin{code}
   7 {-# LANGUAGE UndecidableInstances #-}
   8
   9 module CoreMonad (
  10     -- * Configuration of the core-to-core passes
  11     CoreToDo(..),
  12     SimplifierMode(..),
  13     FloatOutSwitches(..),
  14     getCoreToDo, dumpSimplPhase,
  15
  16     -- * Counting
  17     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
  18     pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
  19
  20     -- * The monad
  21     CoreM, runCoreM,
  22
  23     -- ** Reading from the monad
  24     getHscEnv, getRuleBase, getModule,
  25     getDynFlags, getOrigNameCache,
  26
  27     -- ** Writing to the monad
  28     addSimplCount,
  29
  30     -- ** Lifting into the monad
  31     liftIO, liftIOWithCount,
  32     liftIO1, liftIO2, liftIO3, liftIO4,
  33
  34     -- ** Dealing with annotations
  35     getAnnotations, getFirstAnnotations,
  36
  37     -- ** Debug output
  38     showPass, endPass, endIteration, dumpIfSet,
  39
  40     -- ** Screen output
  41     putMsg, putMsgS, errorMsg, errorMsgS,
  42     fatalErrorMsg, fatalErrorMsgS,
  43     debugTraceMsg, debugTraceMsgS,
  44     dumpIfSet_dyn,
  45
  46 #ifdef GHCI
  47     -- * Getting 'Name's
  48     thNameToGhcName
  49 #endif
  50   ) where
  51
  52 #ifdef GHCI
  53 import Name( Name )
  54 #endif
  55 import CoreSyn
  56 import PprCore
  57 import CoreUtils
  58 import CoreLint         ( lintCoreBindings )
  59 import PrelNames        ( iNTERACTIVE )
  60 import HscTypes
  61 import Module           ( PackageId, Module )
  62 import DynFlags
  63 import StaticFlags
  64 import Rules            ( RuleBase )
  65 import BasicTypes       ( CompilerPhase(..) )
  66 import Annotations
  67 import Id               ( Id )
  68
  69 import IOEnv hiding     ( liftIO, failM, failWithM )
  70 import qualified IOEnv  ( liftIO )
  71 import TcEnv            ( tcLookupGlobal )
  72 import TcRnMonad        ( TcM, initTc )
  73
  74 import Outputable
  75 import FastString
  76 import qualified ErrUtils as Err
  77 import Bag
  78 import Maybes
  79 import UniqSupply
  80 import UniqFM       ( UniqFM, mapUFM, filterUFM )
  81 import MonadUtils
  82
  83 import Util             ( split )
  84 import Data.List        ( intersperse )
  85 import Data.Dynamic
  86 import Data.IORef
  87 import Data.Map (Map)
  88 import qualified Data.Map as Map
  89 import Data.Word
  90 import Control.Monad
  91
  92 import Prelude hiding   ( read )
  93
  94 #ifdef GHCI
  95 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
  96 import qualified Language.Haskell.TH as TH
  97 #endif
  98 \end{code}
  99
 100 %************************************************************************
 101 %*                                                                      *
 102                        Debug output
 103 %*                                                                      *
 104 %************************************************************************
 105
 106 These functions are not CoreM monad stuff, but they probably ought to
 107 be, and it makes a conveneint place.  place for them.  They print out
 108 stuff before and after core passes, and do Core Lint when necessary.
 109
 110 \begin{code}
 111 showPass :: DynFlags -> CoreToDo -> IO ()
 112 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
 113
 114 endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
 115 endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
 116
 117 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
 118 endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
 119 endIteration dflags pass n
 120   = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
 121                 (Just Opt_D_dump_simpl_iterations)
 122
 123 dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
 124 dumpIfSet dump_me pass extra_info doc
 125   = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
 126
 127 dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
 128             -> [CoreBind] -> [CoreRule] -> IO ()
 129 -- The "show_all" parameter says to print dump if -dverbose-core2core is on
 130 dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
 131   = do {  -- Report result size if required
 132           -- This has the side effect of forcing the intermediate to be evaluated
 133        ; Err.debugTraceMsg dflags 2 $
 134                 (text "    Result size =" <+> int (coreBindsSize binds))
 135
 136         -- Report verbosely, if required
 137        ; let pass_name = showSDoc (ppr pass <+> extra_info)
 138              dump_doc  = pprCoreBindings binds
 139                          $$ ppUnless (null rules) pp_rules
 140
 141        ; case mb_dump_flag of
 142             Nothing        -> return ()
 143             Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
 144                where
 145                  dump_flags | show_all  = [dump_flag, Opt_D_verbose_core2core]
 146                             | otherwise = [dump_flag]
 147
 148         -- Type check
 149        ; when (dopt Opt_DoCoreLinting dflags) $
 150          do { let (warns, errs) = lintCoreBindings binds
 151             ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
 152             ; displayLintResults dflags pass warns errs binds  } }
 153   where
 154     pp_rules = vcat [ blankLine
 155                     , ptext (sLit "------ Local rules for imported ids --------")
 156                     , pprRules rules ]
 157
 158 displayLintResults :: DynFlags -> CoreToDo
 159                    -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
 160                    -> IO ()
 161 displayLintResults dflags pass warns errs binds
 162   | not (isEmptyBag errs)
 163   = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
 164                          , ptext (sLit "*** Offending Program ***")
 165                          , pprCoreBindings binds
 166                          , ptext (sLit "*** End of Offense ***") ])
 167        ; Err.ghcExit dflags 1 }
 168
 169   | not (isEmptyBag warns)
 170   , not (case pass of { CoreDesugar -> True; _ -> False })
 171         -- Suppress warnings after desugaring pass because some
 172         -- are legitimate. Notably, the desugarer generates instance
 173         -- methods with INLINE pragmas that form a mutually recursive
 174         -- group.  Only afer a round of simplification are they unravelled.
 175   , not opt_NoDebugOutput
 176   , showLintWarnings pass
 177   = printDump (banner "warnings" $$ Err.pprMessageBag warns)
 178
 179   | otherwise = return ()
 180   where
 181     banner string = ptext (sLit "*** Core Lint")      <+> text string
 182                     <+> ptext (sLit ": in result of") <+> ppr pass
 183                     <+> ptext (sLit "***")
 184
 185 showLintWarnings :: CoreToDo -> Bool
 186 -- Disable Lint warnings on the first simplifier pass, because
 187 -- there may be some INLINE knots still tied, which is tiresomely noisy
 188 showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
 189 showLintWarnings _ = True
 190 \end{code}
 191
 192
 193 %************************************************************************
 194 %*                                                                      *
 195               The CoreToDo type and related types
 196           Abstraction of core-to-core passes to run.
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 \begin{code}
 201 data CoreToDo           -- These are diff core-to-core passes,
 202                         -- which may be invoked in any order,
 203                         -- as many times as you like.
 204
 205   = CoreDoSimplify      -- The core-to-core simplifier.
 206         Int                    -- Max iterations
 207         SimplifierMode
 208
 209   | CoreDoFloatInwards
 210   | CoreDoFloatOutwards FloatOutSwitches
 211   | CoreLiberateCase
 212   | CoreDoPrintCore
 213   | CoreDoStaticArgs
 214   | CoreDoStrictness
 215   | CoreDoWorkerWrapper
 216   | CoreDoSpecialising
 217   | CoreDoSpecConstr
 218   | CoreDoGlomBinds
 219   | CoreCSE
 220   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
 221                                            -- matching this string
 222   | CoreDoVectorisation PackageId
 223   | CoreDoNothing                -- Useful when building up
 224   | CoreDoPasses [CoreToDo]      -- lists of these things
 225
 226   | CoreDesugar  -- Not strictly a core-to-core pass, but produces
 227                  -- Core output, and hence useful to pass to endPass
 228
 229   | CoreTidy
 230   | CorePrep
 231
 232 coreDumpFlag :: CoreToDo -> Maybe DynFlag
 233 coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
 234 coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
 235 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 236 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
 237 coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
 238 coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
 239 coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 240 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 241 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 242 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
 243 coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
 244 coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds
 245 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 246 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 247
 248 coreDumpFlag CoreDoPrintCore         = Nothing
 249 coreDumpFlag (CoreDoRuleCheck {})    = Nothing
 250 coreDumpFlag CoreDoNothing           = Nothing
 251 coreDumpFlag CoreDoGlomBinds         = Nothing
 252 coreDumpFlag (CoreDoPasses {})       = Nothing
 253
 254 instance Outputable CoreToDo where
 255   ppr (CoreDoSimplify n md)  = ptext (sLit "Simplifier")
 256                                <+> ppr md
 257                                  <+> ptext (sLit "max-iterations=") <> int n
 258   ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
 259   ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
 260   ppr CoreLiberateCase         = ptext (sLit "Liberate case")
 261   ppr CoreDoStaticArgs         = ptext (sLit "Static argument")
 262   ppr CoreDoStrictness         = ptext (sLit "Demand analysis")
 263   ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
 264   ppr CoreDoSpecialising       = ptext (sLit "Specialise")
 265   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
 266   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
 267   ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
 268   ppr CoreDesugar              = ptext (sLit "Desugar")
 269   ppr CoreTidy                 = ptext (sLit "Tidy Core")
 270   ppr CorePrep                 = ptext (sLit "CorePrep")
 271   ppr CoreDoPrintCore          = ptext (sLit "Print core")
 272   ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
 273   ppr CoreDoGlomBinds          = ptext (sLit "Glom binds")
 274   ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
 275   ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
 276 \end{code}
 277
 278 \begin{code}
 279 data SimplifierMode             -- See comments in SimplMonad
 280   = SimplMode
 281         { sm_names      :: [String] -- Name(s) of the phase
 282         , sm_phase      :: CompilerPhase
 283         , sm_rules      :: Bool     -- Whether RULES are enabled
 284         , sm_inline     :: Bool     -- Whether inlining is enabled
 285         , sm_case_case  :: Bool     -- Whether case-of-case is enabled
 286         , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
 287         }
 288
 289 instance Outputable SimplifierMode where
 290     ppr (SimplMode { sm_phase = p, sm_names = ss
 291                    , sm_rules = r, sm_inline = i
 292                    , sm_eta_expand = eta, sm_case_case = cc })
 293        = ptext (sLit "SimplMode") <+> braces (
 294          sep [ ptext (sLit "Phase =") <+> ppr p <+>
 295                brackets (text (concat $ intersperse "," ss)) <> comma
 296              , pp_flag i   (sLit "inline") <> comma
 297              , pp_flag r   (sLit "rules") <> comma
 298              , pp_flag eta (sLit "eta-expand") <> comma
 299              , pp_flag cc  (sLit "case-of-case") ])
 300          where
 301            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
 302 \end{code}
 303
 304
 305 \begin{code}
 306 data FloatOutSwitches = FloatOutSwitches {
 307   floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
 308                                    -- doing so will abstract over n or fewer
 309                                    -- value variables
 310                                    -- Nothing <=> float all lambdas to top level,
 311                                    --             regardless of how many free variables
 312                                    -- Just 0 is the vanilla case: float a lambda
 313                                    --    iff it has no free vars
 314
 315   floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
 316                                    --            even if they do not escape a lambda
 317   floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
 318                                             --            based on arity information.
 319   }
 320 instance Outputable FloatOutSwitches where
 321     ppr = pprFloatOutSwitches
 322
 323 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
 324 pprFloatOutSwitches sw
 325   = ptext (sLit "FOS") <+> (braces $
 326      sep $ punctuate comma $
 327      [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
 328      , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
 329      , ptext (sLit "PAPs =")   <+> ppr (floatOutPartialApplications sw) ])
 330 \end{code}
 331
 332
 333 %************************************************************************
 334 %*                                                                      *
 335            Generating the main optimisation pipeline
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 \begin{code}
 340 getCoreToDo :: DynFlags -> [CoreToDo]
 341 getCoreToDo dflags
 342   = core_todo
 343   where
 344     opt_level     = optLevel           dflags
 345     phases        = simplPhases        dflags
 346     max_iter      = maxSimplIterations dflags
 347     rule_check    = ruleCheck          dflags
 348     strictness    = dopt Opt_Strictness                   dflags
 349     full_laziness = dopt Opt_FullLaziness                 dflags
 350     do_specialise = dopt Opt_Specialise                   dflags
 351     do_float_in   = dopt Opt_FloatIn                      dflags
 352     cse           = dopt Opt_CSE                          dflags
 353     spec_constr   = dopt Opt_SpecConstr                   dflags
 354     liberate_case = dopt Opt_LiberateCase                 dflags
 355     static_args   = dopt Opt_StaticArgumentTransformation dflags
 356     rules_on      = dopt Opt_EnableRewriteRules           dflags
 357     eta_expand_on = dopt Opt_DoLambdaEtaExpansion         dflags
 358
 359     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
 360
 361     maybe_strictness_before phase
 362       = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
 363
 364     base_mode = SimplMode { sm_phase      = panic "base_mode"
 365                           , sm_names      = []
 366                           , sm_rules      = rules_on
 367                           , sm_eta_expand = eta_expand_on
 368                           , sm_inline     = True
 369                           , sm_case_case  = True }
 370
 371     simpl_phase phase names iter
 372       = CoreDoPasses
 373           [ maybe_strictness_before phase
 374           , CoreDoSimplify iter
 375                 (base_mode { sm_phase = Phase phase
 376                            , sm_names = names })
 377
 378           , maybe_rule_check (Phase phase)
 379           ]
 380
 381     vectorisation
 382       = runWhen (dopt Opt_Vectorise dflags)
 383         $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
 384
 385
 386                 -- By default, we have 2 phases before phase 0.
 387
 388                 -- Want to run with inline phase 2 after the specialiser to give
 389                 -- maximum chance for fusion to work before we inline build/augment
 390                 -- in phase 1.  This made a difference in 'ansi' where an
 391                 -- overloaded function wasn't inlined till too late.
 392
 393                 -- Need phase 1 so that build/augment get
 394                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 395                 -- strictness in the function sumcode' if augment is not inlined
 396                 -- before strictness analysis runs
 397     simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
 398                                 | phase <- [phases, phases-1 .. 1] ]
 399
 400
 401         -- initial simplify: mk specialiser happy: minimum effort please
 402     simpl_gently = CoreDoSimplify max_iter
 403                        (base_mode { sm_phase = InitialPhase
 404                                   , sm_names = ["Gentle"]
 405                                   , sm_rules = True     -- Note [RULEs enabled in SimplGently]
 406                                   , sm_inline = False
 407                                   , sm_case_case = False })
 408                           -- Don't do case-of-case transformations.
 409                           -- This makes full laziness work better
 410
 411     core_todo =
 412      if opt_level == 0 then
 413        [vectorisation,
 414         simpl_phase 0 ["final"] max_iter]
 415      else {- opt_level >= 1 -} [
 416
 417     -- We want to do the static argument transform before full laziness as it
 418     -- may expose extra opportunities to float things outwards. However, to fix
 419     -- up the output of the transformation we need at do at least one simplify
 420     -- after this before anything else
 421         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
 422
 423         -- We run vectorisation here for now, but we might also try to run
 424         -- it later
 425         vectorisation,
 426
 427         -- initial simplify: mk specialiser happy: minimum effort please
 428         simpl_gently,
 429
 430         -- Specialisation is best done before full laziness
 431         -- so that overloaded functions have all their dictionary lambdas manifest
 432         runWhen do_specialise CoreDoSpecialising,
 433
 434         runWhen full_laziness $
 435            CoreDoFloatOutwards FloatOutSwitches {
 436                                  floatOutLambdas   = Just 0,
 437                                  floatOutConstants = True,
 438                                  floatOutPartialApplications = False },
 439                 -- Was: gentleFloatOutSwitches
 440                 --
 441                 -- I have no idea why, but not floating constants to
 442                 -- top level is very bad in some cases.
 443                 --
 444                 -- Notably: p_ident in spectral/rewrite
 445                 --          Changing from "gentle" to "constantsOnly"
 446                 --          improved rewrite's allocation by 19%, and
 447                 --          made 0.0% difference to any other nofib
 448                 --          benchmark
 449                 --
 450                 -- Not doing floatOutPartialApplications yet, we'll do
 451                 -- that later on when we've had a chance to get more
 452                 -- accurate arity information.  In fact it makes no
 453                 -- difference at all to performance if we do it here,
 454                 -- but maybe we save some unnecessary to-and-fro in
 455                 -- the simplifier.
 456
 457         runWhen do_float_in CoreDoFloatInwards,
 458
 459         simpl_phases,
 460
 461                 -- Phase 0: allow all Ids to be inlined now
 462                 -- This gets foldr inlined before strictness analysis
 463
 464                 -- At least 3 iterations because otherwise we land up with
 465                 -- huge dead expressions because of an infelicity in the
 466                 -- simpifier.
 467                 --      let k = BIG in foldr k z xs
 468                 -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
 469                 -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
 470                 -- Don't stop now!
 471         simpl_phase 0 ["main"] (max max_iter 3),
 472
 473         runWhen strictness (CoreDoPasses [
 474                 CoreDoStrictness,
 475                 CoreDoWorkerWrapper,
 476                 CoreDoGlomBinds,
 477                 simpl_phase 0 ["post-worker-wrapper"] max_iter
 478                 ]),
 479
 480         runWhen full_laziness $
 481            CoreDoFloatOutwards FloatOutSwitches {
 482                                  floatOutLambdas   = floatLamArgs dflags,
 483                                  floatOutConstants = True,
 484                                  floatOutPartialApplications = True },
 485                 -- nofib/spectral/hartel/wang doubles in speed if you
 486                 -- do full laziness late in the day.  It only happens
 487                 -- after fusion and other stuff, so the early pass doesn't
 488                 -- catch it.  For the record, the redex is
 489                 --        f_el22 (f_el21 r_midblock)
 490
 491
 492         runWhen cse CoreCSE,
 493                 -- We want CSE to follow the final full-laziness pass, because it may
 494                 -- succeed in commoning up things floated out by full laziness.
 495                 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
 496
 497         runWhen do_float_in CoreDoFloatInwards,
 498
 499         maybe_rule_check (Phase 0),
 500
 501                 -- Case-liberation for -O2.  This should be after
 502                 -- strictness analysis and the simplification which follows it.
 503         runWhen liberate_case (CoreDoPasses [
 504             CoreLiberateCase,
 505             simpl_phase 0 ["post-liberate-case"] max_iter
 506             ]),         -- Run the simplifier after LiberateCase to vastly
 507                         -- reduce the possiblility of shadowing
 508                         -- Reason: see Note [Shadowing] in SpecConstr.lhs
 509
 510         runWhen spec_constr CoreDoSpecConstr,
 511
 512         maybe_rule_check (Phase 0),
 513
 514         -- Final clean-up simplification:
 515         simpl_phase 0 ["final"] max_iter
 516      ]
 517
 518 -- The core-to-core pass ordering is derived from the DynFlags:
 519 runWhen :: Bool -> CoreToDo -> CoreToDo
 520 runWhen True  do_this = do_this
 521 runWhen False _       = CoreDoNothing
 522
 523 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
 524 runMaybe (Just x) f = f x
 525 runMaybe Nothing  _ = CoreDoNothing
 526
 527 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
 528 dumpSimplPhase dflags mode
 529    | Just spec_string <- shouldDumpSimplPhase dflags
 530    = match_spec spec_string
 531    | otherwise
 532    = dopt Opt_D_verbose_core2core dflags
 533
 534   where
 535     match_spec :: String -> Bool
 536     match_spec spec_string
 537       = or $ map (and . map match . split ':')
 538            $ split ',' spec_string
 539
 540     match :: String -> Bool
 541     match "" = True
 542     match s  = case reads s of
 543                 [(n,"")] -> phase_num  n
 544                 _        -> phase_name s
 545
 546     phase_num :: Int -> Bool
 547     phase_num n = case sm_phase mode of
 548                     Phase k -> n == k
 549                     _       -> False
 550
 551     phase_name :: String -> Bool
 552     phase_name s = s `elem` sm_names mode
 553 \end{code}
 554
 555
 556 Note [RULEs enabled in SimplGently]
 557 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 558 RULES are enabled when doing "gentle" simplification.  Two reasons:
 559
 560   * We really want the class-op cancellation to happen:
 561         op (df d1 d2) --> $cop3 d1 d2
 562     because this breaks the mutual recursion between 'op' and 'df'
 563
 564   * I wanted the RULE
 565         lift String ===> ...
 566     to work in Template Haskell when simplifying
 567     splices, so we get simpler code for literal strings
 568
 569 But watch out: list fusion can prevent floating.  So use phase control
 570 to switch off those rules until after floating.
 571
 572 Currently (Oct10) I think that sm_rules is always True, so we
 573 could remove it.
 574
 575
 576 %************************************************************************
 577 %*                                                                      *
 578              Counting and logging
 579 %*                                                                      *
 580 %************************************************************************
 581
 582 \begin{code}
 583 verboseSimplStats :: Bool
 584 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
 585
 586 zeroSimplCount     :: DynFlags -> SimplCount
 587 isZeroSimplCount   :: SimplCount -> Bool
 588 pprSimplCount      :: SimplCount -> SDoc
 589 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
 590 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 591 \end{code}
 592
 593 \begin{code}
 594 data SimplCount
 595    = VerySimplCount !Int        -- Used when don't want detailed stats
 596
 597    | SimplCount {
 598         ticks   :: !Int,        -- Total ticks
 599         details :: !TickCounts, -- How many of each type
 600
 601         n_log   :: !Int,        -- N
 602         log1    :: [Tick],      -- Last N events; <= opt_HistorySize,
 603                                 --   most recent first
 604         log2    :: [Tick]       -- Last opt_HistorySize events before that
 605                                 -- Having log1, log2 lets us accumulate the
 606                                 -- recent history reasonably efficiently
 607      }
 608
 609 type TickCounts = Map Tick Int
 610
 611 simplCountN :: SimplCount -> Int
 612 simplCountN (VerySimplCount n)         = n
 613 simplCountN (SimplCount { ticks = n }) = n
 614
 615 zeroSimplCount dflags
 616                 -- This is where we decide whether to do
 617                 -- the VerySimpl version or the full-stats version
 618   | dopt Opt_D_dump_simpl_stats dflags
 619   = SimplCount {ticks = 0, details = Map.empty,
 620                 n_log = 0, log1 = [], log2 = []}
 621   | otherwise
 622   = VerySimplCount 0
 623
 624 isZeroSimplCount (VerySimplCount n)         = n==0
 625 isZeroSimplCount (SimplCount { ticks = n }) = n==0
 626
 627 doFreeSimplTick tick sc@SimplCount { details = dts }
 628   = sc { details = dts `addTick` tick }
 629 doFreeSimplTick _ sc = sc
 630
 631 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
 632   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 633   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
 634   where
 635     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 636
 637 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
 638
 639
 640 -- Don't use Map.unionWith because that's lazy, and we want to
 641 -- be pretty strict here!
 642 addTick :: TickCounts -> Tick -> TickCounts
 643 addTick fm tick = case Map.lookup tick fm of
 644                         Nothing -> Map.insert tick 1 fm
 645                         Just n  -> n1 `seq` Map.insert tick n1 fm
 646                                 where
 647                                    n1 = n+1
 648
 649
 650 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 651                sc2@(SimplCount { ticks = tks2, details = dts2 })
 652   = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
 653   where
 654         -- A hackish way of getting recent log info
 655     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
 656              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 657              | otherwise       = sc2
 658
 659 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
 660 plusSimplCount _                  _                  = panic "plusSimplCount"
 661        -- We use one or the other consistently
 662
 663 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
 664 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 665   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
 666           blankLine,
 667           pprTickCounts (Map.toList dts),
 668           if verboseSimplStats then
 669                 vcat [blankLine,
 670                       ptext (sLit "Log (most recent first)"),
 671                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 672           else empty
 673     ]
 674
 675 pprTickCounts :: [(Tick,Int)] -> SDoc
 676 pprTickCounts [] = empty
 677 pprTickCounts ((tick1,n1):ticks)
 678   = vcat [int tot_n <+> text (tickString tick1),
 679           pprTCDetails real_these,
 680           pprTickCounts others
 681     ]
 682   where
 683     tick1_tag           = tickToTag tick1
 684     (these, others)     = span same_tick ticks
 685     real_these          = (tick1,n1):these
 686     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
 687     tot_n               = sum [n | (_,n) <- real_these]
 688
 689 pprTCDetails :: [(Tick, Int)] -> SDoc
 690 pprTCDetails ticks
 691   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 692 \end{code}
 693
 694
 695 \begin{code}
 696 data Tick
 697   = PreInlineUnconditionally    Id
 698   | PostInlineUnconditionally   Id
 699
 700   | UnfoldingDone               Id
 701   | RuleFired                   FastString      -- Rule name
 702
 703   | LetFloatFromLet
 704   | EtaExpansion                Id      -- LHS binder
 705   | EtaReduction                Id      -- Binder on outer lambda
 706   | BetaReduction               Id      -- Lambda binder
 707
 708
 709   | CaseOfCase                  Id      -- Bndr on *inner* case
 710   | KnownBranch                 Id      -- Case binder
 711   | CaseMerge                   Id      -- Binder on outer case
 712   | AltMerge                    Id      -- Case binder
 713   | CaseElim                    Id      -- Case binder
 714   | CaseIdentity                Id      -- Case binder
 715   | FillInCaseDefault           Id      -- Case binder
 716
 717   | BottomFound
 718   | SimplifierDone              -- Ticked at each iteration of the simplifier
 719
 720 instance Outputable Tick where
 721   ppr tick = text (tickString tick) <+> pprTickCts tick
 722
 723 instance Eq Tick where
 724   a == b = case a `cmpTick` b of
 725            EQ -> True
 726            _ -> False
 727
 728 instance Ord Tick where
 729   compare = cmpTick
 730
 731 tickToTag :: Tick -> Int
 732 tickToTag (PreInlineUnconditionally _)  = 0
 733 tickToTag (PostInlineUnconditionally _) = 1
 734 tickToTag (UnfoldingDone _)             = 2
 735 tickToTag (RuleFired _)                 = 3
 736 tickToTag LetFloatFromLet               = 4
 737 tickToTag (EtaExpansion _)              = 5
 738 tickToTag (EtaReduction _)              = 6
 739 tickToTag (BetaReduction _)             = 7
 740 tickToTag (CaseOfCase _)                = 8
 741 tickToTag (KnownBranch _)               = 9
 742 tickToTag (CaseMerge _)                 = 10
 743 tickToTag (CaseElim _)                  = 11
 744 tickToTag (CaseIdentity _)              = 12
 745 tickToTag (FillInCaseDefault _)         = 13
 746 tickToTag BottomFound                   = 14
 747 tickToTag SimplifierDone                = 16
 748 tickToTag (AltMerge _)                  = 17
 749
 750 tickString :: Tick -> String
 751 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
 752 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 753 tickString (UnfoldingDone _)            = "UnfoldingDone"
 754 tickString (RuleFired _)                = "RuleFired"
 755 tickString LetFloatFromLet              = "LetFloatFromLet"
 756 tickString (EtaExpansion _)             = "EtaExpansion"
 757 tickString (EtaReduction _)             = "EtaReduction"
 758 tickString (BetaReduction _)            = "BetaReduction"
 759 tickString (CaseOfCase _)               = "CaseOfCase"
 760 tickString (KnownBranch _)              = "KnownBranch"
 761 tickString (CaseMerge _)                = "CaseMerge"
 762 tickString (AltMerge _)                 = "AltMerge"
 763 tickString (CaseElim _)                 = "CaseElim"
 764 tickString (CaseIdentity _)             = "CaseIdentity"
 765 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
 766 tickString BottomFound                  = "BottomFound"
 767 tickString SimplifierDone               = "SimplifierDone"
 768
 769 pprTickCts :: Tick -> SDoc
 770 pprTickCts (PreInlineUnconditionally v) = ppr v
 771 pprTickCts (PostInlineUnconditionally v)= ppr v
 772 pprTickCts (UnfoldingDone v)            = ppr v
 773 pprTickCts (RuleFired v)                = ppr v
 774 pprTickCts LetFloatFromLet              = empty
 775 pprTickCts (EtaExpansion v)             = ppr v
 776 pprTickCts (EtaReduction v)             = ppr v
 777 pprTickCts (BetaReduction v)            = ppr v
 778 pprTickCts (CaseOfCase v)               = ppr v
 779 pprTickCts (KnownBranch v)              = ppr v
 780 pprTickCts (CaseMerge v)                = ppr v
 781 pprTickCts (AltMerge v)                 = ppr v
 782 pprTickCts (CaseElim v)                 = ppr v
 783 pprTickCts (CaseIdentity v)             = ppr v
 784 pprTickCts (FillInCaseDefault v)        = ppr v
 785 pprTickCts _                            = empty
 786
 787 cmpTick :: Tick -> Tick -> Ordering
 788 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 789                 GT -> GT
 790                 EQ -> cmpEqTick a b
 791                 LT -> LT
 792
 793 cmpEqTick :: Tick -> Tick -> Ordering
 794 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
 795 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
 796 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
 797 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
 798 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
 799 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
 800 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
 801 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
 802 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
 803 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
 804 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
 805 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
 806 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 807 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 808 cmpEqTick _                             _                               = EQ
 809 \end{code}
 810
 811
 812 %************************************************************************
 813 %*                                                                      *
 814              Monad and carried data structure definitions
 815 %*                                                                      *
 816 %************************************************************************
 817
 818 \begin{code}
 819 newtype CoreState = CoreState {
 820         cs_uniq_supply :: UniqSupply
 821 }
 822
 823 data CoreReader = CoreReader {
 824         cr_hsc_env :: HscEnv,
 825         cr_rule_base :: RuleBase,
 826         cr_module :: Module
 827 }
 828
 829 data CoreWriter = CoreWriter {
 830         cw_simpl_count :: SimplCount
 831 }
 832
 833 emptyWriter :: DynFlags -> CoreWriter
 834 emptyWriter dflags = CoreWriter {
 835         cw_simpl_count = zeroSimplCount dflags
 836     }
 837
 838 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
 839 plusWriter w1 w2 = CoreWriter {
 840         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
 841     }
 842
 843 type CoreIOEnv = IOEnv CoreReader
 844
 845 -- | The monad used by Core-to-Core passes to access common state, register simplification
 846 -- statistics and so on
 847 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
 848
 849 instance Functor CoreM where
 850     fmap f ma = do
 851         a <- ma
 852         return (f a)
 853
 854 instance Monad CoreM where
 855     return x = CoreM (\s -> nop s x)
 856     mx >>= f = CoreM $ \s -> do
 857             (x, s', w1) <- unCoreM mx s
 858             (y, s'', w2) <- unCoreM (f x) s'
 859             return (y, s'', w1 `plusWriter` w2)
 860
 861 instance Applicative CoreM where
 862     pure = return
 863     (<*>) = ap
 864
 865 -- For use if the user has imported Control.Monad.Error from MTL
 866 -- Requires UndecidableInstances
 867 instance MonadPlus IO => MonadPlus CoreM where
 868     mzero = CoreM (const mzero)
 869     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
 870
 871 instance MonadUnique CoreM where
 872     getUniqueSupplyM = do
 873         us <- getS cs_uniq_supply
 874         let (us1, us2) = splitUniqSupply us
 875         modifyS (\s -> s { cs_uniq_supply = us2 })
 876         return us1
 877
 878 runCoreM :: HscEnv
 879          -> RuleBase
 880          -> UniqSupply
 881          -> Module
 882          -> CoreM a
 883          -> IO (a, SimplCount)
 884 runCoreM hsc_env rule_base us mod m =
 885         liftM extract $ runIOEnv reader $ unCoreM m state
 886   where
 887     reader = CoreReader {
 888             cr_hsc_env = hsc_env,
 889             cr_rule_base = rule_base,
 890             cr_module = mod
 891         }
 892     state = CoreState {
 893             cs_uniq_supply = us
 894         }
 895
 896     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
 897     extract (value, _, writer) = (value, cw_simpl_count writer)
 898
 899 \end{code}
 900
 901
 902 %************************************************************************
 903 %*                                                                      *
 904              Core combinators, not exported
 905 %*                                                                      *
 906 %************************************************************************
 907
 908 \begin{code}
 909
 910 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
 911 nop s x = do
 912     r <- getEnv
 913     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
 914
 915 read :: (CoreReader -> a) -> CoreM a
 916 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
 917
 918 getS :: (CoreState -> a) -> CoreM a
 919 getS f = CoreM (\s -> nop s (f s))
 920
 921 modifyS :: (CoreState -> CoreState) -> CoreM ()
 922 modifyS f = CoreM (\s -> nop (f s) ())
 923
 924 write :: CoreWriter -> CoreM ()
 925 write w = CoreM (\s -> return ((), s, w))
 926
 927 \end{code}
 928
 929 \subsection{Lifting IO into the monad}
 930
 931 \begin{code}
 932
 933 -- | Lift an 'IOEnv' operation into 'CoreM'
 934 liftIOEnv :: CoreIOEnv a -> CoreM a
 935 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
 936
 937 instance MonadIO CoreM where
 938     liftIO = liftIOEnv . IOEnv.liftIO
 939
 940 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
 941 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
 942 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
 943
 944 \end{code}
 945
 946
 947 %************************************************************************
 948 %*                                                                      *
 949              Reader, writer and state accessors
 950 %*                                                                      *
 951 %************************************************************************
 952
 953 \begin{code}
 954
 955 getHscEnv :: CoreM HscEnv
 956 getHscEnv = read cr_hsc_env
 957
 958 getRuleBase :: CoreM RuleBase
 959 getRuleBase = read cr_rule_base
 960
 961 getModule :: CoreM Module
 962 getModule = read cr_module
 963
 964 addSimplCount :: SimplCount -> CoreM ()
 965 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 966
 967 -- Convenience accessors for useful fields of HscEnv
 968
 969 getDynFlags :: CoreM DynFlags
 970 getDynFlags = fmap hsc_dflags getHscEnv
 971
 972 -- | The original name cache is the current mapping from 'Module' and
 973 -- 'OccName' to a compiler-wide unique 'Name'
 974 getOrigNameCache :: CoreM OrigNameCache
 975 getOrigNameCache = do
 976     nameCacheRef <- fmap hsc_NC getHscEnv
 977     liftIO $ fmap nsNames $ readIORef nameCacheRef
 978
 979 \end{code}
 980
 981
 982 %************************************************************************
 983 %*                                                                      *
 984              Dealing with annotations
 985 %*                                                                      *
 986 %************************************************************************
 987
 988 \begin{code}
 989 -- | Get all annotations of a given type. This happens lazily, that is
 990 -- no deserialization will take place until the [a] is actually demanded and
 991 -- the [a] can also be empty (the UniqFM is not filtered).
 992 --
 993 -- This should be done once at the start of a Core-to-Core pass that uses
 994 -- annotations.
 995 --
 996 -- See Note [Annotations]
 997 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
 998 getAnnotations deserialize guts = do
 999      hsc_env <- getHscEnv
1000      ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
1001      return (deserializeAnns deserialize ann_env)
1002
1003 -- | Get at most one annotation of a given type per Unique.
1004 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
1005 getFirstAnnotations deserialize guts
1006   = liftM (mapUFM head . filterUFM (not . null))
1007   $ getAnnotations deserialize guts
1008
1009 \end{code}
1010
1011 Note [Annotations]
1012 ~~~~~~~~~~~~~~~~~~
1013 A Core-to-Core pass that wants to make use of annotations calls
1014 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
1015 annotations of a specific type. This produces all annotations from interface
1016 files read so far. However, annotations from interface files read during the
1017 pass will not be visible until getAnnotations is called again. This is similar
1018 to how rules work and probably isn't too bad.
1019
1020 The current implementation could be optimised a bit: when looking up
1021 annotations for a thing from the HomePackageTable, we could search directly in
1022 the module where the thing is defined rather than building one UniqFM which
1023 contains all annotations we know of. This would work because annotations can
1024 only be given to things defined in the same module. However, since we would
1025 only want to deserialise every annotation once, we would have to build a cache
1026 for every module in the HTP. In the end, it's probably not worth it as long as
1027 we aren't using annotations heavily.
1028
1029 %************************************************************************
1030 %*                                                                      *
1031                 Direct screen output
1032 %*                                                                      *
1033 %************************************************************************
1034
1035 \begin{code}
1036
1037 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
1038 msg how doc = do
1039         dflags <- getDynFlags
1040         liftIO $ how dflags doc
1041
1042 -- | Output a String message to the screen
1043 putMsgS :: String -> CoreM ()
1044 putMsgS = putMsg . text
1045
1046 -- | Output a message to the screen
1047 putMsg :: SDoc -> CoreM ()
1048 putMsg = msg Err.putMsg
1049
1050 -- | Output a string error to the screen
1051 errorMsgS :: String -> CoreM ()
1052 errorMsgS = errorMsg . text
1053
1054 -- | Output an error to the screen
1055 errorMsg :: SDoc -> CoreM ()
1056 errorMsg = msg Err.errorMsg
1057
1058 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1059 fatalErrorMsgS :: String -> CoreM ()
1060 fatalErrorMsgS = fatalErrorMsg . text
1061
1062 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1063 fatalErrorMsg :: SDoc -> CoreM ()
1064 fatalErrorMsg = msg Err.fatalErrorMsg
1065
1066 -- | Output a string debugging message at verbosity level of @-v@ or higher
1067 debugTraceMsgS :: String -> CoreM ()
1068 debugTraceMsgS = debugTraceMsg . text
1069
1070 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1071 debugTraceMsg :: SDoc -> CoreM ()
1072 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1073
1074 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1075 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1076 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1077 \end{code}
1078
1079 \begin{code}
1080
1081 initTcForLookup :: HscEnv -> TcM a -> IO a
1082 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1083
1084 \end{code}
1085
1086
1087 %************************************************************************
1088 %*                                                                      *
1089                Finding TyThings
1090 %*                                                                      *
1091 %************************************************************************
1092
1093 \begin{code}
1094 instance MonadThings CoreM where
1095     lookupThing name = do
1096         hsc_env <- getHscEnv
1097         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1098 \end{code}
1099
1100 %************************************************************************
1101 %*                                                                      *
1102                Template Haskell interoperability
1103 %*                                                                      *
1104 %************************************************************************
1105
1106 \begin{code}
1107 #ifdef GHCI
1108 -- | Attempt to convert a Template Haskell name to one that GHC can
1109 -- understand. Original TH names such as those you get when you use
1110 -- the @'foo@ syntax will be translated to their equivalent GHC name
1111 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1112 -- to names in the module being compiled, if possible. Exact TH names
1113 -- will be bound to the name they represent, exactly.
1114 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1115 thNameToGhcName th_name = do
1116     hsc_env <- getHscEnv
1117     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
1118 #endif
1119 \end{code}