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