2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[CoreMonad]{The core pipeline monad}
7 {-# LANGUAGE UndecidableInstances #-}
10 -- * Configuration of the core-to-core passes
15 getCoreToDo, dumpSimplPhase,
18 SimplCount, doSimplTick, doFreeSimplTick,
19 pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
24 -- ** Reading from the monad
25 getHscEnv, getRuleBase, getModule,
26 getDynFlags, getOrigNameCache,
28 -- ** Writing to the monad
31 -- ** Lifting into the monad
32 liftIO, liftIOWithCount,
33 liftIO1, liftIO2, liftIO3, liftIO4,
35 -- ** Dealing with annotations
36 getAnnotations, getFirstAnnotations,
39 showPass, endPass, endIteration, dumpIfSet,
42 putMsg, putMsgS, errorMsg, errorMsgS,
43 fatalErrorMsg, fatalErrorMsgS,
44 debugTraceMsg, debugTraceMsgS,
59 import CoreLint ( lintCoreBindings )
60 import PrelNames ( iNTERACTIVE )
62 import Module ( PackageId, Module )
65 import Rules ( RuleBase )
66 import BasicTypes ( CompilerPhase )
70 import IOEnv hiding ( liftIO, failM, failWithM )
71 import qualified IOEnv ( liftIO )
72 import TcEnv ( tcLookupGlobal )
73 import TcRnMonad ( TcM, initTc )
77 import qualified ErrUtils as Err
81 import UniqFM ( UniqFM, mapUFM, filterUFM )
85 import Data.List ( intersperse )
91 import Prelude hiding ( read )
94 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
95 import qualified Language.Haskell.TH as TH
99 %************************************************************************
103 %************************************************************************
105 These functions are not CoreM monad stuff, but they probably ought to
106 be, and it makes a conveneint place. place for them. They print out
107 stuff before and after core passes, and do Core Lint when necessary.
110 showPass :: DynFlags -> CoreToDo -> IO ()
111 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
113 endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
114 endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
116 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
117 endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
118 endIteration dflags pass n
119 = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
120 (Just Opt_D_dump_simpl_iterations)
122 dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
123 dumpIfSet dump_me pass extra_info doc
124 = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
126 dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
127 -> [CoreBind] -> [CoreRule] -> IO ()
128 -- The "show_all" parameter says to print dump if -dverbose-core2core is on
129 dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
130 = do { -- Report result size if required
131 -- This has the side effect of forcing the intermediate to be evaluated
132 ; Err.debugTraceMsg dflags 2 $
133 (text " Result size =" <+> int (coreBindsSize binds))
135 -- Report verbosely, if required
136 ; let pass_name = showSDoc (ppr pass <+> extra_info)
137 dump_doc = pprCoreBindings binds
138 $$ ppUnless (null rules) pp_rules
140 ; case mb_dump_flag of
142 Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
144 dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core]
145 | otherwise = [dump_flag]
148 ; when (dopt Opt_DoCoreLinting dflags) $
149 do { let (warns, errs) = lintCoreBindings binds
150 ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
151 ; displayLintResults dflags pass warns errs binds } }
153 pp_rules = vcat [ blankLine
154 , ptext (sLit "------ Local rules for imported ids --------")
157 displayLintResults :: DynFlags -> CoreToDo
158 -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
160 displayLintResults dflags pass warns errs binds
161 | not (isEmptyBag errs)
162 = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
163 , ptext (sLit "*** Offending Program ***")
164 , pprCoreBindings binds
165 , ptext (sLit "*** End of Offense ***") ])
166 ; Err.ghcExit dflags 1 }
168 | not (isEmptyBag warns)
169 , not (case pass of { CoreDesugar -> True; _ -> False })
170 -- Suppress warnings after desugaring pass because some
171 -- are legitimate. Notably, the desugarer generates instance
172 -- methods with INLINE pragmas that form a mutually recursive
173 -- group. Only afer a round of simplification are they unravelled.
174 , not opt_NoDebugOutput
175 , showLintWarnings pass
176 = printDump (banner "warnings" $$ Err.pprMessageBag warns)
178 | otherwise = return ()
180 banner string = ptext (sLit "*** Core Lint") <+> text string
181 <+> ptext (sLit ": in result of") <+> ppr pass
182 <+> ptext (sLit "***")
184 showLintWarnings :: CoreToDo -> Bool
185 -- Disable Lint warnings on the first simplifier pass, because
186 -- there may be some INLINE knots still tied, which is tiresomely noisy
187 showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
188 showLintWarnings _ = True
192 %************************************************************************
194 The CoreToDo type and related types
195 Abstraction of core-to-core passes to run.
197 %************************************************************************
200 data CoreToDo -- These are diff core-to-core passes,
201 -- which may be invoked in any order,
202 -- as many times as you like.
204 = CoreDoSimplify -- The core-to-core simplifier.
206 Int -- Max iterations
207 [SimplifierSwitch] -- Each run of the simplifier can take a different
208 -- set of simplifier-specific flags.
210 | CoreDoFloatOutwards FloatOutSwitches
215 | CoreDoWorkerWrapper
220 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
221 -- matching this string
222 | CoreDoVectorisation PackageId
223 | CoreDoNothing -- Useful when building up
224 | CoreDoPasses [CoreToDo] -- lists of these things
226 | CoreDesugar -- Not strictly a core-to-core pass, but produces
227 -- Core output, and hence useful to pass to endPass
232 coreDumpFlag :: CoreToDo -> Maybe DynFlag
233 coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
234 coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
235 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
236 coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
237 coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
238 coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
239 coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
240 coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
241 coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
242 coreDumpFlag CoreCSE = Just Opt_D_dump_cse
243 coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
244 coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
245 coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
246 coreDumpFlag CorePrep = Just Opt_D_dump_prep
248 coreDumpFlag CoreDoPrintCore = Nothing
249 coreDumpFlag (CoreDoRuleCheck {}) = Nothing
250 coreDumpFlag CoreDoNothing = Nothing
251 coreDumpFlag CoreDoGlomBinds = Nothing
252 coreDumpFlag (CoreDoPasses {}) = Nothing
254 instance Outputable CoreToDo where
255 ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
257 <+> ptext (sLit "max-iterations=") <> int n
258 ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
259 ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
260 ppr CoreLiberateCase = ptext (sLit "Liberate case")
261 ppr CoreDoStaticArgs = ptext (sLit "Static argument")
262 ppr CoreDoStrictness = ptext (sLit "Demand analysis")
263 ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
264 ppr CoreDoSpecialising = ptext (sLit "Specialise")
265 ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
266 ppr CoreCSE = ptext (sLit "Common sub-expression")
267 ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
268 ppr CoreDesugar = ptext (sLit "Desugar")
269 ppr CoreTidy = ptext (sLit "Tidy Core")
270 ppr CorePrep = ptext (sLit "CorePrep")
271 ppr CoreDoPrintCore = ptext (sLit "Print core")
272 ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
273 ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
274 ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
275 ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
279 data SimplifierMode -- See comments in SimplMonad
281 { sm_rules :: Bool -- Whether RULES are enabled
282 , sm_inline :: Bool } -- Whether inlining is enabled
285 { sm_num :: Int -- Phase number; counts downward so 0 is last phase
286 , sm_names :: [String] } -- Name(s) of the phase
288 instance Outputable SimplifierMode where
289 ppr (SimplPhase { sm_num = n, sm_names = ss })
290 = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
291 ppr (SimplGently { sm_rules = r, sm_inline = i })
292 = ptext (sLit "gentle") <>
293 brackets (pp_flag r (sLit "rules") <> comma <>
294 pp_flag i (sLit "inline"))
296 pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
298 data SimplifierSwitch
304 data FloatOutSwitches = FloatOutSwitches {
305 floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
306 floatOutConstants :: Bool -- ^ True <=> float constants to top level,
307 -- even if they do not escape a lambda
309 instance Outputable FloatOutSwitches where
310 ppr = pprFloatOutSwitches
312 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
313 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
314 <+> pp_not (floatOutConstants sw) <+> text "constants"
317 pp_not False = text "not"
319 -- | Switches that specify the minimum amount of floating out
320 -- gentleFloatOutSwitches :: FloatOutSwitches
321 -- gentleFloatOutSwitches = FloatOutSwitches False False
323 -- | Switches that do not specify floating out of lambdas, just of constants
324 constantsOnlyFloatOutSwitches :: FloatOutSwitches
325 constantsOnlyFloatOutSwitches = FloatOutSwitches False True
329 %************************************************************************
331 Generating the main optimisation pipeline
333 %************************************************************************
336 getCoreToDo :: DynFlags -> [CoreToDo]
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
353 maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
355 maybe_strictness_before phase
356 = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
358 simpl_phase phase names iter
360 [ maybe_strictness_before phase
361 , CoreDoSimplify (SimplPhase phase names)
363 , maybe_rule_check phase
367 = runWhen (dopt Opt_Vectorise dflags)
368 $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
371 -- By default, we have 2 phases before phase 0.
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.
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] ]
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
395 NoCaseOfCase -- Don't do case-of-case transformations.
396 -- This makes full laziness work better
400 if opt_level == 0 then
402 simpl_phase 0 ["final"] max_iter]
403 else {- opt_level >= 1 -} [
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 ]),
411 -- We run vectorisation here for now, but we might also try to run
415 -- initial simplify: mk specialiser happy: minimum effort please
418 -- Specialisation is best done before full laziness
419 -- so that overloaded functions have all their dictionary lambdas manifest
420 runWhen do_specialise CoreDoSpecialising,
422 runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
423 -- Was: gentleFloatOutSwitches
424 -- I have no idea why, but not floating constants to top level is
425 -- very bad in some cases.
426 -- Notably: p_ident in spectral/rewrite
427 -- Changing from "gentle" to "constantsOnly" improved
428 -- rewrite's allocation by 19%, and made 0.0% difference
429 -- to any other nofib benchmark
431 runWhen do_float_in CoreDoFloatInwards,
435 -- Phase 0: allow all Ids to be inlined now
436 -- This gets foldr inlined before strictness analysis
438 -- At least 3 iterations because otherwise we land up with
439 -- huge dead expressions because of an infelicity in the
441 -- let k = BIG in foldr k z xs
442 -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
443 -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
445 simpl_phase 0 ["main"] (max max_iter 3),
447 runWhen strictness (CoreDoPasses [
451 simpl_phase 0 ["post-worker-wrapper"] max_iter
454 runWhen full_laziness
455 (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
456 -- nofib/spectral/hartel/wang doubles in speed if you
457 -- do full laziness late in the day. It only happens
458 -- after fusion and other stuff, so the early pass doesn't
459 -- catch it. For the record, the redex is
460 -- f_el22 (f_el21 r_midblock)
464 -- We want CSE to follow the final full-laziness pass, because it may
465 -- succeed in commoning up things floated out by full laziness.
466 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
468 runWhen do_float_in CoreDoFloatInwards,
472 -- Case-liberation for -O2. This should be after
473 -- strictness analysis and the simplification which follows it.
474 runWhen liberate_case (CoreDoPasses [
476 simpl_phase 0 ["post-liberate-case"] max_iter
477 ]), -- Run the simplifier after LiberateCase to vastly
478 -- reduce the possiblility of shadowing
479 -- Reason: see Note [Shadowing] in SpecConstr.lhs
481 runWhen spec_constr CoreDoSpecConstr,
485 -- Final clean-up simplification:
486 simpl_phase 0 ["final"] max_iter
489 -- The core-to-core pass ordering is derived from the DynFlags:
490 runWhen :: Bool -> CoreToDo -> CoreToDo
491 runWhen True do_this = do_this
492 runWhen False _ = CoreDoNothing
494 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
495 runMaybe (Just x) f = f x
496 runMaybe Nothing _ = CoreDoNothing
498 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
499 dumpSimplPhase dflags mode
500 | Just spec_string <- shouldDumpSimplPhase dflags
501 = match_spec spec_string
503 = dopt Opt_D_verbose_core2core dflags
506 match_spec :: String -> Bool
507 match_spec spec_string
508 = or $ map (and . map match . split ':')
509 $ split ',' spec_string
511 match :: String -> Bool
513 match s = case reads s of
514 [(n,"")] -> phase_num n
517 phase_num :: Int -> Bool
518 phase_num n = case mode of
519 SimplPhase k _ -> n == k
522 phase_name :: String -> Bool
523 phase_name s = case mode of
524 SimplGently {} -> s == "gentle"
525 SimplPhase { sm_names = ss } -> s `elem` ss
529 %************************************************************************
533 %************************************************************************
536 verboseSimplStats :: Bool
537 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
539 zeroSimplCount :: DynFlags -> SimplCount
540 isZeroSimplCount :: SimplCount -> Bool
541 pprSimplCount :: SimplCount -> SDoc
542 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
543 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
548 = VerySimplZero -- These two are used when
549 | VerySimplNonZero -- we are only interested in
553 ticks :: !Int, -- Total ticks
554 details :: !TickCounts, -- How many of each type
557 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
559 log2 :: [Tick] -- Last opt_HistorySize events before that
560 -- Having log1, log2 lets us accumulate the
561 -- recent history reasonably efficiently
564 type TickCounts = FiniteMap Tick Int
566 zeroSimplCount dflags
567 -- This is where we decide whether to do
568 -- the VerySimpl version or the full-stats version
569 | dopt Opt_D_dump_simpl_stats dflags
570 = SimplCount {ticks = 0, details = emptyFM,
571 n_log = 0, log1 = [], log2 = []}
575 isZeroSimplCount VerySimplZero = True
576 isZeroSimplCount (SimplCount { ticks = 0 }) = True
577 isZeroSimplCount _ = False
579 doFreeSimplTick tick sc@SimplCount { details = dts }
580 = sc { details = dts `addTick` tick }
581 doFreeSimplTick _ sc = sc
583 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
584 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
585 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
587 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
589 doSimplTick _ _ = VerySimplNonZero -- The very simple case
592 -- Don't use plusFM_C because that's lazy, and we want to
593 -- be pretty strict here!
594 addTick :: TickCounts -> Tick -> TickCounts
595 addTick fm tick = case lookupFM fm tick of
596 Nothing -> addToFM fm tick 1
597 Just n -> n1 `seq` addToFM fm tick n1
602 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
603 sc2@(SimplCount { ticks = tks2, details = dts2 })
604 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
606 -- A hackish way of getting recent log info
607 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
608 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
611 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
612 plusSimplCount _ _ = VerySimplNonZero
614 pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
615 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
616 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
617 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
619 pprTickCounts (fmToList dts),
620 if verboseSimplStats then
622 ptext (sLit "Log (most recent first)"),
623 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
627 pprTickCounts :: [(Tick,Int)] -> SDoc
628 pprTickCounts [] = empty
629 pprTickCounts ((tick1,n1):ticks)
630 = vcat [int tot_n <+> text (tickString tick1),
631 pprTCDetails real_these,
635 tick1_tag = tickToTag tick1
636 (these, others) = span same_tick ticks
637 real_these = (tick1,n1):these
638 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
639 tot_n = sum [n | (_,n) <- real_these]
641 pprTCDetails :: [(Tick, Int)] -> SDoc
643 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
649 = PreInlineUnconditionally Id
650 | PostInlineUnconditionally Id
653 | RuleFired FastString -- Rule name
656 | EtaExpansion Id -- LHS binder
657 | EtaReduction Id -- Binder on outer lambda
658 | BetaReduction Id -- Lambda binder
661 | CaseOfCase Id -- Bndr on *inner* case
662 | KnownBranch Id -- Case binder
663 | CaseMerge Id -- Binder on outer case
664 | AltMerge Id -- Case binder
665 | CaseElim Id -- Case binder
666 | CaseIdentity Id -- Case binder
667 | FillInCaseDefault Id -- Case binder
670 | SimplifierDone -- Ticked at each iteration of the simplifier
672 instance Outputable Tick where
673 ppr tick = text (tickString tick) <+> pprTickCts tick
675 instance Eq Tick where
676 a == b = case a `cmpTick` b of
680 instance Ord Tick where
683 tickToTag :: Tick -> Int
684 tickToTag (PreInlineUnconditionally _) = 0
685 tickToTag (PostInlineUnconditionally _) = 1
686 tickToTag (UnfoldingDone _) = 2
687 tickToTag (RuleFired _) = 3
688 tickToTag LetFloatFromLet = 4
689 tickToTag (EtaExpansion _) = 5
690 tickToTag (EtaReduction _) = 6
691 tickToTag (BetaReduction _) = 7
692 tickToTag (CaseOfCase _) = 8
693 tickToTag (KnownBranch _) = 9
694 tickToTag (CaseMerge _) = 10
695 tickToTag (CaseElim _) = 11
696 tickToTag (CaseIdentity _) = 12
697 tickToTag (FillInCaseDefault _) = 13
698 tickToTag BottomFound = 14
699 tickToTag SimplifierDone = 16
700 tickToTag (AltMerge _) = 17
702 tickString :: Tick -> String
703 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
704 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
705 tickString (UnfoldingDone _) = "UnfoldingDone"
706 tickString (RuleFired _) = "RuleFired"
707 tickString LetFloatFromLet = "LetFloatFromLet"
708 tickString (EtaExpansion _) = "EtaExpansion"
709 tickString (EtaReduction _) = "EtaReduction"
710 tickString (BetaReduction _) = "BetaReduction"
711 tickString (CaseOfCase _) = "CaseOfCase"
712 tickString (KnownBranch _) = "KnownBranch"
713 tickString (CaseMerge _) = "CaseMerge"
714 tickString (AltMerge _) = "AltMerge"
715 tickString (CaseElim _) = "CaseElim"
716 tickString (CaseIdentity _) = "CaseIdentity"
717 tickString (FillInCaseDefault _) = "FillInCaseDefault"
718 tickString BottomFound = "BottomFound"
719 tickString SimplifierDone = "SimplifierDone"
721 pprTickCts :: Tick -> SDoc
722 pprTickCts (PreInlineUnconditionally v) = ppr v
723 pprTickCts (PostInlineUnconditionally v)= ppr v
724 pprTickCts (UnfoldingDone v) = ppr v
725 pprTickCts (RuleFired v) = ppr v
726 pprTickCts LetFloatFromLet = empty
727 pprTickCts (EtaExpansion v) = ppr v
728 pprTickCts (EtaReduction v) = ppr v
729 pprTickCts (BetaReduction v) = ppr v
730 pprTickCts (CaseOfCase v) = ppr v
731 pprTickCts (KnownBranch v) = ppr v
732 pprTickCts (CaseMerge v) = ppr v
733 pprTickCts (AltMerge v) = ppr v
734 pprTickCts (CaseElim v) = ppr v
735 pprTickCts (CaseIdentity v) = ppr v
736 pprTickCts (FillInCaseDefault v) = ppr v
739 cmpTick :: Tick -> Tick -> Ordering
740 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
745 cmpEqTick :: Tick -> Tick -> Ordering
746 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
747 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
748 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
749 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
750 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
751 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
752 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
753 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
754 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
755 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
756 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
757 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
758 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
759 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
764 %************************************************************************
766 Monad and carried data structure definitions
768 %************************************************************************
771 newtype CoreState = CoreState {
772 cs_uniq_supply :: UniqSupply
775 data CoreReader = CoreReader {
776 cr_hsc_env :: HscEnv,
777 cr_rule_base :: RuleBase,
781 data CoreWriter = CoreWriter {
782 cw_simpl_count :: SimplCount
785 emptyWriter :: DynFlags -> CoreWriter
786 emptyWriter dflags = CoreWriter {
787 cw_simpl_count = zeroSimplCount dflags
790 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
791 plusWriter w1 w2 = CoreWriter {
792 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
795 type CoreIOEnv = IOEnv CoreReader
797 -- | The monad used by Core-to-Core passes to access common state, register simplification
798 -- statistics and so on
799 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
801 instance Functor CoreM where
806 instance Monad CoreM where
807 return x = CoreM (\s -> nop s x)
808 mx >>= f = CoreM $ \s -> do
809 (x, s', w1) <- unCoreM mx s
810 (y, s'', w2) <- unCoreM (f x) s'
811 return (y, s'', w1 `plusWriter` w2)
813 instance Applicative CoreM where
817 -- For use if the user has imported Control.Monad.Error from MTL
818 -- Requires UndecidableInstances
819 instance MonadPlus IO => MonadPlus CoreM where
820 mzero = CoreM (const mzero)
821 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
823 instance MonadUnique CoreM where
824 getUniqueSupplyM = do
825 us <- getS cs_uniq_supply
826 let (us1, us2) = splitUniqSupply us
827 modifyS (\s -> s { cs_uniq_supply = us2 })
835 -> IO (a, SimplCount)
836 runCoreM hsc_env rule_base us mod m =
837 liftM extract $ runIOEnv reader $ unCoreM m state
839 reader = CoreReader {
840 cr_hsc_env = hsc_env,
841 cr_rule_base = rule_base,
848 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
849 extract (value, _, writer) = (value, cw_simpl_count writer)
854 %************************************************************************
856 Core combinators, not exported
858 %************************************************************************
862 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
865 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
867 read :: (CoreReader -> a) -> CoreM a
868 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
870 getS :: (CoreState -> a) -> CoreM a
871 getS f = CoreM (\s -> nop s (f s))
873 modifyS :: (CoreState -> CoreState) -> CoreM ()
874 modifyS f = CoreM (\s -> nop (f s) ())
876 write :: CoreWriter -> CoreM ()
877 write w = CoreM (\s -> return ((), s, w))
881 \subsection{Lifting IO into the monad}
885 -- | Lift an 'IOEnv' operation into 'CoreM'
886 liftIOEnv :: CoreIOEnv a -> CoreM a
887 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
889 instance MonadIO CoreM where
890 liftIO = liftIOEnv . IOEnv.liftIO
892 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
893 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
894 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
899 %************************************************************************
901 Reader, writer and state accessors
903 %************************************************************************
907 getHscEnv :: CoreM HscEnv
908 getHscEnv = read cr_hsc_env
910 getRuleBase :: CoreM RuleBase
911 getRuleBase = read cr_rule_base
913 getModule :: CoreM Module
914 getModule = read cr_module
916 addSimplCount :: SimplCount -> CoreM ()
917 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
919 -- Convenience accessors for useful fields of HscEnv
921 getDynFlags :: CoreM DynFlags
922 getDynFlags = fmap hsc_dflags getHscEnv
924 -- | The original name cache is the current mapping from 'Module' and
925 -- 'OccName' to a compiler-wide unique 'Name'
926 getOrigNameCache :: CoreM OrigNameCache
927 getOrigNameCache = do
928 nameCacheRef <- fmap hsc_NC getHscEnv
929 liftIO $ fmap nsNames $ readIORef nameCacheRef
934 %************************************************************************
936 Dealing with annotations
938 %************************************************************************
941 -- | Get all annotations of a given type. This happens lazily, that is
942 -- no deserialization will take place until the [a] is actually demanded and
943 -- the [a] can also be empty (the UniqFM is not filtered).
945 -- This should be done once at the start of a Core-to-Core pass that uses
948 -- See Note [Annotations]
949 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
950 getAnnotations deserialize guts = do
952 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
953 return (deserializeAnns deserialize ann_env)
955 -- | Get at most one annotation of a given type per Unique.
956 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
957 getFirstAnnotations deserialize guts
958 = liftM (mapUFM head . filterUFM (not . null))
959 $ getAnnotations deserialize guts
965 A Core-to-Core pass that wants to make use of annotations calls
966 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
967 annotations of a specific type. This produces all annotations from interface
968 files read so far. However, annotations from interface files read during the
969 pass will not be visible until getAnnotations is called again. This is similar
970 to how rules work and probably isn't too bad.
972 The current implementation could be optimised a bit: when looking up
973 annotations for a thing from the HomePackageTable, we could search directly in
974 the module where the thing is defined rather than building one UniqFM which
975 contains all annotations we know of. This would work because annotations can
976 only be given to things defined in the same module. However, since we would
977 only want to deserialise every annotation once, we would have to build a cache
978 for every module in the HTP. In the end, it's probably not worth it as long as
979 we aren't using annotations heavily.
981 %************************************************************************
985 %************************************************************************
989 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
991 dflags <- getDynFlags
992 liftIO $ how dflags doc
994 -- | Output a String message to the screen
995 putMsgS :: String -> CoreM ()
996 putMsgS = putMsg . text
998 -- | Output a message to the screen
999 putMsg :: SDoc -> CoreM ()
1000 putMsg = msg Err.putMsg
1002 -- | Output a string error to the screen
1003 errorMsgS :: String -> CoreM ()
1004 errorMsgS = errorMsg . text
1006 -- | Output an error to the screen
1007 errorMsg :: SDoc -> CoreM ()
1008 errorMsg = msg Err.errorMsg
1010 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1011 fatalErrorMsgS :: String -> CoreM ()
1012 fatalErrorMsgS = fatalErrorMsg . text
1014 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1015 fatalErrorMsg :: SDoc -> CoreM ()
1016 fatalErrorMsg = msg Err.fatalErrorMsg
1018 -- | Output a string debugging message at verbosity level of @-v@ or higher
1019 debugTraceMsgS :: String -> CoreM ()
1020 debugTraceMsgS = debugTraceMsg . text
1022 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1023 debugTraceMsg :: SDoc -> CoreM ()
1024 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1026 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1027 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1028 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1033 initTcForLookup :: HscEnv -> TcM a -> IO a
1034 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1039 %************************************************************************
1043 %************************************************************************
1046 instance MonadThings CoreM where
1047 lookupThing name = do
1048 hsc_env <- getHscEnv
1049 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1052 %************************************************************************
1054 Template Haskell interoperability
1056 %************************************************************************
1060 -- | Attempt to convert a Template Haskell name to one that GHC can
1061 -- understand. Original TH names such as those you get when you use
1062 -- the @'foo@ syntax will be translated to their equivalent GHC name
1063 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1064 -- to names in the module being compiled, if possible. Exact TH names
1065 -- will be bound to the name they represent, exactly.
1066 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1067 thNameToGhcName th_name = do
1068 hsc_env <- getHscEnv
1069 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)