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 )
85 import Data.List ( intersperse )
89 import qualified Data.Map as Map
93 import Prelude hiding ( read )
96 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
97 import qualified Language.Haskell.TH as TH
101 %************************************************************************
105 %************************************************************************
107 These functions are not CoreM monad stuff, but they probably ought to
108 be, and it makes a conveneint place. place for them. They print out
109 stuff before and after core passes, and do Core Lint when necessary.
112 showPass :: DynFlags -> CoreToDo -> IO ()
113 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
115 endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
116 endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
118 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
119 endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
120 endIteration dflags pass n
121 = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
122 (Just Opt_D_dump_simpl_iterations)
124 dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
125 dumpIfSet dump_me pass extra_info doc
126 = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
128 dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
129 -> [CoreBind] -> [CoreRule] -> IO ()
130 -- The "show_all" parameter says to print dump if -dverbose-core2core is on
131 dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
132 = do { -- Report result size if required
133 -- This has the side effect of forcing the intermediate to be evaluated
134 ; Err.debugTraceMsg dflags 2 $
135 (text " Result size =" <+> int (coreBindsSize binds))
137 -- Report verbosely, if required
138 ; let pass_name = showSDoc (ppr pass <+> extra_info)
139 dump_doc = pprCoreBindings binds
140 $$ ppUnless (null rules) pp_rules
142 ; case mb_dump_flag of
144 Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
146 dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core]
147 | otherwise = [dump_flag]
150 ; when (dopt Opt_DoCoreLinting dflags) $
151 do { let (warns, errs) = lintCoreBindings binds
152 ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
153 ; displayLintResults dflags pass warns errs binds } }
155 pp_rules = vcat [ blankLine
156 , ptext (sLit "------ Local rules for imported ids --------")
159 displayLintResults :: DynFlags -> CoreToDo
160 -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
162 displayLintResults dflags pass warns errs binds
163 | not (isEmptyBag errs)
164 = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
165 , ptext (sLit "*** Offending Program ***")
166 , pprCoreBindings binds
167 , ptext (sLit "*** End of Offense ***") ])
168 ; Err.ghcExit dflags 1 }
170 | not (isEmptyBag warns)
171 , not (case pass of { CoreDesugar -> True; _ -> False })
172 -- Suppress warnings after desugaring pass because some
173 -- are legitimate. Notably, the desugarer generates instance
174 -- methods with INLINE pragmas that form a mutually recursive
175 -- group. Only afer a round of simplification are they unravelled.
176 , not opt_NoDebugOutput
177 , showLintWarnings pass
178 = printDump (banner "warnings" $$ Err.pprMessageBag warns)
180 | otherwise = return ()
182 banner string = ptext (sLit "*** Core Lint") <+> text string
183 <+> ptext (sLit ": in result of") <+> ppr pass
184 <+> ptext (sLit "***")
186 showLintWarnings :: CoreToDo -> Bool
187 -- Disable Lint warnings on the first simplifier pass, because
188 -- there may be some INLINE knots still tied, which is tiresomely noisy
189 showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
190 showLintWarnings _ = True
194 %************************************************************************
196 The CoreToDo type and related types
197 Abstraction of core-to-core passes to run.
199 %************************************************************************
202 data CoreToDo -- These are diff core-to-core passes,
203 -- which may be invoked in any order,
204 -- as many times as you like.
206 = CoreDoSimplify -- The core-to-core simplifier.
208 Int -- Max iterations
209 [SimplifierSwitch] -- Each run of the simplifier can take a different
210 -- set of simplifier-specific flags.
212 | CoreDoFloatOutwards FloatOutSwitches
217 | CoreDoWorkerWrapper
222 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
223 -- matching this string
224 | CoreDoVectorisation PackageId
225 | CoreDoNothing -- Useful when building up
226 | CoreDoPasses [CoreToDo] -- lists of these things
228 | CoreDesugar -- Not strictly a core-to-core pass, but produces
229 -- Core output, and hence useful to pass to endPass
234 coreDumpFlag :: CoreToDo -> Maybe DynFlag
235 coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
236 coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
237 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
238 coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
239 coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
240 coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
241 coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
242 coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
243 coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
244 coreDumpFlag CoreCSE = Just Opt_D_dump_cse
245 coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
246 coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
247 coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
248 coreDumpFlag CorePrep = Just Opt_D_dump_prep
250 coreDumpFlag CoreDoPrintCore = Nothing
251 coreDumpFlag (CoreDoRuleCheck {}) = Nothing
252 coreDumpFlag CoreDoNothing = Nothing
253 coreDumpFlag CoreDoGlomBinds = Nothing
254 coreDumpFlag (CoreDoPasses {}) = Nothing
256 instance Outputable CoreToDo where
257 ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
259 <+> ptext (sLit "max-iterations=") <> int n
260 ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
261 ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
262 ppr CoreLiberateCase = ptext (sLit "Liberate case")
263 ppr CoreDoStaticArgs = ptext (sLit "Static argument")
264 ppr CoreDoStrictness = ptext (sLit "Demand analysis")
265 ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
266 ppr CoreDoSpecialising = ptext (sLit "Specialise")
267 ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
268 ppr CoreCSE = ptext (sLit "Common sub-expression")
269 ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
270 ppr CoreDesugar = ptext (sLit "Desugar")
271 ppr CoreTidy = ptext (sLit "Tidy Core")
272 ppr CorePrep = ptext (sLit "CorePrep")
273 ppr CoreDoPrintCore = ptext (sLit "Print core")
274 ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
275 ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
276 ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
277 ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
281 data SimplifierMode -- See comments in SimplMonad
283 { sm_rules :: Bool -- Whether RULES are enabled
284 , sm_inline :: Bool } -- Whether inlining is enabled
287 { sm_num :: Int -- Phase number; counts downward so 0 is last phase
288 , sm_names :: [String] } -- Name(s) of the phase
290 instance Outputable SimplifierMode where
291 ppr (SimplPhase { sm_num = n, sm_names = ss })
292 = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
293 ppr (SimplGently { sm_rules = r, sm_inline = i })
294 = ptext (sLit "gentle") <>
295 brackets (pp_flag r (sLit "rules") <> comma <>
296 pp_flag i (sLit "inline"))
298 pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
300 data SimplifierSwitch
306 data FloatOutSwitches = FloatOutSwitches {
307 floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
308 floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
309 -- even if they do not escape a lambda
310 floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
311 -- based on arity information.
313 instance Outputable FloatOutSwitches where
314 ppr = pprFloatOutSwitches
316 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
317 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
318 <+> pp_not (floatOutConstants sw) <+> text "constants"
321 pp_not False = text "not"
323 -- | Switches that specify the minimum amount of floating out
324 -- gentleFloatOutSwitches :: FloatOutSwitches
325 -- gentleFloatOutSwitches = FloatOutSwitches False False
329 %************************************************************************
331 Generating the main optimisation pipeline
333 %************************************************************************
336 getCoreToDo :: DynFlags -> [CoreToDo]
340 opt_level = optLevel dflags
341 phases = simplPhases dflags
342 max_iter = maxSimplIterations dflags
343 strictness = dopt Opt_Strictness dflags
344 full_laziness = dopt Opt_FullLaziness dflags
345 do_specialise = dopt Opt_Specialise dflags
346 do_float_in = dopt Opt_FloatIn dflags
347 cse = dopt Opt_CSE dflags
348 spec_constr = dopt Opt_SpecConstr dflags
349 liberate_case = dopt Opt_LiberateCase dflags
350 rule_check = ruleCheck dflags
351 static_args = dopt Opt_StaticArgumentTransformation dflags
353 maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
355 maybe_strictness_before phase
356 = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
358 simpl_phase phase names iter
360 [ maybe_strictness_before phase
361 , CoreDoSimplify (SimplPhase phase names)
363 , maybe_rule_check phase
367 = runWhen (dopt Opt_Vectorise dflags)
368 $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
371 -- By default, we have 2 phases before phase 0.
373 -- Want to run with inline phase 2 after the specialiser to give
374 -- maximum chance for fusion to work before we inline build/augment
375 -- in phase 1. This made a difference in 'ansi' where an
376 -- overloaded function wasn't inlined till too late.
378 -- Need phase 1 so that build/augment get
379 -- inlined. I found that spectral/hartel/genfft lost some useful
380 -- strictness in the function sumcode' if augment is not inlined
381 -- before strictness analysis runs
382 simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
383 | phase <- [phases, phases-1 .. 1] ]
386 -- initial simplify: mk specialiser happy: minimum effort please
387 simpl_gently = CoreDoSimplify
388 (SimplGently { sm_rules = True, sm_inline = False })
389 -- See Note [Gentle mode] and
390 -- Note [RULEs enabled in SimplGently] in SimplUtils
395 NoCaseOfCase -- Don't do case-of-case transformations.
396 -- This makes full laziness work better
400 if opt_level == 0 then
402 simpl_phase 0 ["final"] max_iter]
403 else {- opt_level >= 1 -} [
405 -- We want to do the static argument transform before full laziness as it
406 -- may expose extra opportunities to float things outwards. However, to fix
407 -- up the output of the transformation we need at do at least one simplify
408 -- after this before anything else
409 runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
411 -- We run vectorisation here for now, but we might also try to run
415 -- initial simplify: mk specialiser happy: minimum effort please
418 -- Specialisation is best done before full laziness
419 -- so that overloaded functions have all their dictionary lambdas manifest
420 runWhen do_specialise CoreDoSpecialising,
422 runWhen full_laziness $
423 CoreDoFloatOutwards FloatOutSwitches {
424 floatOutLambdas = False,
425 floatOutConstants = True,
426 floatOutPartialApplications = False },
427 -- Was: gentleFloatOutSwitches
429 -- I have no idea why, but not floating constants to
430 -- top level is very bad in some cases.
432 -- Notably: p_ident in spectral/rewrite
433 -- Changing from "gentle" to "constantsOnly"
434 -- improved rewrite's allocation by 19%, and
435 -- made 0.0% difference to any other nofib
438 -- Not doing floatOutPartialApplications yet, we'll do
439 -- that later on when we've had a chance to get more
440 -- accurate arity information. In fact it makes no
441 -- difference at all to performance if we do it here,
442 -- but maybe we save some unnecessary to-and-fro in
445 runWhen do_float_in CoreDoFloatInwards,
449 -- Phase 0: allow all Ids to be inlined now
450 -- This gets foldr inlined before strictness analysis
452 -- At least 3 iterations because otherwise we land up with
453 -- huge dead expressions because of an infelicity in the
455 -- let k = BIG in foldr k z xs
456 -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
457 -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
459 simpl_phase 0 ["main"] (max max_iter 3),
461 runWhen strictness (CoreDoPasses [
465 simpl_phase 0 ["post-worker-wrapper"] max_iter
468 runWhen full_laziness $
469 CoreDoFloatOutwards FloatOutSwitches {
470 floatOutLambdas = False,
471 floatOutConstants = True,
472 floatOutPartialApplications = True },
473 -- nofib/spectral/hartel/wang doubles in speed if you
474 -- do full laziness late in the day. It only happens
475 -- after fusion and other stuff, so the early pass doesn't
476 -- catch it. For the record, the redex is
477 -- f_el22 (f_el21 r_midblock)
481 -- We want CSE to follow the final full-laziness pass, because it may
482 -- succeed in commoning up things floated out by full laziness.
483 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
485 runWhen do_float_in CoreDoFloatInwards,
489 -- Case-liberation for -O2. This should be after
490 -- strictness analysis and the simplification which follows it.
491 runWhen liberate_case (CoreDoPasses [
493 simpl_phase 0 ["post-liberate-case"] max_iter
494 ]), -- Run the simplifier after LiberateCase to vastly
495 -- reduce the possiblility of shadowing
496 -- Reason: see Note [Shadowing] in SpecConstr.lhs
498 runWhen spec_constr CoreDoSpecConstr,
502 -- Final clean-up simplification:
503 simpl_phase 0 ["final"] max_iter
506 -- The core-to-core pass ordering is derived from the DynFlags:
507 runWhen :: Bool -> CoreToDo -> CoreToDo
508 runWhen True do_this = do_this
509 runWhen False _ = CoreDoNothing
511 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
512 runMaybe (Just x) f = f x
513 runMaybe Nothing _ = CoreDoNothing
515 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
516 dumpSimplPhase dflags mode
517 | Just spec_string <- shouldDumpSimplPhase dflags
518 = match_spec spec_string
520 = dopt Opt_D_verbose_core2core dflags
523 match_spec :: String -> Bool
524 match_spec spec_string
525 = or $ map (and . map match . split ':')
526 $ split ',' spec_string
528 match :: String -> Bool
530 match s = case reads s of
531 [(n,"")] -> phase_num n
534 phase_num :: Int -> Bool
535 phase_num n = case mode of
536 SimplPhase k _ -> n == k
539 phase_name :: String -> Bool
540 phase_name s = case mode of
541 SimplGently {} -> s == "gentle"
542 SimplPhase { sm_names = ss } -> s `elem` ss
546 %************************************************************************
550 %************************************************************************
553 verboseSimplStats :: Bool
554 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
556 zeroSimplCount :: DynFlags -> SimplCount
557 isZeroSimplCount :: SimplCount -> Bool
558 pprSimplCount :: SimplCount -> SDoc
559 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
560 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
565 = VerySimplCount !Int -- Used when don't want detailed stats
568 ticks :: !Int, -- Total ticks
569 details :: !TickCounts, -- How many of each type
572 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
574 log2 :: [Tick] -- Last opt_HistorySize events before that
575 -- Having log1, log2 lets us accumulate the
576 -- recent history reasonably efficiently
579 type TickCounts = Map Tick Int
581 simplCountN :: SimplCount -> Int
582 simplCountN (VerySimplCount n) = n
583 simplCountN (SimplCount { ticks = n }) = n
585 zeroSimplCount dflags
586 -- This is where we decide whether to do
587 -- the VerySimpl version or the full-stats version
588 | dopt Opt_D_dump_simpl_stats dflags
589 = SimplCount {ticks = 0, details = Map.empty,
590 n_log = 0, log1 = [], log2 = []}
594 isZeroSimplCount (VerySimplCount n) = n==0
595 isZeroSimplCount (SimplCount { ticks = n }) = n==0
597 doFreeSimplTick tick sc@SimplCount { details = dts }
598 = sc { details = dts `addTick` tick }
599 doFreeSimplTick _ sc = sc
601 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
602 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
603 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
605 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
607 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
610 -- Don't use Map.unionWith because that's lazy, and we want to
611 -- be pretty strict here!
612 addTick :: TickCounts -> Tick -> TickCounts
613 addTick fm tick = case Map.lookup tick fm of
614 Nothing -> Map.insert tick 1 fm
615 Just n -> n1 `seq` Map.insert tick n1 fm
620 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
621 sc2@(SimplCount { ticks = tks2, details = dts2 })
622 = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
624 -- A hackish way of getting recent log info
625 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
626 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
629 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
630 plusSimplCount _ _ = panic "plusSimplCount"
631 -- We use one or the other consistently
633 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
634 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
635 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
637 pprTickCounts (Map.toList dts),
638 if verboseSimplStats then
640 ptext (sLit "Log (most recent first)"),
641 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
645 pprTickCounts :: [(Tick,Int)] -> SDoc
646 pprTickCounts [] = empty
647 pprTickCounts ((tick1,n1):ticks)
648 = vcat [int tot_n <+> text (tickString tick1),
649 pprTCDetails real_these,
653 tick1_tag = tickToTag tick1
654 (these, others) = span same_tick ticks
655 real_these = (tick1,n1):these
656 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
657 tot_n = sum [n | (_,n) <- real_these]
659 pprTCDetails :: [(Tick, Int)] -> SDoc
661 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
667 = PreInlineUnconditionally Id
668 | PostInlineUnconditionally Id
671 | RuleFired FastString -- Rule name
674 | EtaExpansion Id -- LHS binder
675 | EtaReduction Id -- Binder on outer lambda
676 | BetaReduction Id -- Lambda binder
679 | CaseOfCase Id -- Bndr on *inner* case
680 | KnownBranch Id -- Case binder
681 | CaseMerge Id -- Binder on outer case
682 | AltMerge Id -- Case binder
683 | CaseElim Id -- Case binder
684 | CaseIdentity Id -- Case binder
685 | FillInCaseDefault Id -- Case binder
688 | SimplifierDone -- Ticked at each iteration of the simplifier
690 instance Outputable Tick where
691 ppr tick = text (tickString tick) <+> pprTickCts tick
693 instance Eq Tick where
694 a == b = case a `cmpTick` b of
698 instance Ord Tick where
701 tickToTag :: Tick -> Int
702 tickToTag (PreInlineUnconditionally _) = 0
703 tickToTag (PostInlineUnconditionally _) = 1
704 tickToTag (UnfoldingDone _) = 2
705 tickToTag (RuleFired _) = 3
706 tickToTag LetFloatFromLet = 4
707 tickToTag (EtaExpansion _) = 5
708 tickToTag (EtaReduction _) = 6
709 tickToTag (BetaReduction _) = 7
710 tickToTag (CaseOfCase _) = 8
711 tickToTag (KnownBranch _) = 9
712 tickToTag (CaseMerge _) = 10
713 tickToTag (CaseElim _) = 11
714 tickToTag (CaseIdentity _) = 12
715 tickToTag (FillInCaseDefault _) = 13
716 tickToTag BottomFound = 14
717 tickToTag SimplifierDone = 16
718 tickToTag (AltMerge _) = 17
720 tickString :: Tick -> String
721 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
722 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
723 tickString (UnfoldingDone _) = "UnfoldingDone"
724 tickString (RuleFired _) = "RuleFired"
725 tickString LetFloatFromLet = "LetFloatFromLet"
726 tickString (EtaExpansion _) = "EtaExpansion"
727 tickString (EtaReduction _) = "EtaReduction"
728 tickString (BetaReduction _) = "BetaReduction"
729 tickString (CaseOfCase _) = "CaseOfCase"
730 tickString (KnownBranch _) = "KnownBranch"
731 tickString (CaseMerge _) = "CaseMerge"
732 tickString (AltMerge _) = "AltMerge"
733 tickString (CaseElim _) = "CaseElim"
734 tickString (CaseIdentity _) = "CaseIdentity"
735 tickString (FillInCaseDefault _) = "FillInCaseDefault"
736 tickString BottomFound = "BottomFound"
737 tickString SimplifierDone = "SimplifierDone"
739 pprTickCts :: Tick -> SDoc
740 pprTickCts (PreInlineUnconditionally v) = ppr v
741 pprTickCts (PostInlineUnconditionally v)= ppr v
742 pprTickCts (UnfoldingDone v) = ppr v
743 pprTickCts (RuleFired v) = ppr v
744 pprTickCts LetFloatFromLet = empty
745 pprTickCts (EtaExpansion v) = ppr v
746 pprTickCts (EtaReduction v) = ppr v
747 pprTickCts (BetaReduction v) = ppr v
748 pprTickCts (CaseOfCase v) = ppr v
749 pprTickCts (KnownBranch v) = ppr v
750 pprTickCts (CaseMerge v) = ppr v
751 pprTickCts (AltMerge v) = ppr v
752 pprTickCts (CaseElim v) = ppr v
753 pprTickCts (CaseIdentity v) = ppr v
754 pprTickCts (FillInCaseDefault v) = ppr v
757 cmpTick :: Tick -> Tick -> Ordering
758 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
763 cmpEqTick :: Tick -> Tick -> Ordering
764 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
765 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
766 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
767 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
768 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
769 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
770 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
771 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
772 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
773 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
774 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
775 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
776 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
777 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
782 %************************************************************************
784 Monad and carried data structure definitions
786 %************************************************************************
789 newtype CoreState = CoreState {
790 cs_uniq_supply :: UniqSupply
793 data CoreReader = CoreReader {
794 cr_hsc_env :: HscEnv,
795 cr_rule_base :: RuleBase,
799 data CoreWriter = CoreWriter {
800 cw_simpl_count :: SimplCount
803 emptyWriter :: DynFlags -> CoreWriter
804 emptyWriter dflags = CoreWriter {
805 cw_simpl_count = zeroSimplCount dflags
808 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
809 plusWriter w1 w2 = CoreWriter {
810 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
813 type CoreIOEnv = IOEnv CoreReader
815 -- | The monad used by Core-to-Core passes to access common state, register simplification
816 -- statistics and so on
817 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
819 instance Functor CoreM where
824 instance Monad CoreM where
825 return x = CoreM (\s -> nop s x)
826 mx >>= f = CoreM $ \s -> do
827 (x, s', w1) <- unCoreM mx s
828 (y, s'', w2) <- unCoreM (f x) s'
829 return (y, s'', w1 `plusWriter` w2)
831 instance Applicative CoreM where
835 -- For use if the user has imported Control.Monad.Error from MTL
836 -- Requires UndecidableInstances
837 instance MonadPlus IO => MonadPlus CoreM where
838 mzero = CoreM (const mzero)
839 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
841 instance MonadUnique CoreM where
842 getUniqueSupplyM = do
843 us <- getS cs_uniq_supply
844 let (us1, us2) = splitUniqSupply us
845 modifyS (\s -> s { cs_uniq_supply = us2 })
853 -> IO (a, SimplCount)
854 runCoreM hsc_env rule_base us mod m =
855 liftM extract $ runIOEnv reader $ unCoreM m state
857 reader = CoreReader {
858 cr_hsc_env = hsc_env,
859 cr_rule_base = rule_base,
866 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
867 extract (value, _, writer) = (value, cw_simpl_count writer)
872 %************************************************************************
874 Core combinators, not exported
876 %************************************************************************
880 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
883 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
885 read :: (CoreReader -> a) -> CoreM a
886 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
888 getS :: (CoreState -> a) -> CoreM a
889 getS f = CoreM (\s -> nop s (f s))
891 modifyS :: (CoreState -> CoreState) -> CoreM ()
892 modifyS f = CoreM (\s -> nop (f s) ())
894 write :: CoreWriter -> CoreM ()
895 write w = CoreM (\s -> return ((), s, w))
899 \subsection{Lifting IO into the monad}
903 -- | Lift an 'IOEnv' operation into 'CoreM'
904 liftIOEnv :: CoreIOEnv a -> CoreM a
905 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
907 instance MonadIO CoreM where
908 liftIO = liftIOEnv . IOEnv.liftIO
910 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
911 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
912 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
917 %************************************************************************
919 Reader, writer and state accessors
921 %************************************************************************
925 getHscEnv :: CoreM HscEnv
926 getHscEnv = read cr_hsc_env
928 getRuleBase :: CoreM RuleBase
929 getRuleBase = read cr_rule_base
931 getModule :: CoreM Module
932 getModule = read cr_module
934 addSimplCount :: SimplCount -> CoreM ()
935 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
937 -- Convenience accessors for useful fields of HscEnv
939 getDynFlags :: CoreM DynFlags
940 getDynFlags = fmap hsc_dflags getHscEnv
942 -- | The original name cache is the current mapping from 'Module' and
943 -- 'OccName' to a compiler-wide unique 'Name'
944 getOrigNameCache :: CoreM OrigNameCache
945 getOrigNameCache = do
946 nameCacheRef <- fmap hsc_NC getHscEnv
947 liftIO $ fmap nsNames $ readIORef nameCacheRef
952 %************************************************************************
954 Dealing with annotations
956 %************************************************************************
959 -- | Get all annotations of a given type. This happens lazily, that is
960 -- no deserialization will take place until the [a] is actually demanded and
961 -- the [a] can also be empty (the UniqFM is not filtered).
963 -- This should be done once at the start of a Core-to-Core pass that uses
966 -- See Note [Annotations]
967 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
968 getAnnotations deserialize guts = do
970 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
971 return (deserializeAnns deserialize ann_env)
973 -- | Get at most one annotation of a given type per Unique.
974 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
975 getFirstAnnotations deserialize guts
976 = liftM (mapUFM head . filterUFM (not . null))
977 $ getAnnotations deserialize guts
983 A Core-to-Core pass that wants to make use of annotations calls
984 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
985 annotations of a specific type. This produces all annotations from interface
986 files read so far. However, annotations from interface files read during the
987 pass will not be visible until getAnnotations is called again. This is similar
988 to how rules work and probably isn't too bad.
990 The current implementation could be optimised a bit: when looking up
991 annotations for a thing from the HomePackageTable, we could search directly in
992 the module where the thing is defined rather than building one UniqFM which
993 contains all annotations we know of. This would work because annotations can
994 only be given to things defined in the same module. However, since we would
995 only want to deserialise every annotation once, we would have to build a cache
996 for every module in the HTP. In the end, it's probably not worth it as long as
997 we aren't using annotations heavily.
999 %************************************************************************
1001 Direct screen output
1003 %************************************************************************
1007 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
1009 dflags <- getDynFlags
1010 liftIO $ how dflags doc
1012 -- | Output a String message to the screen
1013 putMsgS :: String -> CoreM ()
1014 putMsgS = putMsg . text
1016 -- | Output a message to the screen
1017 putMsg :: SDoc -> CoreM ()
1018 putMsg = msg Err.putMsg
1020 -- | Output a string error to the screen
1021 errorMsgS :: String -> CoreM ()
1022 errorMsgS = errorMsg . text
1024 -- | Output an error to the screen
1025 errorMsg :: SDoc -> CoreM ()
1026 errorMsg = msg Err.errorMsg
1028 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1029 fatalErrorMsgS :: String -> CoreM ()
1030 fatalErrorMsgS = fatalErrorMsg . text
1032 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1033 fatalErrorMsg :: SDoc -> CoreM ()
1034 fatalErrorMsg = msg Err.fatalErrorMsg
1036 -- | Output a string debugging message at verbosity level of @-v@ or higher
1037 debugTraceMsgS :: String -> CoreM ()
1038 debugTraceMsgS = debugTraceMsg . text
1040 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1041 debugTraceMsg :: SDoc -> CoreM ()
1042 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1044 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1045 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1046 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1051 initTcForLookup :: HscEnv -> TcM a -> IO a
1052 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1057 %************************************************************************
1061 %************************************************************************
1064 instance MonadThings CoreM where
1065 lookupThing name = do
1066 hsc_env <- getHscEnv
1067 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1070 %************************************************************************
1072 Template Haskell interoperability
1074 %************************************************************************
1078 -- | Attempt to convert a Template Haskell name to one that GHC can
1079 -- understand. Original TH names such as those you get when you use
1080 -- the @'foo@ syntax will be translated to their equivalent GHC name
1081 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1082 -- to names in the module being compiled, if possible. Exact TH names
1083 -- will be bound to the name they represent, exactly.
1084 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1085 thNameToGhcName th_name = do
1086 hsc_env <- getHscEnv
1087 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)