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, simplCountN,
  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
  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 (SimplGently {}) _ _) = 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         SimplifierMode
 207         Int                    -- Max iterations
 208         [SimplifierSwitch]     -- Each run of the simplifier can take a different
 209                                -- set of simplifier-specific flags.
 210   | CoreDoFloatInwards
 211   | CoreDoFloatOutwards FloatOutSwitches
 212   | CoreLiberateCase
 213   | CoreDoPrintCore
 214   | CoreDoStaticArgs
 215   | CoreDoStrictness
 216   | CoreDoWorkerWrapper
 217   | CoreDoSpecialising
 218   | CoreDoSpecConstr
 219   | CoreDoGlomBinds
 220   | CoreCSE
 221   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
 222                                            -- matching this string
 223   | CoreDoVectorisation PackageId
 224   | CoreDoNothing                -- Useful when building up
 225   | CoreDoPasses [CoreToDo]      -- lists of these things
 226
 227   | CoreDesugar  -- Not strictly a core-to-core pass, but produces
 228                  -- Core output, and hence useful to pass to endPass
 229
 230   | CoreTidy
 231   | CorePrep
 232
 233 coreDumpFlag :: CoreToDo -> Maybe DynFlag
 234 coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
 235 coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
 236 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 237 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
 238 coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
 239 coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
 240 coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 241 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 242 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 243 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
 244 coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
 245 coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds
 246 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 247 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 248
 249 coreDumpFlag CoreDoPrintCore         = Nothing
 250 coreDumpFlag (CoreDoRuleCheck {})    = Nothing
 251 coreDumpFlag CoreDoNothing           = Nothing
 252 coreDumpFlag CoreDoGlomBinds         = Nothing
 253 coreDumpFlag (CoreDoPasses {})       = Nothing
 254
 255 instance Outputable CoreToDo where
 256   ppr (CoreDoSimplify md n _)  = ptext (sLit "Simplifier")
 257                                  <+> ppr md
 258                                  <+> ptext (sLit "max-iterations=") <> int n
 259   ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
 260   ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
 261   ppr CoreLiberateCase         = ptext (sLit "Liberate case")
 262   ppr CoreDoStaticArgs         = ptext (sLit "Static argument")
 263   ppr CoreDoStrictness         = ptext (sLit "Demand analysis")
 264   ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
 265   ppr CoreDoSpecialising       = ptext (sLit "Specialise")
 266   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
 267   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
 268   ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
 269   ppr CoreDesugar              = ptext (sLit "Desugar")
 270   ppr CoreTidy                 = ptext (sLit "Tidy Core")
 271   ppr CorePrep                 = ptext (sLit "CorePrep")
 272   ppr CoreDoPrintCore          = ptext (sLit "Print core")
 273   ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
 274   ppr CoreDoGlomBinds          = ptext (sLit "Glom binds")
 275   ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
 276   ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
 277 \end{code}
 278
 279 \begin{code}
 280 data SimplifierMode             -- See comments in SimplMonad
 281   = SimplGently
 282         { sm_rules :: Bool      -- Whether RULES are enabled
 283         , sm_inline :: Bool }   -- Whether inlining is enabled
 284
 285   | SimplPhase
 286         { sm_num :: Int           -- Phase number; counts downward so 0 is last phase
 287         , sm_names :: [String] }  -- Name(s) of the phase
 288
 289 instance Outputable SimplifierMode where
 290     ppr (SimplPhase { sm_num = n, sm_names = ss })
 291        = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
 292     ppr (SimplGently { sm_rules = r, sm_inline = i })
 293        = ptext (sLit "gentle") <>
 294            brackets (pp_flag r (sLit "rules") <> comma <>
 295                      pp_flag i (sLit "inline"))
 296          where
 297            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
 298
 299 data SimplifierSwitch
 300   = NoCaseOfCase
 301 \end{code}
 302
 303
 304 \begin{code}
 305 data FloatOutSwitches = FloatOutSwitches {
 306         floatOutLambdas :: Bool,     -- ^ True <=> float lambdas to top level
 307         floatOutConstants :: Bool    -- ^ True <=> float constants to top level,
 308                                      --            even if they do not escape a lambda
 309     }
 310 instance Outputable FloatOutSwitches where
 311     ppr = pprFloatOutSwitches
 312
 313 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
 314 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
 315                      <+> pp_not (floatOutConstants sw) <+> text "constants"
 316   where
 317     pp_not True  = empty
 318     pp_not False = text "not"
 319
 320 -- | Switches that specify the minimum amount of floating out
 321 -- gentleFloatOutSwitches :: FloatOutSwitches
 322 -- gentleFloatOutSwitches = FloatOutSwitches False False
 323
 324 -- | Switches that do not specify floating out of lambdas, just of constants
 325 constantsOnlyFloatOutSwitches :: FloatOutSwitches
 326 constantsOnlyFloatOutSwitches = FloatOutSwitches False True
 327 \end{code}
 328
 329
 330 %************************************************************************
 331 %*                                                                      *
 332            Generating the main optimisation pipeline
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 \begin{code}
 337 getCoreToDo :: DynFlags -> [CoreToDo]
 338 getCoreToDo dflags
 339   = core_todo
 340   where
 341     opt_level     = optLevel dflags
 342     phases        = simplPhases dflags
 343     max_iter      = maxSimplIterations dflags
 344     strictness    = dopt Opt_Strictness dflags
 345     full_laziness = dopt Opt_FullLaziness dflags
 346     do_specialise = dopt Opt_Specialise dflags
 347     do_float_in   = dopt Opt_FloatIn dflags
 348     cse           = dopt Opt_CSE dflags
 349     spec_constr   = dopt Opt_SpecConstr dflags
 350     liberate_case = dopt Opt_LiberateCase dflags
 351     rule_check    = ruleCheck dflags
 352     static_args   = dopt Opt_StaticArgumentTransformation dflags
 353
 354     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
 355
 356     maybe_strictness_before phase
 357       = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
 358
 359     simpl_phase phase names iter
 360       = CoreDoPasses
 361           [ maybe_strictness_before phase
 362           , CoreDoSimplify (SimplPhase phase names)
 363                            iter []
 364           , maybe_rule_check phase
 365           ]
 366
 367     vectorisation
 368       = runWhen (dopt Opt_Vectorise dflags)
 369         $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
 370
 371
 372                 -- By default, we have 2 phases before phase 0.
 373
 374                 -- Want to run with inline phase 2 after the specialiser to give
 375                 -- maximum chance for fusion to work before we inline build/augment
 376                 -- in phase 1.  This made a difference in 'ansi' where an
 377                 -- overloaded function wasn't inlined till too late.
 378
 379                 -- Need phase 1 so that build/augment get
 380                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 381                 -- strictness in the function sumcode' if augment is not inlined
 382                 -- before strictness analysis runs
 383     simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
 384                                   | phase <- [phases, phases-1 .. 1] ]
 385
 386
 387         -- initial simplify: mk specialiser happy: minimum effort please
 388     simpl_gently = CoreDoSimplify
 389                        (SimplGently { sm_rules = True, sm_inline = False })
 390                           -- See Note [Gentle mode] and
 391                           -- Note [RULEs enabled in SimplGently] in SimplUtils
 392                        max_iter
 393                        [
 394
 395
 396             NoCaseOfCase        -- Don't do case-of-case transformations.
 397                                 -- This makes full laziness work better
 398         ]
 399
 400     core_todo =
 401      if opt_level == 0 then
 402        [vectorisation,
 403         simpl_phase 0 ["final"] max_iter]
 404      else {- opt_level >= 1 -} [
 405
 406     -- We want to do the static argument transform before full laziness as it
 407     -- may expose extra opportunities to float things outwards. However, to fix
 408     -- up the output of the transformation we need at do at least one simplify
 409     -- after this before anything else
 410         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
 411
 412         -- We run vectorisation here for now, but we might also try to run
 413         -- it later
 414         vectorisation,
 415
 416         -- initial simplify: mk specialiser happy: minimum effort please
 417         simpl_gently,
 418
 419         -- Specialisation is best done before full laziness
 420         -- so that overloaded functions have all their dictionary lambdas manifest
 421         runWhen do_specialise CoreDoSpecialising,
 422
 423         runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
 424                 -- Was: gentleFloatOutSwitches
 425                 -- I have no idea why, but not floating constants to top level is
 426                 -- very bad in some cases.
 427                 -- Notably: p_ident in spectral/rewrite
 428                 --          Changing from "gentle" to "constantsOnly" improved
 429                 --          rewrite's allocation by 19%, and made  0.0% difference
 430                 --          to any other nofib benchmark
 431
 432         runWhen do_float_in CoreDoFloatInwards,
 433
 434         simpl_phases,
 435
 436                 -- Phase 0: allow all Ids to be inlined now
 437                 -- This gets foldr inlined before strictness analysis
 438
 439                 -- At least 3 iterations because otherwise we land up with
 440                 -- huge dead expressions because of an infelicity in the
 441                 -- simpifier.
 442                 --      let k = BIG in foldr k z xs
 443                 -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
 444                 -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
 445                 -- Don't stop now!
 446         simpl_phase 0 ["main"] (max max_iter 3),
 447
 448         runWhen strictness (CoreDoPasses [
 449                 CoreDoStrictness,
 450                 CoreDoWorkerWrapper,
 451                 CoreDoGlomBinds,
 452                 simpl_phase 0 ["post-worker-wrapper"] max_iter
 453                 ]),
 454
 455         runWhen full_laziness
 456           (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
 457                 -- nofib/spectral/hartel/wang doubles in speed if you
 458                 -- do full laziness late in the day.  It only happens
 459                 -- after fusion and other stuff, so the early pass doesn't
 460                 -- catch it.  For the record, the redex is
 461                 --        f_el22 (f_el21 r_midblock)
 462
 463
 464         runWhen cse CoreCSE,
 465                 -- We want CSE to follow the final full-laziness pass, because it may
 466                 -- succeed in commoning up things floated out by full laziness.
 467                 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
 468
 469         runWhen do_float_in CoreDoFloatInwards,
 470
 471         maybe_rule_check 0,
 472
 473                 -- Case-liberation for -O2.  This should be after
 474                 -- strictness analysis and the simplification which follows it.
 475         runWhen liberate_case (CoreDoPasses [
 476             CoreLiberateCase,
 477             simpl_phase 0 ["post-liberate-case"] max_iter
 478             ]),         -- Run the simplifier after LiberateCase to vastly
 479                         -- reduce the possiblility of shadowing
 480                         -- Reason: see Note [Shadowing] in SpecConstr.lhs
 481
 482         runWhen spec_constr CoreDoSpecConstr,
 483
 484         maybe_rule_check 0,
 485
 486         -- Final clean-up simplification:
 487         simpl_phase 0 ["final"] max_iter
 488      ]
 489
 490 -- The core-to-core pass ordering is derived from the DynFlags:
 491 runWhen :: Bool -> CoreToDo -> CoreToDo
 492 runWhen True  do_this = do_this
 493 runWhen False _       = CoreDoNothing
 494
 495 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
 496 runMaybe (Just x) f = f x
 497 runMaybe Nothing  _ = CoreDoNothing
 498
 499 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
 500 dumpSimplPhase dflags mode
 501    | Just spec_string <- shouldDumpSimplPhase dflags
 502    = match_spec spec_string
 503    | otherwise
 504    = dopt Opt_D_verbose_core2core dflags
 505
 506   where
 507     match_spec :: String -> Bool
 508     match_spec spec_string
 509       = or $ map (and . map match . split ':')
 510            $ split ',' spec_string
 511
 512     match :: String -> Bool
 513     match "" = True
 514     match s  = case reads s of
 515                 [(n,"")] -> phase_num  n
 516                 _        -> phase_name s
 517
 518     phase_num :: Int -> Bool
 519     phase_num n = case mode of
 520                     SimplPhase k _ -> n == k
 521                     _              -> False
 522
 523     phase_name :: String -> Bool
 524     phase_name s = case mode of
 525                      SimplGently {}               -> s == "gentle"
 526                      SimplPhase { sm_names = ss } -> s `elem` ss
 527 \end{code}
 528
 529
 530 %************************************************************************
 531 %*                                                                      *
 532              Counting and logging
 533 %*                                                                      *
 534 %************************************************************************
 535
 536 \begin{code}
 537 verboseSimplStats :: Bool
 538 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
 539
 540 zeroSimplCount     :: DynFlags -> SimplCount
 541 isZeroSimplCount   :: SimplCount -> Bool
 542 pprSimplCount      :: SimplCount -> SDoc
 543 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
 544 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 545 \end{code}
 546
 547 \begin{code}
 548 data SimplCount
 549    = VerySimplCount !Int        -- Used when don't want detailed stats
 550
 551    | SimplCount {
 552         ticks   :: !Int,        -- Total ticks
 553         details :: !TickCounts, -- How many of each type
 554
 555         n_log   :: !Int,        -- N
 556         log1    :: [Tick],      -- Last N events; <= opt_HistorySize,
 557                                 --   most recent first
 558         log2    :: [Tick]       -- Last opt_HistorySize events before that
 559                                 -- Having log1, log2 lets us accumulate the
 560                                 -- recent history reasonably efficiently
 561      }
 562
 563 type TickCounts = Map Tick Int
 564
 565 simplCountN :: SimplCount -> Int
 566 simplCountN (VerySimplCount n)         = n
 567 simplCountN (SimplCount { ticks = n }) = n
 568
 569 zeroSimplCount dflags
 570                 -- This is where we decide whether to do
 571                 -- the VerySimpl version or the full-stats version
 572   | dopt Opt_D_dump_simpl_stats dflags
 573   = SimplCount {ticks = 0, details = Map.empty,
 574                 n_log = 0, log1 = [], log2 = []}
 575   | otherwise
 576   = VerySimplCount 0
 577
 578 isZeroSimplCount (VerySimplCount n)         = n==0
 579 isZeroSimplCount (SimplCount { ticks = n }) = n==0
 580
 581 doFreeSimplTick tick sc@SimplCount { details = dts }
 582   = sc { details = dts `addTick` tick }
 583 doFreeSimplTick _ sc = sc
 584
 585 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
 586   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 587   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
 588   where
 589     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 590
 591 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
 592
 593
 594 -- Don't use Map.unionWith because that's lazy, and we want to
 595 -- be pretty strict here!
 596 addTick :: TickCounts -> Tick -> TickCounts
 597 addTick fm tick = case Map.lookup tick fm of
 598                         Nothing -> Map.insert tick 1 fm
 599                         Just n  -> n1 `seq` Map.insert tick n1 fm
 600                                 where
 601                                    n1 = n+1
 602
 603
 604 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 605                sc2@(SimplCount { ticks = tks2, details = dts2 })
 606   = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
 607   where
 608         -- A hackish way of getting recent log info
 609     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
 610              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 611              | otherwise       = sc2
 612
 613 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
 614 plusSimplCount _                  _                  = panic "plusSimplCount"
 615        -- We use one or the other consistently
 616
 617 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
 618 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 619   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
 620           blankLine,
 621           pprTickCounts (Map.toList dts),
 622           if verboseSimplStats then
 623                 vcat [blankLine,
 624                       ptext (sLit "Log (most recent first)"),
 625                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 626           else empty
 627     ]
 628
 629 pprTickCounts :: [(Tick,Int)] -> SDoc
 630 pprTickCounts [] = empty
 631 pprTickCounts ((tick1,n1):ticks)
 632   = vcat [int tot_n <+> text (tickString tick1),
 633           pprTCDetails real_these,
 634           pprTickCounts others
 635     ]
 636   where
 637     tick1_tag           = tickToTag tick1
 638     (these, others)     = span same_tick ticks
 639     real_these          = (tick1,n1):these
 640     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
 641     tot_n               = sum [n | (_,n) <- real_these]
 642
 643 pprTCDetails :: [(Tick, Int)] -> SDoc
 644 pprTCDetails ticks
 645   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 646 \end{code}
 647
 648
 649 \begin{code}
 650 data Tick
 651   = PreInlineUnconditionally    Id
 652   | PostInlineUnconditionally   Id
 653
 654   | UnfoldingDone               Id
 655   | RuleFired                   FastString      -- Rule name
 656
 657   | LetFloatFromLet
 658   | EtaExpansion                Id      -- LHS binder
 659   | EtaReduction                Id      -- Binder on outer lambda
 660   | BetaReduction               Id      -- Lambda binder
 661
 662
 663   | CaseOfCase                  Id      -- Bndr on *inner* case
 664   | KnownBranch                 Id      -- Case binder
 665   | CaseMerge                   Id      -- Binder on outer case
 666   | AltMerge                    Id      -- Case binder
 667   | CaseElim                    Id      -- Case binder
 668   | CaseIdentity                Id      -- Case binder
 669   | FillInCaseDefault           Id      -- Case binder
 670
 671   | BottomFound
 672   | SimplifierDone              -- Ticked at each iteration of the simplifier
 673
 674 instance Outputable Tick where
 675   ppr tick = text (tickString tick) <+> pprTickCts tick
 676
 677 instance Eq Tick where
 678   a == b = case a `cmpTick` b of
 679            EQ -> True
 680            _ -> False
 681
 682 instance Ord Tick where
 683   compare = cmpTick
 684
 685 tickToTag :: Tick -> Int
 686 tickToTag (PreInlineUnconditionally _)  = 0
 687 tickToTag (PostInlineUnconditionally _) = 1
 688 tickToTag (UnfoldingDone _)             = 2
 689 tickToTag (RuleFired _)                 = 3
 690 tickToTag LetFloatFromLet               = 4
 691 tickToTag (EtaExpansion _)              = 5
 692 tickToTag (EtaReduction _)              = 6
 693 tickToTag (BetaReduction _)             = 7
 694 tickToTag (CaseOfCase _)                = 8
 695 tickToTag (KnownBranch _)               = 9
 696 tickToTag (CaseMerge _)                 = 10
 697 tickToTag (CaseElim _)                  = 11
 698 tickToTag (CaseIdentity _)              = 12
 699 tickToTag (FillInCaseDefault _)         = 13
 700 tickToTag BottomFound                   = 14
 701 tickToTag SimplifierDone                = 16
 702 tickToTag (AltMerge _)                  = 17
 703
 704 tickString :: Tick -> String
 705 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
 706 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 707 tickString (UnfoldingDone _)            = "UnfoldingDone"
 708 tickString (RuleFired _)                = "RuleFired"
 709 tickString LetFloatFromLet              = "LetFloatFromLet"
 710 tickString (EtaExpansion _)             = "EtaExpansion"
 711 tickString (EtaReduction _)             = "EtaReduction"
 712 tickString (BetaReduction _)            = "BetaReduction"
 713 tickString (CaseOfCase _)               = "CaseOfCase"
 714 tickString (KnownBranch _)              = "KnownBranch"
 715 tickString (CaseMerge _)                = "CaseMerge"
 716 tickString (AltMerge _)                 = "AltMerge"
 717 tickString (CaseElim _)                 = "CaseElim"
 718 tickString (CaseIdentity _)             = "CaseIdentity"
 719 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
 720 tickString BottomFound                  = "BottomFound"
 721 tickString SimplifierDone               = "SimplifierDone"
 722
 723 pprTickCts :: Tick -> SDoc
 724 pprTickCts (PreInlineUnconditionally v) = ppr v
 725 pprTickCts (PostInlineUnconditionally v)= ppr v
 726 pprTickCts (UnfoldingDone v)            = ppr v
 727 pprTickCts (RuleFired v)                = ppr v
 728 pprTickCts LetFloatFromLet              = empty
 729 pprTickCts (EtaExpansion v)             = ppr v
 730 pprTickCts (EtaReduction v)             = ppr v
 731 pprTickCts (BetaReduction v)            = ppr v
 732 pprTickCts (CaseOfCase v)               = ppr v
 733 pprTickCts (KnownBranch v)              = ppr v
 734 pprTickCts (CaseMerge v)                = ppr v
 735 pprTickCts (AltMerge v)                 = ppr v
 736 pprTickCts (CaseElim v)                 = ppr v
 737 pprTickCts (CaseIdentity v)             = ppr v
 738 pprTickCts (FillInCaseDefault v)        = ppr v
 739 pprTickCts _                            = empty
 740
 741 cmpTick :: Tick -> Tick -> Ordering
 742 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 743                 GT -> GT
 744                 EQ -> cmpEqTick a b
 745                 LT -> LT
 746
 747 cmpEqTick :: Tick -> Tick -> Ordering
 748 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
 749 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
 750 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
 751 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
 752 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
 753 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
 754 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
 755 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
 756 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
 757 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
 758 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
 759 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
 760 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 761 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 762 cmpEqTick _                             _                               = EQ
 763 \end{code}
 764
 765
 766 %************************************************************************
 767 %*                                                                      *
 768              Monad and carried data structure definitions
 769 %*                                                                      *
 770 %************************************************************************
 771
 772 \begin{code}
 773 newtype CoreState = CoreState {
 774         cs_uniq_supply :: UniqSupply
 775 }
 776
 777 data CoreReader = CoreReader {
 778         cr_hsc_env :: HscEnv,
 779         cr_rule_base :: RuleBase,
 780         cr_module :: Module
 781 }
 782
 783 data CoreWriter = CoreWriter {
 784         cw_simpl_count :: SimplCount
 785 }
 786
 787 emptyWriter :: DynFlags -> CoreWriter
 788 emptyWriter dflags = CoreWriter {
 789         cw_simpl_count = zeroSimplCount dflags
 790     }
 791
 792 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
 793 plusWriter w1 w2 = CoreWriter {
 794         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
 795     }
 796
 797 type CoreIOEnv = IOEnv CoreReader
 798
 799 -- | The monad used by Core-to-Core passes to access common state, register simplification
 800 -- statistics and so on
 801 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
 802
 803 instance Functor CoreM where
 804     fmap f ma = do
 805         a <- ma
 806         return (f a)
 807
 808 instance Monad CoreM where
 809     return x = CoreM (\s -> nop s x)
 810     mx >>= f = CoreM $ \s -> do
 811             (x, s', w1) <- unCoreM mx s
 812             (y, s'', w2) <- unCoreM (f x) s'
 813             return (y, s'', w1 `plusWriter` w2)
 814
 815 instance Applicative CoreM where
 816     pure = return
 817     (<*>) = ap
 818
 819 -- For use if the user has imported Control.Monad.Error from MTL
 820 -- Requires UndecidableInstances
 821 instance MonadPlus IO => MonadPlus CoreM where
 822     mzero = CoreM (const mzero)
 823     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
 824
 825 instance MonadUnique CoreM where
 826     getUniqueSupplyM = do
 827         us <- getS cs_uniq_supply
 828         let (us1, us2) = splitUniqSupply us
 829         modifyS (\s -> s { cs_uniq_supply = us2 })
 830         return us1
 831
 832 runCoreM :: HscEnv
 833          -> RuleBase
 834          -> UniqSupply
 835          -> Module
 836          -> CoreM a
 837          -> IO (a, SimplCount)
 838 runCoreM hsc_env rule_base us mod m =
 839         liftM extract $ runIOEnv reader $ unCoreM m state
 840   where
 841     reader = CoreReader {
 842             cr_hsc_env = hsc_env,
 843             cr_rule_base = rule_base,
 844             cr_module = mod
 845         }
 846     state = CoreState {
 847             cs_uniq_supply = us
 848         }
 849
 850     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
 851     extract (value, _, writer) = (value, cw_simpl_count writer)
 852
 853 \end{code}
 854
 855
 856 %************************************************************************
 857 %*                                                                      *
 858              Core combinators, not exported
 859 %*                                                                      *
 860 %************************************************************************
 861
 862 \begin{code}
 863
 864 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
 865 nop s x = do
 866     r <- getEnv
 867     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
 868
 869 read :: (CoreReader -> a) -> CoreM a
 870 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
 871
 872 getS :: (CoreState -> a) -> CoreM a
 873 getS f = CoreM (\s -> nop s (f s))
 874
 875 modifyS :: (CoreState -> CoreState) -> CoreM ()
 876 modifyS f = CoreM (\s -> nop (f s) ())
 877
 878 write :: CoreWriter -> CoreM ()
 879 write w = CoreM (\s -> return ((), s, w))
 880
 881 \end{code}
 882
 883 \subsection{Lifting IO into the monad}
 884
 885 \begin{code}
 886
 887 -- | Lift an 'IOEnv' operation into 'CoreM'
 888 liftIOEnv :: CoreIOEnv a -> CoreM a
 889 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
 890
 891 instance MonadIO CoreM where
 892     liftIO = liftIOEnv . IOEnv.liftIO
 893
 894 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
 895 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
 896 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
 897
 898 \end{code}
 899
 900
 901 %************************************************************************
 902 %*                                                                      *
 903              Reader, writer and state accessors
 904 %*                                                                      *
 905 %************************************************************************
 906
 907 \begin{code}
 908
 909 getHscEnv :: CoreM HscEnv
 910 getHscEnv = read cr_hsc_env
 911
 912 getRuleBase :: CoreM RuleBase
 913 getRuleBase = read cr_rule_base
 914
 915 getModule :: CoreM Module
 916 getModule = read cr_module
 917
 918 addSimplCount :: SimplCount -> CoreM ()
 919 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 920
 921 -- Convenience accessors for useful fields of HscEnv
 922
 923 getDynFlags :: CoreM DynFlags
 924 getDynFlags = fmap hsc_dflags getHscEnv
 925
 926 -- | The original name cache is the current mapping from 'Module' and
 927 -- 'OccName' to a compiler-wide unique 'Name'
 928 getOrigNameCache :: CoreM OrigNameCache
 929 getOrigNameCache = do
 930     nameCacheRef <- fmap hsc_NC getHscEnv
 931     liftIO $ fmap nsNames $ readIORef nameCacheRef
 932
 933 \end{code}
 934
 935
 936 %************************************************************************
 937 %*                                                                      *
 938              Dealing with annotations
 939 %*                                                                      *
 940 %************************************************************************
 941
 942 \begin{code}
 943 -- | Get all annotations of a given type. This happens lazily, that is
 944 -- no deserialization will take place until the [a] is actually demanded and
 945 -- the [a] can also be empty (the UniqFM is not filtered).
 946 --
 947 -- This should be done once at the start of a Core-to-Core pass that uses
 948 -- annotations.
 949 --
 950 -- See Note [Annotations]
 951 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
 952 getAnnotations deserialize guts = do
 953      hsc_env <- getHscEnv
 954      ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
 955      return (deserializeAnns deserialize ann_env)
 956
 957 -- | Get at most one annotation of a given type per Unique.
 958 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
 959 getFirstAnnotations deserialize guts
 960   = liftM (mapUFM head . filterUFM (not . null))
 961   $ getAnnotations deserialize guts
 962
 963 \end{code}
 964
 965 Note [Annotations]
 966 ~~~~~~~~~~~~~~~~~~
 967 A Core-to-Core pass that wants to make use of annotations calls
 968 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
 969 annotations of a specific type. This produces all annotations from interface
 970 files read so far. However, annotations from interface files read during the
 971 pass will not be visible until getAnnotations is called again. This is similar
 972 to how rules work and probably isn't too bad.
 973
 974 The current implementation could be optimised a bit: when looking up
 975 annotations for a thing from the HomePackageTable, we could search directly in
 976 the module where the thing is defined rather than building one UniqFM which
 977 contains all annotations we know of. This would work because annotations can
 978 only be given to things defined in the same module. However, since we would
 979 only want to deserialise every annotation once, we would have to build a cache
 980 for every module in the HTP. In the end, it's probably not worth it as long as
 981 we aren't using annotations heavily.
 982
 983 %************************************************************************
 984 %*                                                                      *
 985                 Direct screen output
 986 %*                                                                      *
 987 %************************************************************************
 988
 989 \begin{code}
 990
 991 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
 992 msg how doc = do
 993         dflags <- getDynFlags
 994         liftIO $ how dflags doc
 995
 996 -- | Output a String message to the screen
 997 putMsgS :: String -> CoreM ()
 998 putMsgS = putMsg . text
 999
1000 -- | Output a message to the screen
1001 putMsg :: SDoc -> CoreM ()
1002 putMsg = msg Err.putMsg
1003
1004 -- | Output a string error to the screen
1005 errorMsgS :: String -> CoreM ()
1006 errorMsgS = errorMsg . text
1007
1008 -- | Output an error to the screen
1009 errorMsg :: SDoc -> CoreM ()
1010 errorMsg = msg Err.errorMsg
1011
1012 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1013 fatalErrorMsgS :: String -> CoreM ()
1014 fatalErrorMsgS = fatalErrorMsg . text
1015
1016 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1017 fatalErrorMsg :: SDoc -> CoreM ()
1018 fatalErrorMsg = msg Err.fatalErrorMsg
1019
1020 -- | Output a string debugging message at verbosity level of @-v@ or higher
1021 debugTraceMsgS :: String -> CoreM ()
1022 debugTraceMsgS = debugTraceMsg . text
1023
1024 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1025 debugTraceMsg :: SDoc -> CoreM ()
1026 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1027
1028 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1029 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1030 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1031 \end{code}
1032
1033 \begin{code}
1034
1035 initTcForLookup :: HscEnv -> TcM a -> IO a
1036 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1037
1038 \end{code}
1039
1040
1041 %************************************************************************
1042 %*                                                                      *
1043                Finding TyThings
1044 %*                                                                      *
1045 %************************************************************************
1046
1047 \begin{code}
1048 instance MonadThings CoreM where
1049     lookupThing name = do
1050         hsc_env <- getHscEnv
1051         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1052 \end{code}
1053
1054 %************************************************************************
1055 %*                                                                      *
1056                Template Haskell interoperability
1057 %*                                                                      *
1058 %************************************************************************
1059
1060 \begin{code}
1061 #ifdef GHCI
1062 -- | Attempt to convert a Template Haskell name to one that GHC can
1063 -- understand. Original TH names such as those you get when you use
1064 -- the @'foo@ syntax will be translated to their equivalent GHC name
1065 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1066 -- to names in the module being compiled, if possible. Exact TH names
1067 -- will be bound to the name they represent, exactly.
1068 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1069 thNameToGhcName th_name = do
1070     hsc_env <- getHscEnv
1071     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
1072 #endif
1073 \end{code}