compiler/simplCore/CoreMonad.lhs

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