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