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 opt_NoDebugOutput
170 , showLintWarnings pass
171 = printDump (banner "warnings" $$ Err.pprMessageBag warns)
173 | otherwise = return ()
175 banner string = ptext (sLit "*** Core Lint") <+> text string
176 <+> ptext (sLit ": in result of") <+> ppr pass
177 <+> ptext (sLit "***")
179 showLintWarnings :: CoreToDo -> Bool
180 -- Disable Lint warnings on the first simplifier pass, because
181 -- there may be some INLINE knots still tied, which is tiresomely noisy
182 showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
183 showLintWarnings _ = True
187 %************************************************************************
189 The CoreToDo type and related types
190 Abstraction of core-to-core passes to run.
192 %************************************************************************
195 data CoreToDo -- These are diff core-to-core passes,
196 -- which may be invoked in any order,
197 -- as many times as you like.
199 = CoreDoSimplify -- The core-to-core simplifier.
201 Int -- Max iterations
202 [SimplifierSwitch] -- Each run of the simplifier can take a different
203 -- set of simplifier-specific flags.
205 | CoreDoFloatOutwards FloatOutSwitches
210 | CoreDoWorkerWrapper
215 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
216 -- matching this string
217 | CoreDoVectorisation PackageId
218 | CoreDoNothing -- Useful when building up
219 | CoreDoPasses [CoreToDo] -- lists of these things
221 | CoreDesugar -- Not strictly a core-to-core pass, but produces
222 -- Core output, and hence useful to pass to endPass
227 coreDumpFlag :: CoreToDo -> Maybe DynFlag
228 coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
229 coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
230 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
231 coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
232 coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
233 coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
234 coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
235 coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
236 coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
237 coreDumpFlag CoreCSE = Just Opt_D_dump_cse
238 coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
239 coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
240 coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
241 coreDumpFlag CorePrep = Just Opt_D_dump_prep
243 coreDumpFlag CoreDoPrintCore = Nothing
244 coreDumpFlag (CoreDoRuleCheck {}) = Nothing
245 coreDumpFlag CoreDoNothing = Nothing
246 coreDumpFlag CoreDoGlomBinds = Nothing
247 coreDumpFlag (CoreDoPasses {}) = Nothing
249 instance Outputable CoreToDo where
250 ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
252 <+> ptext (sLit "max-iterations=") <> int n
253 ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
254 ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
255 ppr CoreLiberateCase = ptext (sLit "Liberate case")
256 ppr CoreDoStaticArgs = ptext (sLit "Static argument")
257 ppr CoreDoStrictness = ptext (sLit "Demand analysis")
258 ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
259 ppr CoreDoSpecialising = ptext (sLit "Specialise")
260 ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
261 ppr CoreCSE = ptext (sLit "Common sub-expression")
262 ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
263 ppr CoreDesugar = ptext (sLit "Desugar")
264 ppr CoreTidy = ptext (sLit "Tidy Core")
265 ppr CorePrep = ptext (sLit "CorePrep")
266 ppr CoreDoPrintCore = ptext (sLit "Print core")
267 ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
268 ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
269 ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
270 ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
274 data SimplifierMode -- See comments in SimplMonad
276 { sm_rules :: Bool -- Whether RULES are enabled
277 , sm_inline :: Bool } -- Whether inlining is enabled
280 { sm_num :: Int -- Phase number; counts downward so 0 is last phase
281 , sm_names :: [String] } -- Name(s) of the phase
283 instance Outputable SimplifierMode where
284 ppr (SimplPhase { sm_num = n, sm_names = ss })
285 = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
286 ppr (SimplGently { sm_rules = r, sm_inline = i })
287 = ptext (sLit "gentle") <>
288 brackets (pp_flag r (sLit "rules") <> comma <>
289 pp_flag i (sLit "inline"))
291 pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
293 data SimplifierSwitch
299 data FloatOutSwitches = FloatOutSwitches {
300 floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
301 floatOutConstants :: Bool -- ^ True <=> float constants to top level,
302 -- even if they do not escape a lambda
304 instance Outputable FloatOutSwitches where
305 ppr = pprFloatOutSwitches
307 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
308 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
309 <+> pp_not (floatOutConstants sw) <+> text "constants"
312 pp_not False = text "not"
314 -- | Switches that specify the minimum amount of floating out
315 -- gentleFloatOutSwitches :: FloatOutSwitches
316 -- gentleFloatOutSwitches = FloatOutSwitches False False
318 -- | Switches that do not specify floating out of lambdas, just of constants
319 constantsOnlyFloatOutSwitches :: FloatOutSwitches
320 constantsOnlyFloatOutSwitches = FloatOutSwitches False True
324 %************************************************************************
326 Generating the main optimisation pipeline
328 %************************************************************************
331 getCoreToDo :: DynFlags -> [CoreToDo]
335 opt_level = optLevel dflags
336 phases = simplPhases dflags
337 max_iter = maxSimplIterations dflags
338 strictness = dopt Opt_Strictness dflags
339 full_laziness = dopt Opt_FullLaziness dflags
340 do_specialise = dopt Opt_Specialise dflags
341 do_float_in = dopt Opt_FloatIn dflags
342 cse = dopt Opt_CSE dflags
343 spec_constr = dopt Opt_SpecConstr dflags
344 liberate_case = dopt Opt_LiberateCase dflags
345 rule_check = ruleCheck dflags
346 static_args = dopt Opt_StaticArgumentTransformation dflags
348 maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
350 maybe_strictness_before phase
351 = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
353 simpl_phase phase names iter
355 [ maybe_strictness_before phase
356 , CoreDoSimplify (SimplPhase phase names)
358 , maybe_rule_check phase
362 = runWhen (dopt Opt_Vectorise dflags)
363 $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
366 -- By default, we have 2 phases before phase 0.
368 -- Want to run with inline phase 2 after the specialiser to give
369 -- maximum chance for fusion to work before we inline build/augment
370 -- in phase 1. This made a difference in 'ansi' where an
371 -- overloaded function wasn't inlined till too late.
373 -- Need phase 1 so that build/augment get
374 -- inlined. I found that spectral/hartel/genfft lost some useful
375 -- strictness in the function sumcode' if augment is not inlined
376 -- before strictness analysis runs
377 simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
378 | phase <- [phases, phases-1 .. 1] ]
381 -- initial simplify: mk specialiser happy: minimum effort please
382 simpl_gently = CoreDoSimplify
383 (SimplGently { sm_rules = True, sm_inline = False })
387 -- Don't inline anything till full laziness has bitten
388 -- In particular, inlining wrappers inhibits floating
389 -- e.g. ...(case f x of ...)...
390 -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
391 -- ==> ...(case x of I# x# -> case fw x# of ...)...
392 -- and now the redex (f x) isn't floatable any more
393 -- Similarly, don't apply any rules until after full
394 -- laziness. Notably, list fusion can prevent floating.
396 NoCaseOfCase -- Don't do case-of-case transformations.
397 -- This makes full laziness work better
401 if opt_level == 0 then
403 simpl_phase 0 ["final"] max_iter]
404 else {- opt_level >= 1 -} [
406 -- We want to do the static argument transform before full laziness as it
407 -- may expose extra opportunities to float things outwards. However, to fix
408 -- up the output of the transformation we need at do at least one simplify
409 -- after this before anything else
410 runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
412 -- We run vectorisation here for now, but we might also try to run
416 -- initial simplify: mk specialiser happy: minimum effort please
419 -- Specialisation is best done before full laziness
420 -- so that overloaded functions have all their dictionary lambdas manifest
421 runWhen do_specialise CoreDoSpecialising,
423 runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
424 -- Was: gentleFloatOutSwitches
425 -- I have no idea why, but not floating constants to top level is
426 -- very bad in some cases.
427 -- Notably: p_ident in spectral/rewrite
428 -- Changing from "gentle" to "constantsOnly" improved
429 -- rewrite's allocation by 19%, and made 0.0% difference
430 -- to any other nofib benchmark
432 runWhen do_float_in CoreDoFloatInwards,
436 -- Phase 0: allow all Ids to be inlined now
437 -- This gets foldr inlined before strictness analysis
439 -- At least 3 iterations because otherwise we land up with
440 -- huge dead expressions because of an infelicity in the
442 -- let k = BIG in foldr k z xs
443 -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
444 -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
446 simpl_phase 0 ["main"] (max max_iter 3),
448 runWhen strictness (CoreDoPasses [
452 simpl_phase 0 ["post-worker-wrapper"] max_iter
455 runWhen full_laziness
456 (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
457 -- nofib/spectral/hartel/wang doubles in speed if you
458 -- do full laziness late in the day. It only happens
459 -- after fusion and other stuff, so the early pass doesn't
460 -- catch it. For the record, the redex is
461 -- f_el22 (f_el21 r_midblock)
465 -- We want CSE to follow the final full-laziness pass, because it may
466 -- succeed in commoning up things floated out by full laziness.
467 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
469 runWhen do_float_in CoreDoFloatInwards,
473 -- Case-liberation for -O2. This should be after
474 -- strictness analysis and the simplification which follows it.
475 runWhen liberate_case (CoreDoPasses [
477 simpl_phase 0 ["post-liberate-case"] max_iter
478 ]), -- Run the simplifier after LiberateCase to vastly
479 -- reduce the possiblility of shadowing
480 -- Reason: see Note [Shadowing] in SpecConstr.lhs
482 runWhen spec_constr CoreDoSpecConstr,
486 -- Final clean-up simplification:
487 simpl_phase 0 ["final"] max_iter
490 -- The core-to-core pass ordering is derived from the DynFlags:
491 runWhen :: Bool -> CoreToDo -> CoreToDo
492 runWhen True do_this = do_this
493 runWhen False _ = CoreDoNothing
495 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
496 runMaybe (Just x) f = f x
497 runMaybe Nothing _ = CoreDoNothing
499 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
500 dumpSimplPhase dflags mode
501 | Just spec_string <- shouldDumpSimplPhase dflags
502 = match_spec spec_string
504 = dopt Opt_D_verbose_core2core dflags
507 match_spec :: String -> Bool
508 match_spec spec_string
509 = or $ map (and . map match . split ':')
510 $ split ',' spec_string
512 match :: String -> Bool
514 match s = case reads s of
515 [(n,"")] -> phase_num n
518 phase_num :: Int -> Bool
519 phase_num n = case mode of
520 SimplPhase k _ -> n == k
523 phase_name :: String -> Bool
524 phase_name s = case mode of
525 SimplGently {} -> s == "gentle"
526 SimplPhase { sm_names = ss } -> s `elem` ss
530 %************************************************************************
534 %************************************************************************
537 verboseSimplStats :: Bool
538 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
540 zeroSimplCount :: DynFlags -> SimplCount
541 isZeroSimplCount :: SimplCount -> Bool
542 pprSimplCount :: SimplCount -> SDoc
543 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
544 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
549 = VerySimplZero -- These two are used when
550 | VerySimplNonZero -- we are only interested in
554 ticks :: !Int, -- Total ticks
555 details :: !TickCounts, -- How many of each type
558 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
560 log2 :: [Tick] -- Last opt_HistorySize events before that
561 -- Having log1, log2 lets us accumulate the
562 -- recent history reasonably efficiently
565 type TickCounts = FiniteMap Tick Int
567 zeroSimplCount dflags
568 -- This is where we decide whether to do
569 -- the VerySimpl version or the full-stats version
570 | dopt Opt_D_dump_simpl_stats dflags
571 = SimplCount {ticks = 0, details = emptyFM,
572 n_log = 0, log1 = [], log2 = []}
576 isZeroSimplCount VerySimplZero = True
577 isZeroSimplCount (SimplCount { ticks = 0 }) = True
578 isZeroSimplCount _ = False
580 doFreeSimplTick tick sc@SimplCount { details = dts }
581 = sc { details = dts `addTick` tick }
582 doFreeSimplTick _ sc = sc
584 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
585 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
586 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
588 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
590 doSimplTick _ _ = VerySimplNonZero -- The very simple case
593 -- Don't use plusFM_C because that's lazy, and we want to
594 -- be pretty strict here!
595 addTick :: TickCounts -> Tick -> TickCounts
596 addTick fm tick = case lookupFM fm tick of
597 Nothing -> addToFM fm tick 1
598 Just n -> n1 `seq` addToFM fm tick n1
603 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
604 sc2@(SimplCount { ticks = tks2, details = dts2 })
605 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
607 -- A hackish way of getting recent log info
608 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
609 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
612 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
613 plusSimplCount _ _ = VerySimplNonZero
615 pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
616 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
617 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
618 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
620 pprTickCounts (fmToList dts),
621 if verboseSimplStats then
623 ptext (sLit "Log (most recent first)"),
624 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
628 pprTickCounts :: [(Tick,Int)] -> SDoc
629 pprTickCounts [] = empty
630 pprTickCounts ((tick1,n1):ticks)
631 = vcat [int tot_n <+> text (tickString tick1),
632 pprTCDetails real_these,
636 tick1_tag = tickToTag tick1
637 (these, others) = span same_tick ticks
638 real_these = (tick1,n1):these
639 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
640 tot_n = sum [n | (_,n) <- real_these]
642 pprTCDetails :: [(Tick, Int)] -> SDoc
644 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
650 = PreInlineUnconditionally Id
651 | PostInlineUnconditionally Id
654 | RuleFired FastString -- Rule name
657 | EtaExpansion Id -- LHS binder
658 | EtaReduction Id -- Binder on outer lambda
659 | BetaReduction Id -- Lambda binder
662 | CaseOfCase Id -- Bndr on *inner* case
663 | KnownBranch Id -- Case binder
664 | CaseMerge Id -- Binder on outer case
665 | AltMerge Id -- Case binder
666 | CaseElim Id -- Case binder
667 | CaseIdentity Id -- Case binder
668 | FillInCaseDefault Id -- Case binder
671 | SimplifierDone -- Ticked at each iteration of the simplifier
673 instance Outputable Tick where
674 ppr tick = text (tickString tick) <+> pprTickCts tick
676 instance Eq Tick where
677 a == b = case a `cmpTick` b of
681 instance Ord Tick where
684 tickToTag :: Tick -> Int
685 tickToTag (PreInlineUnconditionally _) = 0
686 tickToTag (PostInlineUnconditionally _) = 1
687 tickToTag (UnfoldingDone _) = 2
688 tickToTag (RuleFired _) = 3
689 tickToTag LetFloatFromLet = 4
690 tickToTag (EtaExpansion _) = 5
691 tickToTag (EtaReduction _) = 6
692 tickToTag (BetaReduction _) = 7
693 tickToTag (CaseOfCase _) = 8
694 tickToTag (KnownBranch _) = 9
695 tickToTag (CaseMerge _) = 10
696 tickToTag (CaseElim _) = 11
697 tickToTag (CaseIdentity _) = 12
698 tickToTag (FillInCaseDefault _) = 13
699 tickToTag BottomFound = 14
700 tickToTag SimplifierDone = 16
701 tickToTag (AltMerge _) = 17
703 tickString :: Tick -> String
704 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
705 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
706 tickString (UnfoldingDone _) = "UnfoldingDone"
707 tickString (RuleFired _) = "RuleFired"
708 tickString LetFloatFromLet = "LetFloatFromLet"
709 tickString (EtaExpansion _) = "EtaExpansion"
710 tickString (EtaReduction _) = "EtaReduction"
711 tickString (BetaReduction _) = "BetaReduction"
712 tickString (CaseOfCase _) = "CaseOfCase"
713 tickString (KnownBranch _) = "KnownBranch"
714 tickString (CaseMerge _) = "CaseMerge"
715 tickString (AltMerge _) = "AltMerge"
716 tickString (CaseElim _) = "CaseElim"
717 tickString (CaseIdentity _) = "CaseIdentity"
718 tickString (FillInCaseDefault _) = "FillInCaseDefault"
719 tickString BottomFound = "BottomFound"
720 tickString SimplifierDone = "SimplifierDone"
722 pprTickCts :: Tick -> SDoc
723 pprTickCts (PreInlineUnconditionally v) = ppr v
724 pprTickCts (PostInlineUnconditionally v)= ppr v
725 pprTickCts (UnfoldingDone v) = ppr v
726 pprTickCts (RuleFired v) = ppr v
727 pprTickCts LetFloatFromLet = empty
728 pprTickCts (EtaExpansion v) = ppr v
729 pprTickCts (EtaReduction v) = ppr v
730 pprTickCts (BetaReduction v) = ppr v
731 pprTickCts (CaseOfCase v) = ppr v
732 pprTickCts (KnownBranch v) = ppr v
733 pprTickCts (CaseMerge v) = ppr v
734 pprTickCts (AltMerge v) = ppr v
735 pprTickCts (CaseElim v) = ppr v
736 pprTickCts (CaseIdentity v) = ppr v
737 pprTickCts (FillInCaseDefault v) = ppr v
740 cmpTick :: Tick -> Tick -> Ordering
741 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
746 cmpEqTick :: Tick -> Tick -> Ordering
747 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
748 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
749 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
750 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
751 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
752 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
753 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
754 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
755 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
756 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
757 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
758 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
759 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
760 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
765 %************************************************************************
767 Monad and carried data structure definitions
769 %************************************************************************
772 newtype CoreState = CoreState {
773 cs_uniq_supply :: UniqSupply
776 data CoreReader = CoreReader {
777 cr_hsc_env :: HscEnv,
778 cr_rule_base :: RuleBase,
782 data CoreWriter = CoreWriter {
783 cw_simpl_count :: SimplCount
786 emptyWriter :: DynFlags -> CoreWriter
787 emptyWriter dflags = CoreWriter {
788 cw_simpl_count = zeroSimplCount dflags
791 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
792 plusWriter w1 w2 = CoreWriter {
793 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
796 type CoreIOEnv = IOEnv CoreReader
798 -- | The monad used by Core-to-Core passes to access common state, register simplification
799 -- statistics and so on
800 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
802 instance Functor CoreM where
807 instance Monad CoreM where
808 return x = CoreM (\s -> nop s x)
809 mx >>= f = CoreM $ \s -> do
810 (x, s', w1) <- unCoreM mx s
811 (y, s'', w2) <- unCoreM (f x) s'
812 return (y, s'', w1 `plusWriter` w2)
814 instance Applicative CoreM where
818 -- For use if the user has imported Control.Monad.Error from MTL
819 -- Requires UndecidableInstances
820 instance MonadPlus IO => MonadPlus CoreM where
821 mzero = CoreM (const mzero)
822 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
824 instance MonadUnique CoreM where
825 getUniqueSupplyM = do
826 us <- getS cs_uniq_supply
827 let (us1, us2) = splitUniqSupply us
828 modifyS (\s -> s { cs_uniq_supply = us2 })
836 -> IO (a, SimplCount)
837 runCoreM hsc_env rule_base us mod m =
838 liftM extract $ runIOEnv reader $ unCoreM m state
840 reader = CoreReader {
841 cr_hsc_env = hsc_env,
842 cr_rule_base = rule_base,
849 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
850 extract (value, _, writer) = (value, cw_simpl_count writer)
855 %************************************************************************
857 Core combinators, not exported
859 %************************************************************************
863 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
866 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
868 read :: (CoreReader -> a) -> CoreM a
869 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
871 getS :: (CoreState -> a) -> CoreM a
872 getS f = CoreM (\s -> nop s (f s))
874 modifyS :: (CoreState -> CoreState) -> CoreM ()
875 modifyS f = CoreM (\s -> nop (f s) ())
877 write :: CoreWriter -> CoreM ()
878 write w = CoreM (\s -> return ((), s, w))
882 \subsection{Lifting IO into the monad}
886 -- | Lift an 'IOEnv' operation into 'CoreM'
887 liftIOEnv :: CoreIOEnv a -> CoreM a
888 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
890 instance MonadIO CoreM where
891 liftIO = liftIOEnv . IOEnv.liftIO
893 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
894 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
895 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
900 %************************************************************************
902 Reader, writer and state accessors
904 %************************************************************************
908 getHscEnv :: CoreM HscEnv
909 getHscEnv = read cr_hsc_env
911 getRuleBase :: CoreM RuleBase
912 getRuleBase = read cr_rule_base
914 getModule :: CoreM Module
915 getModule = read cr_module
917 addSimplCount :: SimplCount -> CoreM ()
918 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
920 -- Convenience accessors for useful fields of HscEnv
922 getDynFlags :: CoreM DynFlags
923 getDynFlags = fmap hsc_dflags getHscEnv
925 -- | The original name cache is the current mapping from 'Module' and
926 -- 'OccName' to a compiler-wide unique 'Name'
927 getOrigNameCache :: CoreM OrigNameCache
928 getOrigNameCache = do
929 nameCacheRef <- fmap hsc_NC getHscEnv
930 liftIO $ fmap nsNames $ readIORef nameCacheRef
935 %************************************************************************
937 Dealing with annotations
939 %************************************************************************
942 -- | Get all annotations of a given type. This happens lazily, that is
943 -- no deserialization will take place until the [a] is actually demanded and
944 -- the [a] can also be empty (the UniqFM is not filtered).
946 -- This should be done once at the start of a Core-to-Core pass that uses
949 -- See Note [Annotations]
950 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
951 getAnnotations deserialize guts = do
953 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
954 return (deserializeAnns deserialize ann_env)
956 -- | Get at most one annotation of a given type per Unique.
957 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
958 getFirstAnnotations deserialize guts
959 = liftM (mapUFM head . filterUFM (not . null))
960 $ getAnnotations deserialize guts
966 A Core-to-Core pass that wants to make use of annotations calls
967 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
968 annotations of a specific type. This produces all annotations from interface
969 files read so far. However, annotations from interface files read during the
970 pass will not be visible until getAnnotations is called again. This is similar
971 to how rules work and probably isn't too bad.
973 The current implementation could be optimised a bit: when looking up
974 annotations for a thing from the HomePackageTable, we could search directly in
975 the module where the thing is defined rather than building one UniqFM which
976 contains all annotations we know of. This would work because annotations can
977 only be given to things defined in the same module. However, since we would
978 only want to deserialise every annotation once, we would have to build a cache
979 for every module in the HTP. In the end, it's probably not worth it as long as
980 we aren't using annotations heavily.
982 %************************************************************************
986 %************************************************************************
990 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
992 dflags <- getDynFlags
993 liftIO $ how dflags doc
995 -- | Output a String message to the screen
996 putMsgS :: String -> CoreM ()
997 putMsgS = putMsg . text
999 -- | Output a message to the screen
1000 putMsg :: SDoc -> CoreM ()
1001 putMsg = msg Err.putMsg
1003 -- | Output a string error to the screen
1004 errorMsgS :: String -> CoreM ()
1005 errorMsgS = errorMsg . text
1007 -- | Output an error to the screen
1008 errorMsg :: SDoc -> CoreM ()
1009 errorMsg = msg Err.errorMsg
1011 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1012 fatalErrorMsgS :: String -> CoreM ()
1013 fatalErrorMsgS = fatalErrorMsg . text
1015 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1016 fatalErrorMsg :: SDoc -> CoreM ()
1017 fatalErrorMsg = msg Err.fatalErrorMsg
1019 -- | Output a string debugging message at verbosity level of @-v@ or higher
1020 debugTraceMsgS :: String -> CoreM ()
1021 debugTraceMsgS = debugTraceMsg . text
1023 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1024 debugTraceMsg :: SDoc -> CoreM ()
1025 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1027 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1028 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1029 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1034 initTcForLookup :: HscEnv -> TcM a -> IO a
1035 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1040 %************************************************************************
1044 %************************************************************************
1047 instance MonadThings CoreM where
1048 lookupThing name = do
1049 hsc_env <- getHscEnv
1050 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1053 %************************************************************************
1055 Template Haskell interoperability
1057 %************************************************************************
1061 -- | Attempt to convert a Template Haskell name to one that GHC can
1062 -- understand. Original TH names such as those you get when you use
1063 -- the @'foo@ syntax will be translated to their equivalent GHC name
1064 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1065 -- to names in the module being compiled, if possible. Exact TH names
1066 -- will be bound to the name they represent, exactly.
1067 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1068 thNameToGhcName th_name = do
1069 hsc_env <- getHscEnv
1070 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)