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