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 })
384 -- See Note [Gentle mode] and
385 -- Note [RULEs enabled in SimplGently] in SimplUtils
390 NoCaseOfCase -- Don't do case-of-case transformations.
391 -- This makes full laziness work better
395 if opt_level == 0 then
397 simpl_phase 0 ["final"] max_iter]
398 else {- opt_level >= 1 -} [
400 -- We want to do the static argument transform before full laziness as it
401 -- may expose extra opportunities to float things outwards. However, to fix
402 -- up the output of the transformation we need at do at least one simplify
403 -- after this before anything else
404 runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
406 -- We run vectorisation here for now, but we might also try to run
410 -- initial simplify: mk specialiser happy: minimum effort please
413 -- Specialisation is best done before full laziness
414 -- so that overloaded functions have all their dictionary lambdas manifest
415 runWhen do_specialise CoreDoSpecialising,
417 runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
418 -- Was: gentleFloatOutSwitches
419 -- I have no idea why, but not floating constants to top level is
420 -- very bad in some cases.
421 -- Notably: p_ident in spectral/rewrite
422 -- Changing from "gentle" to "constantsOnly" improved
423 -- rewrite's allocation by 19%, and made 0.0% difference
424 -- to any other nofib benchmark
426 runWhen do_float_in CoreDoFloatInwards,
430 -- Phase 0: allow all Ids to be inlined now
431 -- This gets foldr inlined before strictness analysis
433 -- At least 3 iterations because otherwise we land up with
434 -- huge dead expressions because of an infelicity in the
436 -- let k = BIG in foldr k z xs
437 -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
438 -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
440 simpl_phase 0 ["main"] (max max_iter 3),
442 runWhen strictness (CoreDoPasses [
446 simpl_phase 0 ["post-worker-wrapper"] max_iter
449 runWhen full_laziness
450 (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
451 -- nofib/spectral/hartel/wang doubles in speed if you
452 -- do full laziness late in the day. It only happens
453 -- after fusion and other stuff, so the early pass doesn't
454 -- catch it. For the record, the redex is
455 -- f_el22 (f_el21 r_midblock)
459 -- We want CSE to follow the final full-laziness pass, because it may
460 -- succeed in commoning up things floated out by full laziness.
461 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
463 runWhen do_float_in CoreDoFloatInwards,
467 -- Case-liberation for -O2. This should be after
468 -- strictness analysis and the simplification which follows it.
469 runWhen liberate_case (CoreDoPasses [
471 simpl_phase 0 ["post-liberate-case"] max_iter
472 ]), -- Run the simplifier after LiberateCase to vastly
473 -- reduce the possiblility of shadowing
474 -- Reason: see Note [Shadowing] in SpecConstr.lhs
476 runWhen spec_constr CoreDoSpecConstr,
480 -- Final clean-up simplification:
481 simpl_phase 0 ["final"] max_iter
484 -- The core-to-core pass ordering is derived from the DynFlags:
485 runWhen :: Bool -> CoreToDo -> CoreToDo
486 runWhen True do_this = do_this
487 runWhen False _ = CoreDoNothing
489 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
490 runMaybe (Just x) f = f x
491 runMaybe Nothing _ = CoreDoNothing
493 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
494 dumpSimplPhase dflags mode
495 | Just spec_string <- shouldDumpSimplPhase dflags
496 = match_spec spec_string
498 = dopt Opt_D_verbose_core2core dflags
501 match_spec :: String -> Bool
502 match_spec spec_string
503 = or $ map (and . map match . split ':')
504 $ split ',' spec_string
506 match :: String -> Bool
508 match s = case reads s of
509 [(n,"")] -> phase_num n
512 phase_num :: Int -> Bool
513 phase_num n = case mode of
514 SimplPhase k _ -> n == k
517 phase_name :: String -> Bool
518 phase_name s = case mode of
519 SimplGently {} -> s == "gentle"
520 SimplPhase { sm_names = ss } -> s `elem` ss
524 %************************************************************************
528 %************************************************************************
531 verboseSimplStats :: Bool
532 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
534 zeroSimplCount :: DynFlags -> SimplCount
535 isZeroSimplCount :: SimplCount -> Bool
536 pprSimplCount :: SimplCount -> SDoc
537 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
538 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
543 = VerySimplZero -- These two are used when
544 | VerySimplNonZero -- we are only interested in
548 ticks :: !Int, -- Total ticks
549 details :: !TickCounts, -- How many of each type
552 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
554 log2 :: [Tick] -- Last opt_HistorySize events before that
555 -- Having log1, log2 lets us accumulate the
556 -- recent history reasonably efficiently
559 type TickCounts = FiniteMap Tick Int
561 zeroSimplCount dflags
562 -- This is where we decide whether to do
563 -- the VerySimpl version or the full-stats version
564 | dopt Opt_D_dump_simpl_stats dflags
565 = SimplCount {ticks = 0, details = emptyFM,
566 n_log = 0, log1 = [], log2 = []}
570 isZeroSimplCount VerySimplZero = True
571 isZeroSimplCount (SimplCount { ticks = 0 }) = True
572 isZeroSimplCount _ = False
574 doFreeSimplTick tick sc@SimplCount { details = dts }
575 = sc { details = dts `addTick` tick }
576 doFreeSimplTick _ sc = sc
578 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
579 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
580 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
582 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
584 doSimplTick _ _ = VerySimplNonZero -- The very simple case
587 -- Don't use plusFM_C because that's lazy, and we want to
588 -- be pretty strict here!
589 addTick :: TickCounts -> Tick -> TickCounts
590 addTick fm tick = case lookupFM fm tick of
591 Nothing -> addToFM fm tick 1
592 Just n -> n1 `seq` addToFM fm tick n1
597 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
598 sc2@(SimplCount { ticks = tks2, details = dts2 })
599 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
601 -- A hackish way of getting recent log info
602 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
603 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
606 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
607 plusSimplCount _ _ = VerySimplNonZero
609 pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
610 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
611 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
612 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
614 pprTickCounts (fmToList dts),
615 if verboseSimplStats then
617 ptext (sLit "Log (most recent first)"),
618 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
622 pprTickCounts :: [(Tick,Int)] -> SDoc
623 pprTickCounts [] = empty
624 pprTickCounts ((tick1,n1):ticks)
625 = vcat [int tot_n <+> text (tickString tick1),
626 pprTCDetails real_these,
630 tick1_tag = tickToTag tick1
631 (these, others) = span same_tick ticks
632 real_these = (tick1,n1):these
633 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
634 tot_n = sum [n | (_,n) <- real_these]
636 pprTCDetails :: [(Tick, Int)] -> SDoc
638 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
644 = PreInlineUnconditionally Id
645 | PostInlineUnconditionally Id
648 | RuleFired FastString -- Rule name
651 | EtaExpansion Id -- LHS binder
652 | EtaReduction Id -- Binder on outer lambda
653 | BetaReduction Id -- Lambda binder
656 | CaseOfCase Id -- Bndr on *inner* case
657 | KnownBranch Id -- Case binder
658 | CaseMerge Id -- Binder on outer case
659 | AltMerge Id -- Case binder
660 | CaseElim Id -- Case binder
661 | CaseIdentity Id -- Case binder
662 | FillInCaseDefault Id -- Case binder
665 | SimplifierDone -- Ticked at each iteration of the simplifier
667 instance Outputable Tick where
668 ppr tick = text (tickString tick) <+> pprTickCts tick
670 instance Eq Tick where
671 a == b = case a `cmpTick` b of
675 instance Ord Tick where
678 tickToTag :: Tick -> Int
679 tickToTag (PreInlineUnconditionally _) = 0
680 tickToTag (PostInlineUnconditionally _) = 1
681 tickToTag (UnfoldingDone _) = 2
682 tickToTag (RuleFired _) = 3
683 tickToTag LetFloatFromLet = 4
684 tickToTag (EtaExpansion _) = 5
685 tickToTag (EtaReduction _) = 6
686 tickToTag (BetaReduction _) = 7
687 tickToTag (CaseOfCase _) = 8
688 tickToTag (KnownBranch _) = 9
689 tickToTag (CaseMerge _) = 10
690 tickToTag (CaseElim _) = 11
691 tickToTag (CaseIdentity _) = 12
692 tickToTag (FillInCaseDefault _) = 13
693 tickToTag BottomFound = 14
694 tickToTag SimplifierDone = 16
695 tickToTag (AltMerge _) = 17
697 tickString :: Tick -> String
698 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
699 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
700 tickString (UnfoldingDone _) = "UnfoldingDone"
701 tickString (RuleFired _) = "RuleFired"
702 tickString LetFloatFromLet = "LetFloatFromLet"
703 tickString (EtaExpansion _) = "EtaExpansion"
704 tickString (EtaReduction _) = "EtaReduction"
705 tickString (BetaReduction _) = "BetaReduction"
706 tickString (CaseOfCase _) = "CaseOfCase"
707 tickString (KnownBranch _) = "KnownBranch"
708 tickString (CaseMerge _) = "CaseMerge"
709 tickString (AltMerge _) = "AltMerge"
710 tickString (CaseElim _) = "CaseElim"
711 tickString (CaseIdentity _) = "CaseIdentity"
712 tickString (FillInCaseDefault _) = "FillInCaseDefault"
713 tickString BottomFound = "BottomFound"
714 tickString SimplifierDone = "SimplifierDone"
716 pprTickCts :: Tick -> SDoc
717 pprTickCts (PreInlineUnconditionally v) = ppr v
718 pprTickCts (PostInlineUnconditionally v)= ppr v
719 pprTickCts (UnfoldingDone v) = ppr v
720 pprTickCts (RuleFired v) = ppr v
721 pprTickCts LetFloatFromLet = empty
722 pprTickCts (EtaExpansion v) = ppr v
723 pprTickCts (EtaReduction v) = ppr v
724 pprTickCts (BetaReduction v) = ppr v
725 pprTickCts (CaseOfCase v) = ppr v
726 pprTickCts (KnownBranch v) = ppr v
727 pprTickCts (CaseMerge v) = ppr v
728 pprTickCts (AltMerge v) = ppr v
729 pprTickCts (CaseElim v) = ppr v
730 pprTickCts (CaseIdentity v) = ppr v
731 pprTickCts (FillInCaseDefault v) = ppr v
734 cmpTick :: Tick -> Tick -> Ordering
735 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
740 cmpEqTick :: Tick -> Tick -> Ordering
741 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
742 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
743 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
744 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
745 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
746 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
747 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
748 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
749 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
750 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
751 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
752 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
753 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
754 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
759 %************************************************************************
761 Monad and carried data structure definitions
763 %************************************************************************
766 newtype CoreState = CoreState {
767 cs_uniq_supply :: UniqSupply
770 data CoreReader = CoreReader {
771 cr_hsc_env :: HscEnv,
772 cr_rule_base :: RuleBase,
776 data CoreWriter = CoreWriter {
777 cw_simpl_count :: SimplCount
780 emptyWriter :: DynFlags -> CoreWriter
781 emptyWriter dflags = CoreWriter {
782 cw_simpl_count = zeroSimplCount dflags
785 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
786 plusWriter w1 w2 = CoreWriter {
787 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
790 type CoreIOEnv = IOEnv CoreReader
792 -- | The monad used by Core-to-Core passes to access common state, register simplification
793 -- statistics and so on
794 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
796 instance Functor CoreM where
801 instance Monad CoreM where
802 return x = CoreM (\s -> nop s x)
803 mx >>= f = CoreM $ \s -> do
804 (x, s', w1) <- unCoreM mx s
805 (y, s'', w2) <- unCoreM (f x) s'
806 return (y, s'', w1 `plusWriter` w2)
808 instance Applicative CoreM where
812 -- For use if the user has imported Control.Monad.Error from MTL
813 -- Requires UndecidableInstances
814 instance MonadPlus IO => MonadPlus CoreM where
815 mzero = CoreM (const mzero)
816 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
818 instance MonadUnique CoreM where
819 getUniqueSupplyM = do
820 us <- getS cs_uniq_supply
821 let (us1, us2) = splitUniqSupply us
822 modifyS (\s -> s { cs_uniq_supply = us2 })
830 -> IO (a, SimplCount)
831 runCoreM hsc_env rule_base us mod m =
832 liftM extract $ runIOEnv reader $ unCoreM m state
834 reader = CoreReader {
835 cr_hsc_env = hsc_env,
836 cr_rule_base = rule_base,
843 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
844 extract (value, _, writer) = (value, cw_simpl_count writer)
849 %************************************************************************
851 Core combinators, not exported
853 %************************************************************************
857 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
860 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
862 read :: (CoreReader -> a) -> CoreM a
863 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
865 getS :: (CoreState -> a) -> CoreM a
866 getS f = CoreM (\s -> nop s (f s))
868 modifyS :: (CoreState -> CoreState) -> CoreM ()
869 modifyS f = CoreM (\s -> nop (f s) ())
871 write :: CoreWriter -> CoreM ()
872 write w = CoreM (\s -> return ((), s, w))
876 \subsection{Lifting IO into the monad}
880 -- | Lift an 'IOEnv' operation into 'CoreM'
881 liftIOEnv :: CoreIOEnv a -> CoreM a
882 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
884 instance MonadIO CoreM where
885 liftIO = liftIOEnv . IOEnv.liftIO
887 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
888 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
889 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
894 %************************************************************************
896 Reader, writer and state accessors
898 %************************************************************************
902 getHscEnv :: CoreM HscEnv
903 getHscEnv = read cr_hsc_env
905 getRuleBase :: CoreM RuleBase
906 getRuleBase = read cr_rule_base
908 getModule :: CoreM Module
909 getModule = read cr_module
911 addSimplCount :: SimplCount -> CoreM ()
912 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
914 -- Convenience accessors for useful fields of HscEnv
916 getDynFlags :: CoreM DynFlags
917 getDynFlags = fmap hsc_dflags getHscEnv
919 -- | The original name cache is the current mapping from 'Module' and
920 -- 'OccName' to a compiler-wide unique 'Name'
921 getOrigNameCache :: CoreM OrigNameCache
922 getOrigNameCache = do
923 nameCacheRef <- fmap hsc_NC getHscEnv
924 liftIO $ fmap nsNames $ readIORef nameCacheRef
929 %************************************************************************
931 Dealing with annotations
933 %************************************************************************
936 -- | Get all annotations of a given type. This happens lazily, that is
937 -- no deserialization will take place until the [a] is actually demanded and
938 -- the [a] can also be empty (the UniqFM is not filtered).
940 -- This should be done once at the start of a Core-to-Core pass that uses
943 -- See Note [Annotations]
944 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
945 getAnnotations deserialize guts = do
947 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
948 return (deserializeAnns deserialize ann_env)
950 -- | Get at most one annotation of a given type per Unique.
951 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
952 getFirstAnnotations deserialize guts
953 = liftM (mapUFM head . filterUFM (not . null))
954 $ getAnnotations deserialize guts
960 A Core-to-Core pass that wants to make use of annotations calls
961 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
962 annotations of a specific type. This produces all annotations from interface
963 files read so far. However, annotations from interface files read during the
964 pass will not be visible until getAnnotations is called again. This is similar
965 to how rules work and probably isn't too bad.
967 The current implementation could be optimised a bit: when looking up
968 annotations for a thing from the HomePackageTable, we could search directly in
969 the module where the thing is defined rather than building one UniqFM which
970 contains all annotations we know of. This would work because annotations can
971 only be given to things defined in the same module. However, since we would
972 only want to deserialise every annotation once, we would have to build a cache
973 for every module in the HTP. In the end, it's probably not worth it as long as
974 we aren't using annotations heavily.
976 %************************************************************************
980 %************************************************************************
984 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
986 dflags <- getDynFlags
987 liftIO $ how dflags doc
989 -- | Output a String message to the screen
990 putMsgS :: String -> CoreM ()
991 putMsgS = putMsg . text
993 -- | Output a message to the screen
994 putMsg :: SDoc -> CoreM ()
995 putMsg = msg Err.putMsg
997 -- | Output a string error to the screen
998 errorMsgS :: String -> CoreM ()
999 errorMsgS = errorMsg . text
1001 -- | Output an error to the screen
1002 errorMsg :: SDoc -> CoreM ()
1003 errorMsg = msg Err.errorMsg
1005 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1006 fatalErrorMsgS :: String -> CoreM ()
1007 fatalErrorMsgS = fatalErrorMsg . text
1009 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1010 fatalErrorMsg :: SDoc -> CoreM ()
1011 fatalErrorMsg = msg Err.fatalErrorMsg
1013 -- | Output a string debugging message at verbosity level of @-v@ or higher
1014 debugTraceMsgS :: String -> CoreM ()
1015 debugTraceMsgS = debugTraceMsg . text
1017 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1018 debugTraceMsg :: SDoc -> CoreM ()
1019 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1021 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1022 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1023 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1028 initTcForLookup :: HscEnv -> TcM a -> IO a
1029 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1034 %************************************************************************
1038 %************************************************************************
1041 instance MonadThings CoreM where
1042 lookupThing name = do
1043 hsc_env <- getHscEnv
1044 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1047 %************************************************************************
1049 Template Haskell interoperability
1051 %************************************************************************
1055 -- | Attempt to convert a Template Haskell name to one that GHC can
1056 -- understand. Original TH names such as those you get when you use
1057 -- the @'foo@ syntax will be translated to their equivalent GHC name
1058 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1059 -- to names in the module being compiled, if possible. Exact TH names
1060 -- will be bound to the name they represent, exactly.
1061 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1062 thNameToGhcName th_name = do
1063 hsc_env <- getHscEnv
1064 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)