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
14 getCoreToDo, dumpSimplPhase,
17 SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
18 pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
23 -- ** Reading from the monad
24 getHscEnv, getRuleBase, getModule,
25 getDynFlags, getOrigNameCache,
27 -- ** Writing to the monad
30 -- ** Lifting into the monad
31 liftIO, liftIOWithCount,
32 liftIO1, liftIO2, liftIO3, liftIO4,
34 -- ** Dealing with annotations
35 getAnnotations, getFirstAnnotations,
38 showPass, endPass, endIteration, dumpIfSet,
41 putMsg, putMsgS, errorMsg, errorMsgS,
42 fatalErrorMsg, fatalErrorMsgS,
43 debugTraceMsg, debugTraceMsgS,
60 import CoreLint ( lintCoreBindings )
61 import PrelNames ( iNTERACTIVE )
63 import Module ( Module )
66 import Rules ( RuleBase )
67 import BasicTypes ( CompilerPhase(..) )
71 import IOEnv hiding ( liftIO, failM, failWithM )
72 import qualified IOEnv ( liftIO )
73 import TcEnv ( tcLookupGlobal )
74 import TcRnMonad ( TcM, initTc )
78 import qualified ErrUtils as Err
82 import UniqFM ( UniqFM, mapUFM, filterUFM )
86 import Data.List ( intersperse )
90 import qualified Data.Map as Map
94 import Prelude hiding ( read )
99 import Control.Exception.Base
102 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
103 import qualified Language.Haskell.TH as TH
107 %************************************************************************
111 %************************************************************************
113 These functions are not CoreM monad stuff, but they probably ought to
114 be, and it makes a conveneint place. place for them. They print out
115 stuff before and after core passes, and do Core Lint when necessary.
118 showPass :: DynFlags -> CoreToDo -> IO ()
119 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
121 endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
122 endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
124 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
125 endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
126 endIteration dflags pass n
127 = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
128 (Just Opt_D_dump_simpl_iterations)
130 dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
131 dumpIfSet dump_me pass extra_info doc
132 = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
134 dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
135 -> [CoreBind] -> [CoreRule] -> IO ()
136 -- The "show_all" parameter says to print dump if -dverbose-core2core is on
137 dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
138 = do { -- Report result size if required
139 -- This has the side effect of forcing the intermediate to be evaluated
140 ; Err.debugTraceMsg dflags 2 $
141 (text " Result size =" <+> int (coreBindsSize binds))
143 -- Report verbosely, if required
144 ; let pass_name = showSDoc (ppr pass <+> extra_info)
145 dump_doc = pprCoreBindings binds
146 $$ ppUnless (null rules) pp_rules
148 ; case mb_dump_flag of
150 Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
152 dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core]
153 | otherwise = [dump_flag]
156 ; when (dopt Opt_DoCoreLinting dflags) $
157 do { let (warns, errs) = lintCoreBindings binds
158 ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
159 ; displayLintResults dflags pass warns errs binds } }
161 pp_rules = vcat [ blankLine
162 , ptext (sLit "------ Local rules for imported ids --------")
165 displayLintResults :: DynFlags -> CoreToDo
166 -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
168 displayLintResults dflags pass warns errs binds
169 | not (isEmptyBag errs)
170 = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
171 , ptext (sLit "*** Offending Program ***")
172 , pprCoreBindings binds
173 , ptext (sLit "*** End of Offense ***") ])
174 ; Err.ghcExit dflags 1 }
176 | not (isEmptyBag warns)
177 , not (case pass of { CoreDesugar -> True; _ -> False })
178 -- Suppress warnings after desugaring pass because some
179 -- are legitimate. Notably, the desugarer generates instance
180 -- methods with INLINE pragmas that form a mutually recursive
181 -- group. Only afer a round of simplification are they unravelled.
182 , not opt_NoDebugOutput
183 , showLintWarnings pass
184 = printDump (banner "warnings" $$ Err.pprMessageBag warns)
186 | otherwise = return ()
188 banner string = ptext (sLit "*** Core Lint") <+> text string
189 <+> ptext (sLit ": in result of") <+> ppr pass
190 <+> ptext (sLit "***")
192 showLintWarnings :: CoreToDo -> Bool
193 -- Disable Lint warnings on the first simplifier pass, because
194 -- there may be some INLINE knots still tied, which is tiresomely noisy
195 showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
196 showLintWarnings _ = True
200 %************************************************************************
202 The CoreToDo type and related types
203 Abstraction of core-to-core passes to run.
205 %************************************************************************
208 data CoreToDo -- These are diff core-to-core passes,
209 -- which may be invoked in any order,
210 -- as many times as you like.
212 = CoreDoSimplify -- The core-to-core simplifier.
213 Int -- Max iterations
217 | CoreDoFloatOutwards FloatOutSwitches
222 | CoreDoWorkerWrapper
227 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
228 -- matching this string
229 | CoreDoVectorisation
230 | CoreDoNothing -- Useful when building up
231 | CoreDoPasses [CoreToDo] -- lists of these things
233 | CoreDesugar -- Not strictly a core-to-core pass, but produces
234 -- Core output, and hence useful to pass to endPass
239 coreDumpFlag :: CoreToDo -> Maybe DynFlag
240 coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
241 coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
242 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
243 coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
244 coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
245 coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
246 coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
247 coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
248 coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
249 coreDumpFlag CoreCSE = Just Opt_D_dump_cse
250 coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
251 coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
252 coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
253 coreDumpFlag CorePrep = Just Opt_D_dump_prep
255 coreDumpFlag CoreDoPrintCore = Nothing
256 coreDumpFlag (CoreDoRuleCheck {}) = Nothing
257 coreDumpFlag CoreDoNothing = Nothing
258 coreDumpFlag CoreDoGlomBinds = Nothing
259 coreDumpFlag (CoreDoPasses {}) = Nothing
261 instance Outputable CoreToDo where
262 ppr (CoreDoSimplify n md) = ptext (sLit "Simplifier")
264 <+> ptext (sLit "max-iterations=") <> int n
265 ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
266 ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
267 ppr CoreLiberateCase = ptext (sLit "Liberate case")
268 ppr CoreDoStaticArgs = ptext (sLit "Static argument")
269 ppr CoreDoStrictness = ptext (sLit "Demand analysis")
270 ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
271 ppr CoreDoSpecialising = ptext (sLit "Specialise")
272 ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
273 ppr CoreCSE = ptext (sLit "Common sub-expression")
274 ppr CoreDoVectorisation = ptext (sLit "Vectorisation")
275 ppr CoreDesugar = ptext (sLit "Desugar")
276 ppr CoreTidy = ptext (sLit "Tidy Core")
277 ppr CorePrep = ptext (sLit "CorePrep")
278 ppr CoreDoPrintCore = ptext (sLit "Print core")
279 ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
280 ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
281 ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
282 ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
286 data SimplifierMode -- See comments in SimplMonad
288 { sm_names :: [String] -- Name(s) of the phase
289 , sm_phase :: CompilerPhase
290 , sm_rules :: Bool -- Whether RULES are enabled
291 , sm_inline :: Bool -- Whether inlining is enabled
292 , sm_case_case :: Bool -- Whether case-of-case is enabled
293 , sm_eta_expand :: Bool -- Whether eta-expansion is enabled
296 instance Outputable SimplifierMode where
297 ppr (SimplMode { sm_phase = p, sm_names = ss
298 , sm_rules = r, sm_inline = i
299 , sm_eta_expand = eta, sm_case_case = cc })
300 = ptext (sLit "SimplMode") <+> braces (
301 sep [ ptext (sLit "Phase =") <+> ppr p <+>
302 brackets (text (concat $ intersperse "," ss)) <> comma
303 , pp_flag i (sLit "inline") <> comma
304 , pp_flag r (sLit "rules") <> comma
305 , pp_flag eta (sLit "eta-expand") <> comma
306 , pp_flag cc (sLit "case-of-case") ])
308 pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
313 data FloatOutSwitches = FloatOutSwitches {
314 floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if
315 -- doing so will abstract over n or fewer
317 -- Nothing <=> float all lambdas to top level,
318 -- regardless of how many free variables
319 -- Just 0 is the vanilla case: float a lambda
320 -- iff it has no free vars
322 floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
323 -- even if they do not escape a lambda
324 floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
325 -- based on arity information.
327 instance Outputable FloatOutSwitches where
328 ppr = pprFloatOutSwitches
330 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
331 pprFloatOutSwitches sw
332 = ptext (sLit "FOS") <+> (braces $
333 sep $ punctuate comma $
334 [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw)
335 , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
336 , ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ])
340 %************************************************************************
342 Generating the main optimisation pipeline
344 %************************************************************************
347 getCoreToDo :: DynFlags -> [CoreToDo]
351 opt_level = optLevel dflags
352 phases = simplPhases dflags
353 max_iter = maxSimplIterations dflags
354 rule_check = ruleCheck dflags
355 strictness = dopt Opt_Strictness dflags
356 full_laziness = dopt Opt_FullLaziness dflags
357 do_specialise = dopt Opt_Specialise dflags
358 do_float_in = dopt Opt_FloatIn dflags
359 cse = dopt Opt_CSE dflags
360 spec_constr = dopt Opt_SpecConstr dflags
361 liberate_case = dopt Opt_LiberateCase dflags
362 static_args = dopt Opt_StaticArgumentTransformation dflags
363 rules_on = dopt Opt_EnableRewriteRules dflags
364 eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags
366 maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
368 maybe_strictness_before phase
369 = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
371 base_mode = SimplMode { sm_phase = panic "base_mode"
373 , sm_rules = rules_on
374 , sm_eta_expand = eta_expand_on
376 , sm_case_case = True }
378 simpl_phase phase names iter
380 $ [ maybe_strictness_before phase
381 , CoreDoSimplify iter
382 (base_mode { sm_phase = Phase phase
383 , sm_names = names })
385 , maybe_rule_check (Phase phase) ]
387 -- Vectorisation can introduce a fair few common sub expressions involving
388 -- DPH primitives. For example, see the Reverse test from dph-examples.
389 -- We need to eliminate these common sub expressions before their definitions
390 -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings,
391 -- so we also run simpl_gently to inline them.
392 ++ (if dopt Opt_Vectorise dflags && phase == 3
393 then [CoreCSE, simpl_gently]
397 = runWhen (dopt Opt_Vectorise dflags) $
398 CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
400 -- By default, we have 2 phases before phase 0.
402 -- Want to run with inline phase 2 after the specialiser to give
403 -- maximum chance for fusion to work before we inline build/augment
404 -- in phase 1. This made a difference in 'ansi' where an
405 -- overloaded function wasn't inlined till too late.
407 -- Need phase 1 so that build/augment get
408 -- inlined. I found that spectral/hartel/genfft lost some useful
409 -- strictness in the function sumcode' if augment is not inlined
410 -- before strictness analysis runs
411 simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
412 | phase <- [phases, phases-1 .. 1] ]
415 -- initial simplify: mk specialiser happy: minimum effort please
416 simpl_gently = CoreDoSimplify max_iter
417 (base_mode { sm_phase = InitialPhase
418 , sm_names = ["Gentle"]
419 , sm_rules = rules_on -- Note [RULEs enabled in SimplGently]
421 , sm_case_case = False })
422 -- Don't do case-of-case transformations.
423 -- This makes full laziness work better
426 if opt_level == 0 then
428 simpl_phase 0 ["final"] max_iter]
429 else {- opt_level >= 1 -} [
431 -- We want to do the static argument transform before full laziness as it
432 -- may expose extra opportunities to float things outwards. However, to fix
433 -- up the output of the transformation we need at do at least one simplify
434 -- after this before anything else
435 runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
437 -- We run vectorisation here for now, but we might also try to run
441 -- initial simplify: mk specialiser happy: minimum effort please
444 -- Specialisation is best done before full laziness
445 -- so that overloaded functions have all their dictionary lambdas manifest
446 runWhen do_specialise CoreDoSpecialising,
448 runWhen full_laziness $
449 CoreDoFloatOutwards FloatOutSwitches {
450 floatOutLambdas = Just 0,
451 floatOutConstants = True,
452 floatOutPartialApplications = False },
453 -- Was: gentleFloatOutSwitches
455 -- I have no idea why, but not floating constants to
456 -- top level is very bad in some cases.
458 -- Notably: p_ident in spectral/rewrite
459 -- Changing from "gentle" to "constantsOnly"
460 -- improved rewrite's allocation by 19%, and
461 -- made 0.0% difference to any other nofib
464 -- Not doing floatOutPartialApplications yet, we'll do
465 -- that later on when we've had a chance to get more
466 -- accurate arity information. In fact it makes no
467 -- difference at all to performance if we do it here,
468 -- but maybe we save some unnecessary to-and-fro in
471 runWhen do_float_in CoreDoFloatInwards,
475 -- Phase 0: allow all Ids to be inlined now
476 -- This gets foldr inlined before strictness analysis
478 -- At least 3 iterations because otherwise we land up with
479 -- huge dead expressions because of an infelicity in the
481 -- let k = BIG in foldr k z xs
482 -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
483 -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
485 simpl_phase 0 ["main"] (max max_iter 3),
487 runWhen strictness (CoreDoPasses [
491 simpl_phase 0 ["post-worker-wrapper"] max_iter
494 runWhen full_laziness $
495 CoreDoFloatOutwards FloatOutSwitches {
496 floatOutLambdas = floatLamArgs dflags,
497 floatOutConstants = True,
498 floatOutPartialApplications = True },
499 -- nofib/spectral/hartel/wang doubles in speed if you
500 -- do full laziness late in the day. It only happens
501 -- after fusion and other stuff, so the early pass doesn't
502 -- catch it. For the record, the redex is
503 -- f_el22 (f_el21 r_midblock)
507 -- We want CSE to follow the final full-laziness pass, because it may
508 -- succeed in commoning up things floated out by full laziness.
509 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
511 runWhen do_float_in CoreDoFloatInwards,
513 maybe_rule_check (Phase 0),
515 -- Case-liberation for -O2. This should be after
516 -- strictness analysis and the simplification which follows it.
517 runWhen liberate_case (CoreDoPasses [
519 simpl_phase 0 ["post-liberate-case"] max_iter
520 ]), -- Run the simplifier after LiberateCase to vastly
521 -- reduce the possiblility of shadowing
522 -- Reason: see Note [Shadowing] in SpecConstr.lhs
524 runWhen spec_constr CoreDoSpecConstr,
526 maybe_rule_check (Phase 0),
528 -- Final clean-up simplification:
529 simpl_phase 0 ["final"] max_iter
532 -- The core-to-core pass ordering is derived from the DynFlags:
533 runWhen :: Bool -> CoreToDo -> CoreToDo
534 runWhen True do_this = do_this
535 runWhen False _ = CoreDoNothing
537 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
538 runMaybe (Just x) f = f x
539 runMaybe Nothing _ = CoreDoNothing
541 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
542 dumpSimplPhase dflags mode
543 | Just spec_string <- shouldDumpSimplPhase dflags
544 = match_spec spec_string
546 = dopt Opt_D_verbose_core2core dflags
549 match_spec :: String -> Bool
550 match_spec spec_string
551 = or $ map (and . map match . split ':')
552 $ split ',' spec_string
554 match :: String -> Bool
556 match s = case reads s of
557 [(n,"")] -> phase_num n
560 phase_num :: Int -> Bool
561 phase_num n = case sm_phase mode of
565 phase_name :: String -> Bool
566 phase_name s = s `elem` sm_names mode
570 Note [RULEs enabled in SimplGently]
571 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
572 RULES are enabled when doing "gentle" simplification. Two reasons:
574 * We really want the class-op cancellation to happen:
575 op (df d1 d2) --> $cop3 d1 d2
576 because this breaks the mutual recursion between 'op' and 'df'
580 to work in Template Haskell when simplifying
581 splices, so we get simpler code for literal strings
583 But watch out: list fusion can prevent floating. So use phase control
584 to switch off those rules until after floating.
587 %************************************************************************
591 %************************************************************************
594 verboseSimplStats :: Bool
595 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
597 zeroSimplCount :: DynFlags -> SimplCount
598 isZeroSimplCount :: SimplCount -> Bool
599 pprSimplCount :: SimplCount -> SDoc
600 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
601 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
606 = VerySimplCount !Int -- Used when don't want detailed stats
609 ticks :: !Int, -- Total ticks
610 details :: !TickCounts, -- How many of each type
613 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
615 log2 :: [Tick] -- Last opt_HistorySize events before that
616 -- Having log1, log2 lets us accumulate the
617 -- recent history reasonably efficiently
620 type TickCounts = Map Tick Int
622 simplCountN :: SimplCount -> Int
623 simplCountN (VerySimplCount n) = n
624 simplCountN (SimplCount { ticks = n }) = n
626 zeroSimplCount dflags
627 -- This is where we decide whether to do
628 -- the VerySimpl version or the full-stats version
629 | dopt Opt_D_dump_simpl_stats dflags
630 = SimplCount {ticks = 0, details = Map.empty,
631 n_log = 0, log1 = [], log2 = []}
635 isZeroSimplCount (VerySimplCount n) = n==0
636 isZeroSimplCount (SimplCount { ticks = n }) = n==0
638 doFreeSimplTick tick sc@SimplCount { details = dts }
639 = sc { details = dts `addTick` tick }
640 doFreeSimplTick _ sc = sc
642 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
643 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
644 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
646 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
648 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
651 -- Don't use Map.unionWith because that's lazy, and we want to
652 -- be pretty strict here!
653 addTick :: TickCounts -> Tick -> TickCounts
654 addTick fm tick = case Map.lookup tick fm of
655 Nothing -> Map.insert tick 1 fm
656 Just n -> n1 `seq` Map.insert tick n1 fm
661 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
662 sc2@(SimplCount { ticks = tks2, details = dts2 })
663 = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
665 -- A hackish way of getting recent log info
666 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
667 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
670 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
671 plusSimplCount _ _ = panic "plusSimplCount"
672 -- We use one or the other consistently
674 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
675 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
676 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
678 pprTickCounts (Map.toList dts),
679 if verboseSimplStats then
681 ptext (sLit "Log (most recent first)"),
682 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
686 pprTickCounts :: [(Tick,Int)] -> SDoc
687 pprTickCounts [] = empty
688 pprTickCounts ((tick1,n1):ticks)
689 = vcat [int tot_n <+> text (tickString tick1),
690 pprTCDetails real_these,
694 tick1_tag = tickToTag tick1
695 (these, others) = span same_tick ticks
696 real_these = (tick1,n1):these
697 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
698 tot_n = sum [n | (_,n) <- real_these]
700 pprTCDetails :: [(Tick, Int)] -> SDoc
702 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
708 = PreInlineUnconditionally Id
709 | PostInlineUnconditionally Id
712 | RuleFired FastString -- Rule name
715 | EtaExpansion Id -- LHS binder
716 | EtaReduction Id -- Binder on outer lambda
717 | BetaReduction Id -- Lambda binder
720 | CaseOfCase Id -- Bndr on *inner* case
721 | KnownBranch Id -- Case binder
722 | CaseMerge Id -- Binder on outer case
723 | AltMerge Id -- Case binder
724 | CaseElim Id -- Case binder
725 | CaseIdentity Id -- Case binder
726 | FillInCaseDefault Id -- Case binder
729 | SimplifierDone -- Ticked at each iteration of the simplifier
731 instance Outputable Tick where
732 ppr tick = text (tickString tick) <+> pprTickCts tick
734 instance Eq Tick where
735 a == b = case a `cmpTick` b of
739 instance Ord Tick where
742 tickToTag :: Tick -> Int
743 tickToTag (PreInlineUnconditionally _) = 0
744 tickToTag (PostInlineUnconditionally _) = 1
745 tickToTag (UnfoldingDone _) = 2
746 tickToTag (RuleFired _) = 3
747 tickToTag LetFloatFromLet = 4
748 tickToTag (EtaExpansion _) = 5
749 tickToTag (EtaReduction _) = 6
750 tickToTag (BetaReduction _) = 7
751 tickToTag (CaseOfCase _) = 8
752 tickToTag (KnownBranch _) = 9
753 tickToTag (CaseMerge _) = 10
754 tickToTag (CaseElim _) = 11
755 tickToTag (CaseIdentity _) = 12
756 tickToTag (FillInCaseDefault _) = 13
757 tickToTag BottomFound = 14
758 tickToTag SimplifierDone = 16
759 tickToTag (AltMerge _) = 17
761 tickString :: Tick -> String
762 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
763 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
764 tickString (UnfoldingDone _) = "UnfoldingDone"
765 tickString (RuleFired _) = "RuleFired"
766 tickString LetFloatFromLet = "LetFloatFromLet"
767 tickString (EtaExpansion _) = "EtaExpansion"
768 tickString (EtaReduction _) = "EtaReduction"
769 tickString (BetaReduction _) = "BetaReduction"
770 tickString (CaseOfCase _) = "CaseOfCase"
771 tickString (KnownBranch _) = "KnownBranch"
772 tickString (CaseMerge _) = "CaseMerge"
773 tickString (AltMerge _) = "AltMerge"
774 tickString (CaseElim _) = "CaseElim"
775 tickString (CaseIdentity _) = "CaseIdentity"
776 tickString (FillInCaseDefault _) = "FillInCaseDefault"
777 tickString BottomFound = "BottomFound"
778 tickString SimplifierDone = "SimplifierDone"
780 pprTickCts :: Tick -> SDoc
781 pprTickCts (PreInlineUnconditionally v) = ppr v
782 pprTickCts (PostInlineUnconditionally v)= ppr v
783 pprTickCts (UnfoldingDone v) = ppr v
784 pprTickCts (RuleFired v) = ppr v
785 pprTickCts LetFloatFromLet = empty
786 pprTickCts (EtaExpansion v) = ppr v
787 pprTickCts (EtaReduction v) = ppr v
788 pprTickCts (BetaReduction v) = ppr v
789 pprTickCts (CaseOfCase v) = ppr v
790 pprTickCts (KnownBranch v) = ppr v
791 pprTickCts (CaseMerge v) = ppr v
792 pprTickCts (AltMerge v) = ppr v
793 pprTickCts (CaseElim v) = ppr v
794 pprTickCts (CaseIdentity v) = ppr v
795 pprTickCts (FillInCaseDefault v) = ppr v
798 cmpTick :: Tick -> Tick -> Ordering
799 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
804 cmpEqTick :: Tick -> Tick -> Ordering
805 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
806 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
807 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
808 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
809 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
810 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
811 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
812 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
813 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
814 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
815 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
816 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
817 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
818 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
823 %************************************************************************
825 Monad and carried data structure definitions
827 %************************************************************************
830 newtype CoreState = CoreState {
831 cs_uniq_supply :: UniqSupply
834 data CoreReader = CoreReader {
835 cr_hsc_env :: HscEnv,
836 cr_rule_base :: RuleBase,
840 data CoreWriter = CoreWriter {
841 cw_simpl_count :: SimplCount
844 emptyWriter :: DynFlags -> CoreWriter
845 emptyWriter dflags = CoreWriter {
846 cw_simpl_count = zeroSimplCount dflags
849 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
850 plusWriter w1 w2 = CoreWriter {
851 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
854 type CoreIOEnv = IOEnv CoreReader
856 -- | The monad used by Core-to-Core passes to access common state, register simplification
857 -- statistics and so on
858 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
860 instance Functor CoreM where
865 instance Monad CoreM where
866 return x = CoreM (\s -> nop s x)
867 mx >>= f = CoreM $ \s -> do
868 (x, s', w1) <- unCoreM mx s
869 (y, s'', w2) <- unCoreM (f x) s'
870 return (y, s'', w1 `plusWriter` w2)
872 instance Applicative CoreM where
876 -- For use if the user has imported Control.Monad.Error from MTL
877 -- Requires UndecidableInstances
878 instance MonadPlus IO => MonadPlus CoreM where
879 mzero = CoreM (const mzero)
880 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
882 instance MonadUnique CoreM where
883 getUniqueSupplyM = do
884 us <- getS cs_uniq_supply
885 let (us1, us2) = splitUniqSupply us
886 modifyS (\s -> s { cs_uniq_supply = us2 })
894 -> IO (a, SimplCount)
895 runCoreM hsc_env rule_base us mod m =
896 liftM extract $ runIOEnv reader $ unCoreM m state
898 reader = CoreReader {
899 cr_hsc_env = hsc_env,
900 cr_rule_base = rule_base,
907 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
908 extract (value, _, writer) = (value, cw_simpl_count writer)
913 %************************************************************************
915 Core combinators, not exported
917 %************************************************************************
921 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
924 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
926 read :: (CoreReader -> a) -> CoreM a
927 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
929 getS :: (CoreState -> a) -> CoreM a
930 getS f = CoreM (\s -> nop s (f s))
932 modifyS :: (CoreState -> CoreState) -> CoreM ()
933 modifyS f = CoreM (\s -> nop (f s) ())
935 write :: CoreWriter -> CoreM ()
936 write w = CoreM (\s -> return ((), s, w))
940 \subsection{Lifting IO into the monad}
944 -- | Lift an 'IOEnv' operation into 'CoreM'
945 liftIOEnv :: CoreIOEnv a -> CoreM a
946 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
948 instance MonadIO CoreM where
949 liftIO = liftIOEnv . IOEnv.liftIO
951 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
952 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
953 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
958 %************************************************************************
960 Reader, writer and state accessors
962 %************************************************************************
966 getHscEnv :: CoreM HscEnv
967 getHscEnv = read cr_hsc_env
969 getRuleBase :: CoreM RuleBase
970 getRuleBase = read cr_rule_base
972 getModule :: CoreM Module
973 getModule = read cr_module
975 addSimplCount :: SimplCount -> CoreM ()
976 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
978 -- Convenience accessors for useful fields of HscEnv
980 getDynFlags :: CoreM DynFlags
981 getDynFlags = fmap hsc_dflags getHscEnv
983 -- | The original name cache is the current mapping from 'Module' and
984 -- 'OccName' to a compiler-wide unique 'Name'
985 getOrigNameCache :: CoreM OrigNameCache
986 getOrigNameCache = do
987 nameCacheRef <- fmap hsc_NC getHscEnv
988 liftIO $ fmap nsNames $ readIORef nameCacheRef
993 %************************************************************************
995 Dealing with annotations
997 %************************************************************************
1000 -- | Get all annotations of a given type. This happens lazily, that is
1001 -- no deserialization will take place until the [a] is actually demanded and
1002 -- the [a] can also be empty (the UniqFM is not filtered).
1004 -- This should be done once at the start of a Core-to-Core pass that uses
1007 -- See Note [Annotations]
1008 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
1009 getAnnotations deserialize guts = do
1010 hsc_env <- getHscEnv
1011 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
1012 return (deserializeAnns deserialize ann_env)
1014 -- | Get at most one annotation of a given type per Unique.
1015 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
1016 getFirstAnnotations deserialize guts
1017 = liftM (mapUFM head . filterUFM (not . null))
1018 $ getAnnotations deserialize guts
1024 A Core-to-Core pass that wants to make use of annotations calls
1025 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
1026 annotations of a specific type. This produces all annotations from interface
1027 files read so far. However, annotations from interface files read during the
1028 pass will not be visible until getAnnotations is called again. This is similar
1029 to how rules work and probably isn't too bad.
1031 The current implementation could be optimised a bit: when looking up
1032 annotations for a thing from the HomePackageTable, we could search directly in
1033 the module where the thing is defined rather than building one UniqFM which
1034 contains all annotations we know of. This would work because annotations can
1035 only be given to things defined in the same module. However, since we would
1036 only want to deserialise every annotation once, we would have to build a cache
1037 for every module in the HTP. In the end, it's probably not worth it as long as
1038 we aren't using annotations heavily.
1040 %************************************************************************
1042 Direct screen output
1044 %************************************************************************
1048 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
1050 dflags <- getDynFlags
1051 liftIO $ how dflags doc
1053 -- | Output a String message to the screen
1054 putMsgS :: String -> CoreM ()
1055 putMsgS = putMsg . text
1057 -- | Output a message to the screen
1058 putMsg :: SDoc -> CoreM ()
1059 putMsg = msg Err.putMsg
1061 -- | Output a string error to the screen
1062 errorMsgS :: String -> CoreM ()
1063 errorMsgS = errorMsg . text
1065 -- | Output an error to the screen
1066 errorMsg :: SDoc -> CoreM ()
1067 errorMsg = msg Err.errorMsg
1069 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1070 fatalErrorMsgS :: String -> CoreM ()
1071 fatalErrorMsgS = fatalErrorMsg . text
1073 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1074 fatalErrorMsg :: SDoc -> CoreM ()
1075 fatalErrorMsg = msg Err.fatalErrorMsg
1077 -- | Output a string debugging message at verbosity level of @-v@ or higher
1078 debugTraceMsgS :: String -> CoreM ()
1079 debugTraceMsgS = debugTraceMsg . text
1081 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1082 debugTraceMsg :: SDoc -> CoreM ()
1083 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1085 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1086 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1087 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1092 initTcForLookup :: HscEnv -> TcM a -> IO a
1093 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1098 %************************************************************************
1102 %************************************************************************
1105 instance MonadThings CoreM where
1106 lookupThing name = do
1107 hsc_env <- getHscEnv
1108 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1111 %************************************************************************
1113 Template Haskell interoperability
1115 %************************************************************************
1119 -- | Attempt to convert a Template Haskell name to one that GHC can
1120 -- understand. Original TH names such as those you get when you use
1121 -- the @'foo@ syntax will be translated to their equivalent GHC name
1122 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1123 -- to names in the module being compiled, if possible. Exact TH names
1124 -- will be bound to the name they represent, exactly.
1125 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1126 thNameToGhcName th_name = do
1127 hsc_env <- getHscEnv
1128 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
1133 updNameCache' :: (NameCache -> (NameCache, a)) -> CoreM a
1134 updNameCache' upd_fn = do
1135 HscEnv { hsc_NC = nc_var } <- getHscEnv
1136 r <- liftIO $ atomicModifyIORef nc_var upd_fn
1137 r' <- liftIO $ readIORef nc_var
1138 _ <- liftIO $ evaluate r'
1141 -- cut-and-pasted from IfaceEnv, where it lives in the TcRn monad rather than CoreM
1142 lookupOrigCoreM :: Module -> OccName -> CoreM Name
1143 lookupOrigCoreM mod occ
1144 = do { mod `seq` occ `seq` return ()
1145 ; updNameCache' $ \name_cache ->
1146 case lookupOrigNameCache (nsNames name_cache) mod occ of {
1147 Just name -> (name_cache, name);
1149 case takeUniqFromSupply (nsUniqs name_cache) of {
1152 name = mkExternalName uniq mod occ noSrcSpan
1153 new_cache = extendNameCache (nsNames name_cache) mod occ name
1154 in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)