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