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, simplCountN,
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 )
84 import Data.List ( intersperse )
88 import qualified Data.Map as Map
92 import Prelude hiding ( read )
95 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
96 import qualified Language.Haskell.TH as TH
100 %************************************************************************
104 %************************************************************************
106 These functions are not CoreM monad stuff, but they probably ought to
107 be, and it makes a conveneint place. place for them. They print out
108 stuff before and after core passes, and do Core Lint when necessary.
111 showPass :: DynFlags -> CoreToDo -> IO ()
112 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
114 endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
115 endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
117 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
118 endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
119 endIteration dflags pass n
120 = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
121 (Just Opt_D_dump_simpl_iterations)
123 dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
124 dumpIfSet dump_me pass extra_info doc
125 = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
127 dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
128 -> [CoreBind] -> [CoreRule] -> IO ()
129 -- The "show_all" parameter says to print dump if -dverbose-core2core is on
130 dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
131 = do { -- Report result size if required
132 -- This has the side effect of forcing the intermediate to be evaluated
133 ; Err.debugTraceMsg dflags 2 $
134 (text " Result size =" <+> int (coreBindsSize binds))
136 -- Report verbosely, if required
137 ; let pass_name = showSDoc (ppr pass <+> extra_info)
138 dump_doc = pprCoreBindings binds
139 $$ ppUnless (null rules) pp_rules
141 ; case mb_dump_flag of
143 Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
145 dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core]
146 | otherwise = [dump_flag]
149 ; when (dopt Opt_DoCoreLinting dflags) $
150 do { let (warns, errs) = lintCoreBindings binds
151 ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
152 ; displayLintResults dflags pass warns errs binds } }
154 pp_rules = vcat [ blankLine
155 , ptext (sLit "------ Local rules for imported ids --------")
158 displayLintResults :: DynFlags -> CoreToDo
159 -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
161 displayLintResults dflags pass warns errs binds
162 | not (isEmptyBag errs)
163 = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
164 , ptext (sLit "*** Offending Program ***")
165 , pprCoreBindings binds
166 , ptext (sLit "*** End of Offense ***") ])
167 ; Err.ghcExit dflags 1 }
169 | not (isEmptyBag warns)
170 , not (case pass of { CoreDesugar -> True; _ -> False })
171 -- Suppress warnings after desugaring pass because some
172 -- are legitimate. Notably, the desugarer generates instance
173 -- methods with INLINE pragmas that form a mutually recursive
174 -- group. Only afer a round of simplification are they unravelled.
175 , not opt_NoDebugOutput
176 , showLintWarnings pass
177 = printDump (banner "warnings" $$ Err.pprMessageBag warns)
179 | otherwise = return ()
181 banner string = ptext (sLit "*** Core Lint") <+> text string
182 <+> ptext (sLit ": in result of") <+> ppr pass
183 <+> ptext (sLit "***")
185 showLintWarnings :: CoreToDo -> Bool
186 -- Disable Lint warnings on the first simplifier pass, because
187 -- there may be some INLINE knots still tied, which is tiresomely noisy
188 showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
189 showLintWarnings _ = True
193 %************************************************************************
195 The CoreToDo type and related types
196 Abstraction of core-to-core passes to run.
198 %************************************************************************
201 data CoreToDo -- These are diff core-to-core passes,
202 -- which may be invoked in any order,
203 -- as many times as you like.
205 = CoreDoSimplify -- The core-to-core simplifier.
207 Int -- Max iterations
208 [SimplifierSwitch] -- Each run of the simplifier can take a different
209 -- set of simplifier-specific flags.
211 | CoreDoFloatOutwards FloatOutSwitches
216 | CoreDoWorkerWrapper
221 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
222 -- matching this string
223 | CoreDoVectorisation PackageId
224 | CoreDoNothing -- Useful when building up
225 | CoreDoPasses [CoreToDo] -- lists of these things
227 | CoreDesugar -- Not strictly a core-to-core pass, but produces
228 -- Core output, and hence useful to pass to endPass
233 coreDumpFlag :: CoreToDo -> Maybe DynFlag
234 coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
235 coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
236 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
237 coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
238 coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
239 coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
240 coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
241 coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
242 coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
243 coreDumpFlag CoreCSE = Just Opt_D_dump_cse
244 coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
245 coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
246 coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
247 coreDumpFlag CorePrep = Just Opt_D_dump_prep
249 coreDumpFlag CoreDoPrintCore = Nothing
250 coreDumpFlag (CoreDoRuleCheck {}) = Nothing
251 coreDumpFlag CoreDoNothing = Nothing
252 coreDumpFlag CoreDoGlomBinds = Nothing
253 coreDumpFlag (CoreDoPasses {}) = Nothing
255 instance Outputable CoreToDo where
256 ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
258 <+> ptext (sLit "max-iterations=") <> int n
259 ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
260 ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
261 ppr CoreLiberateCase = ptext (sLit "Liberate case")
262 ppr CoreDoStaticArgs = ptext (sLit "Static argument")
263 ppr CoreDoStrictness = ptext (sLit "Demand analysis")
264 ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
265 ppr CoreDoSpecialising = ptext (sLit "Specialise")
266 ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
267 ppr CoreCSE = ptext (sLit "Common sub-expression")
268 ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
269 ppr CoreDesugar = ptext (sLit "Desugar")
270 ppr CoreTidy = ptext (sLit "Tidy Core")
271 ppr CorePrep = ptext (sLit "CorePrep")
272 ppr CoreDoPrintCore = ptext (sLit "Print core")
273 ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
274 ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
275 ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
276 ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
280 data SimplifierMode -- See comments in SimplMonad
282 { sm_rules :: Bool -- Whether RULES are enabled
283 , sm_inline :: Bool } -- Whether inlining is enabled
286 { sm_num :: Int -- Phase number; counts downward so 0 is last phase
287 , sm_names :: [String] } -- Name(s) of the phase
289 instance Outputable SimplifierMode where
290 ppr (SimplPhase { sm_num = n, sm_names = ss })
291 = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
292 ppr (SimplGently { sm_rules = r, sm_inline = i })
293 = ptext (sLit "gentle") <>
294 brackets (pp_flag r (sLit "rules") <> comma <>
295 pp_flag i (sLit "inline"))
297 pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
299 data SimplifierSwitch
305 data FloatOutSwitches = FloatOutSwitches {
306 floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
307 floatOutConstants :: Bool -- ^ True <=> float constants to top level,
308 -- even if they do not escape a lambda
310 instance Outputable FloatOutSwitches where
311 ppr = pprFloatOutSwitches
313 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
314 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
315 <+> pp_not (floatOutConstants sw) <+> text "constants"
318 pp_not False = text "not"
320 -- | Switches that specify the minimum amount of floating out
321 -- gentleFloatOutSwitches :: FloatOutSwitches
322 -- gentleFloatOutSwitches = FloatOutSwitches False False
324 -- | Switches that do not specify floating out of lambdas, just of constants
325 constantsOnlyFloatOutSwitches :: FloatOutSwitches
326 constantsOnlyFloatOutSwitches = FloatOutSwitches False True
330 %************************************************************************
332 Generating the main optimisation pipeline
334 %************************************************************************
337 getCoreToDo :: DynFlags -> [CoreToDo]
341 opt_level = optLevel dflags
342 phases = simplPhases dflags
343 max_iter = maxSimplIterations dflags
344 strictness = dopt Opt_Strictness dflags
345 full_laziness = dopt Opt_FullLaziness dflags
346 do_specialise = dopt Opt_Specialise dflags
347 do_float_in = dopt Opt_FloatIn dflags
348 cse = dopt Opt_CSE dflags
349 spec_constr = dopt Opt_SpecConstr dflags
350 liberate_case = dopt Opt_LiberateCase dflags
351 rule_check = ruleCheck dflags
352 static_args = dopt Opt_StaticArgumentTransformation dflags
354 maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
356 maybe_strictness_before phase
357 = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
359 simpl_phase phase names iter
361 [ maybe_strictness_before phase
362 , CoreDoSimplify (SimplPhase phase names)
364 , maybe_rule_check phase
368 = runWhen (dopt Opt_Vectorise dflags)
369 $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
372 -- By default, we have 2 phases before phase 0.
374 -- Want to run with inline phase 2 after the specialiser to give
375 -- maximum chance for fusion to work before we inline build/augment
376 -- in phase 1. This made a difference in 'ansi' where an
377 -- overloaded function wasn't inlined till too late.
379 -- Need phase 1 so that build/augment get
380 -- inlined. I found that spectral/hartel/genfft lost some useful
381 -- strictness in the function sumcode' if augment is not inlined
382 -- before strictness analysis runs
383 simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
384 | phase <- [phases, phases-1 .. 1] ]
387 -- initial simplify: mk specialiser happy: minimum effort please
388 simpl_gently = CoreDoSimplify
389 (SimplGently { sm_rules = True, sm_inline = False })
390 -- See Note [Gentle mode] and
391 -- Note [RULEs enabled in SimplGently] in SimplUtils
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 = VerySimplCount !Int -- Used when don't want detailed stats
552 ticks :: !Int, -- Total ticks
553 details :: !TickCounts, -- How many of each type
556 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
558 log2 :: [Tick] -- Last opt_HistorySize events before that
559 -- Having log1, log2 lets us accumulate the
560 -- recent history reasonably efficiently
563 type TickCounts = Map Tick Int
565 simplCountN :: SimplCount -> Int
566 simplCountN (VerySimplCount n) = n
567 simplCountN (SimplCount { ticks = n }) = n
569 zeroSimplCount dflags
570 -- This is where we decide whether to do
571 -- the VerySimpl version or the full-stats version
572 | dopt Opt_D_dump_simpl_stats dflags
573 = SimplCount {ticks = 0, details = Map.empty,
574 n_log = 0, log1 = [], log2 = []}
578 isZeroSimplCount (VerySimplCount n) = n==0
579 isZeroSimplCount (SimplCount { ticks = n }) = n==0
581 doFreeSimplTick tick sc@SimplCount { details = dts }
582 = sc { details = dts `addTick` tick }
583 doFreeSimplTick _ sc = sc
585 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
586 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
587 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
589 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
591 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
594 -- Don't use Map.unionWith because that's lazy, and we want to
595 -- be pretty strict here!
596 addTick :: TickCounts -> Tick -> TickCounts
597 addTick fm tick = case Map.lookup tick fm of
598 Nothing -> Map.insert tick 1 fm
599 Just n -> n1 `seq` Map.insert tick n1 fm
604 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
605 sc2@(SimplCount { ticks = tks2, details = dts2 })
606 = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
608 -- A hackish way of getting recent log info
609 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
610 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
613 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
614 plusSimplCount _ _ = panic "plusSimplCount"
615 -- We use one or the other consistently
617 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
618 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
619 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
621 pprTickCounts (Map.toList dts),
622 if verboseSimplStats then
624 ptext (sLit "Log (most recent first)"),
625 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
629 pprTickCounts :: [(Tick,Int)] -> SDoc
630 pprTickCounts [] = empty
631 pprTickCounts ((tick1,n1):ticks)
632 = vcat [int tot_n <+> text (tickString tick1),
633 pprTCDetails real_these,
637 tick1_tag = tickToTag tick1
638 (these, others) = span same_tick ticks
639 real_these = (tick1,n1):these
640 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
641 tot_n = sum [n | (_,n) <- real_these]
643 pprTCDetails :: [(Tick, Int)] -> SDoc
645 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
651 = PreInlineUnconditionally Id
652 | PostInlineUnconditionally Id
655 | RuleFired FastString -- Rule name
658 | EtaExpansion Id -- LHS binder
659 | EtaReduction Id -- Binder on outer lambda
660 | BetaReduction Id -- Lambda binder
663 | CaseOfCase Id -- Bndr on *inner* case
664 | KnownBranch Id -- Case binder
665 | CaseMerge Id -- Binder on outer case
666 | AltMerge Id -- Case binder
667 | CaseElim Id -- Case binder
668 | CaseIdentity Id -- Case binder
669 | FillInCaseDefault Id -- Case binder
672 | SimplifierDone -- Ticked at each iteration of the simplifier
674 instance Outputable Tick where
675 ppr tick = text (tickString tick) <+> pprTickCts tick
677 instance Eq Tick where
678 a == b = case a `cmpTick` b of
682 instance Ord Tick where
685 tickToTag :: Tick -> Int
686 tickToTag (PreInlineUnconditionally _) = 0
687 tickToTag (PostInlineUnconditionally _) = 1
688 tickToTag (UnfoldingDone _) = 2
689 tickToTag (RuleFired _) = 3
690 tickToTag LetFloatFromLet = 4
691 tickToTag (EtaExpansion _) = 5
692 tickToTag (EtaReduction _) = 6
693 tickToTag (BetaReduction _) = 7
694 tickToTag (CaseOfCase _) = 8
695 tickToTag (KnownBranch _) = 9
696 tickToTag (CaseMerge _) = 10
697 tickToTag (CaseElim _) = 11
698 tickToTag (CaseIdentity _) = 12
699 tickToTag (FillInCaseDefault _) = 13
700 tickToTag BottomFound = 14
701 tickToTag SimplifierDone = 16
702 tickToTag (AltMerge _) = 17
704 tickString :: Tick -> String
705 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
706 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
707 tickString (UnfoldingDone _) = "UnfoldingDone"
708 tickString (RuleFired _) = "RuleFired"
709 tickString LetFloatFromLet = "LetFloatFromLet"
710 tickString (EtaExpansion _) = "EtaExpansion"
711 tickString (EtaReduction _) = "EtaReduction"
712 tickString (BetaReduction _) = "BetaReduction"
713 tickString (CaseOfCase _) = "CaseOfCase"
714 tickString (KnownBranch _) = "KnownBranch"
715 tickString (CaseMerge _) = "CaseMerge"
716 tickString (AltMerge _) = "AltMerge"
717 tickString (CaseElim _) = "CaseElim"
718 tickString (CaseIdentity _) = "CaseIdentity"
719 tickString (FillInCaseDefault _) = "FillInCaseDefault"
720 tickString BottomFound = "BottomFound"
721 tickString SimplifierDone = "SimplifierDone"
723 pprTickCts :: Tick -> SDoc
724 pprTickCts (PreInlineUnconditionally v) = ppr v
725 pprTickCts (PostInlineUnconditionally v)= ppr v
726 pprTickCts (UnfoldingDone v) = ppr v
727 pprTickCts (RuleFired v) = ppr v
728 pprTickCts LetFloatFromLet = empty
729 pprTickCts (EtaExpansion v) = ppr v
730 pprTickCts (EtaReduction v) = ppr v
731 pprTickCts (BetaReduction v) = ppr v
732 pprTickCts (CaseOfCase v) = ppr v
733 pprTickCts (KnownBranch v) = ppr v
734 pprTickCts (CaseMerge v) = ppr v
735 pprTickCts (AltMerge v) = ppr v
736 pprTickCts (CaseElim v) = ppr v
737 pprTickCts (CaseIdentity v) = ppr v
738 pprTickCts (FillInCaseDefault v) = ppr v
741 cmpTick :: Tick -> Tick -> Ordering
742 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
747 cmpEqTick :: Tick -> Tick -> Ordering
748 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
749 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
750 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
751 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
752 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
753 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
754 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
755 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
756 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
757 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
758 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
759 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
760 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
761 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
766 %************************************************************************
768 Monad and carried data structure definitions
770 %************************************************************************
773 newtype CoreState = CoreState {
774 cs_uniq_supply :: UniqSupply
777 data CoreReader = CoreReader {
778 cr_hsc_env :: HscEnv,
779 cr_rule_base :: RuleBase,
783 data CoreWriter = CoreWriter {
784 cw_simpl_count :: SimplCount
787 emptyWriter :: DynFlags -> CoreWriter
788 emptyWriter dflags = CoreWriter {
789 cw_simpl_count = zeroSimplCount dflags
792 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
793 plusWriter w1 w2 = CoreWriter {
794 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
797 type CoreIOEnv = IOEnv CoreReader
799 -- | The monad used by Core-to-Core passes to access common state, register simplification
800 -- statistics and so on
801 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
803 instance Functor CoreM where
808 instance Monad CoreM where
809 return x = CoreM (\s -> nop s x)
810 mx >>= f = CoreM $ \s -> do
811 (x, s', w1) <- unCoreM mx s
812 (y, s'', w2) <- unCoreM (f x) s'
813 return (y, s'', w1 `plusWriter` w2)
815 instance Applicative CoreM where
819 -- For use if the user has imported Control.Monad.Error from MTL
820 -- Requires UndecidableInstances
821 instance MonadPlus IO => MonadPlus CoreM where
822 mzero = CoreM (const mzero)
823 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
825 instance MonadUnique CoreM where
826 getUniqueSupplyM = do
827 us <- getS cs_uniq_supply
828 let (us1, us2) = splitUniqSupply us
829 modifyS (\s -> s { cs_uniq_supply = us2 })
837 -> IO (a, SimplCount)
838 runCoreM hsc_env rule_base us mod m =
839 liftM extract $ runIOEnv reader $ unCoreM m state
841 reader = CoreReader {
842 cr_hsc_env = hsc_env,
843 cr_rule_base = rule_base,
850 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
851 extract (value, _, writer) = (value, cw_simpl_count writer)
856 %************************************************************************
858 Core combinators, not exported
860 %************************************************************************
864 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
867 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
869 read :: (CoreReader -> a) -> CoreM a
870 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
872 getS :: (CoreState -> a) -> CoreM a
873 getS f = CoreM (\s -> nop s (f s))
875 modifyS :: (CoreState -> CoreState) -> CoreM ()
876 modifyS f = CoreM (\s -> nop (f s) ())
878 write :: CoreWriter -> CoreM ()
879 write w = CoreM (\s -> return ((), s, w))
883 \subsection{Lifting IO into the monad}
887 -- | Lift an 'IOEnv' operation into 'CoreM'
888 liftIOEnv :: CoreIOEnv a -> CoreM a
889 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
891 instance MonadIO CoreM where
892 liftIO = liftIOEnv . IOEnv.liftIO
894 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
895 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
896 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
901 %************************************************************************
903 Reader, writer and state accessors
905 %************************************************************************
909 getHscEnv :: CoreM HscEnv
910 getHscEnv = read cr_hsc_env
912 getRuleBase :: CoreM RuleBase
913 getRuleBase = read cr_rule_base
915 getModule :: CoreM Module
916 getModule = read cr_module
918 addSimplCount :: SimplCount -> CoreM ()
919 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
921 -- Convenience accessors for useful fields of HscEnv
923 getDynFlags :: CoreM DynFlags
924 getDynFlags = fmap hsc_dflags getHscEnv
926 -- | The original name cache is the current mapping from 'Module' and
927 -- 'OccName' to a compiler-wide unique 'Name'
928 getOrigNameCache :: CoreM OrigNameCache
929 getOrigNameCache = do
930 nameCacheRef <- fmap hsc_NC getHscEnv
931 liftIO $ fmap nsNames $ readIORef nameCacheRef
936 %************************************************************************
938 Dealing with annotations
940 %************************************************************************
943 -- | Get all annotations of a given type. This happens lazily, that is
944 -- no deserialization will take place until the [a] is actually demanded and
945 -- the [a] can also be empty (the UniqFM is not filtered).
947 -- This should be done once at the start of a Core-to-Core pass that uses
950 -- See Note [Annotations]
951 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
952 getAnnotations deserialize guts = do
954 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
955 return (deserializeAnns deserialize ann_env)
957 -- | Get at most one annotation of a given type per Unique.
958 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
959 getFirstAnnotations deserialize guts
960 = liftM (mapUFM head . filterUFM (not . null))
961 $ getAnnotations deserialize guts
967 A Core-to-Core pass that wants to make use of annotations calls
968 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
969 annotations of a specific type. This produces all annotations from interface
970 files read so far. However, annotations from interface files read during the
971 pass will not be visible until getAnnotations is called again. This is similar
972 to how rules work and probably isn't too bad.
974 The current implementation could be optimised a bit: when looking up
975 annotations for a thing from the HomePackageTable, we could search directly in
976 the module where the thing is defined rather than building one UniqFM which
977 contains all annotations we know of. This would work because annotations can
978 only be given to things defined in the same module. However, since we would
979 only want to deserialise every annotation once, we would have to build a cache
980 for every module in the HTP. In the end, it's probably not worth it as long as
981 we aren't using annotations heavily.
983 %************************************************************************
987 %************************************************************************
991 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
993 dflags <- getDynFlags
994 liftIO $ how dflags doc
996 -- | Output a String message to the screen
997 putMsgS :: String -> CoreM ()
998 putMsgS = putMsg . text
1000 -- | Output a message to the screen
1001 putMsg :: SDoc -> CoreM ()
1002 putMsg = msg Err.putMsg
1004 -- | Output a string error to the screen
1005 errorMsgS :: String -> CoreM ()
1006 errorMsgS = errorMsg . text
1008 -- | Output an error to the screen
1009 errorMsg :: SDoc -> CoreM ()
1010 errorMsg = msg Err.errorMsg
1012 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1013 fatalErrorMsgS :: String -> CoreM ()
1014 fatalErrorMsgS = fatalErrorMsg . text
1016 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1017 fatalErrorMsg :: SDoc -> CoreM ()
1018 fatalErrorMsg = msg Err.fatalErrorMsg
1020 -- | Output a string debugging message at verbosity level of @-v@ or higher
1021 debugTraceMsgS :: String -> CoreM ()
1022 debugTraceMsgS = debugTraceMsg . text
1024 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1025 debugTraceMsg :: SDoc -> CoreM ()
1026 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1028 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1029 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1030 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1035 initTcForLookup :: HscEnv -> TcM a -> IO a
1036 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1041 %************************************************************************
1045 %************************************************************************
1048 instance MonadThings CoreM where
1049 lookupThing name = do
1050 hsc_env <- getHscEnv
1051 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1054 %************************************************************************
1056 Template Haskell interoperability
1058 %************************************************************************
1062 -- | Attempt to convert a Template Haskell name to one that GHC can
1063 -- understand. Original TH names such as those you get when you use
1064 -- the @'foo@ syntax will be translated to their equivalent GHC name
1065 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1066 -- to names in the module being compiled, if possible. Exact TH names
1067 -- will be bound to the name they represent, exactly.
1068 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1069 thNameToGhcName th_name = do
1070 hsc_env <- getHscEnv
1071 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)