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,
58 import CoreLint ( lintCoreBindings )
59 import PrelNames ( iNTERACTIVE )
61 import Module ( Module )
64 import Rules ( RuleBase )
65 import BasicTypes ( CompilerPhase(..) )
69 import IOEnv hiding ( liftIO, failM, failWithM )
70 import qualified IOEnv ( liftIO )
71 import TcEnv ( tcLookupGlobal )
72 import TcRnMonad ( TcM, initTc )
76 import qualified ErrUtils as Err
80 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 _ (SimplMode { sm_phase = InitialPhase })) = 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.
206 Int -- Max iterations
210 | CoreDoFloatOutwards FloatOutSwitches
215 | CoreDoWorkerWrapper
220 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
221 -- matching this string
222 | CoreDoVectorisation
223 | CoreDoNothing -- Useful when building up
224 | CoreDoPasses [CoreToDo] -- lists of these things
226 | CoreDesugar -- Not strictly a core-to-core pass, but produces
227 -- Core output, and hence useful to pass to endPass
232 coreDumpFlag :: CoreToDo -> Maybe DynFlag
233 coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
234 coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
235 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
236 coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
237 coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
238 coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
239 coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
240 coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
241 coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
242 coreDumpFlag CoreCSE = Just Opt_D_dump_cse
243 coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
244 coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
245 coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
246 coreDumpFlag CorePrep = Just Opt_D_dump_prep
248 coreDumpFlag CoreDoPrintCore = Nothing
249 coreDumpFlag (CoreDoRuleCheck {}) = Nothing
250 coreDumpFlag CoreDoNothing = Nothing
251 coreDumpFlag CoreDoGlomBinds = Nothing
252 coreDumpFlag (CoreDoPasses {}) = Nothing
254 instance Outputable CoreToDo where
255 ppr (CoreDoSimplify n md) = ptext (sLit "Simplifier")
257 <+> ptext (sLit "max-iterations=") <> int n
258 ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
259 ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
260 ppr CoreLiberateCase = ptext (sLit "Liberate case")
261 ppr CoreDoStaticArgs = ptext (sLit "Static argument")
262 ppr CoreDoStrictness = ptext (sLit "Demand analysis")
263 ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
264 ppr CoreDoSpecialising = ptext (sLit "Specialise")
265 ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
266 ppr CoreCSE = ptext (sLit "Common sub-expression")
267 ppr CoreDoVectorisation = ptext (sLit "Vectorisation")
268 ppr CoreDesugar = ptext (sLit "Desugar")
269 ppr CoreTidy = ptext (sLit "Tidy Core")
270 ppr CorePrep = ptext (sLit "CorePrep")
271 ppr CoreDoPrintCore = ptext (sLit "Print core")
272 ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
273 ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
274 ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
275 ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
279 data SimplifierMode -- See comments in SimplMonad
281 { sm_names :: [String] -- Name(s) of the phase
282 , sm_phase :: CompilerPhase
283 , sm_rules :: Bool -- Whether RULES are enabled
284 , sm_inline :: Bool -- Whether inlining is enabled
285 , sm_case_case :: Bool -- Whether case-of-case is enabled
286 , sm_eta_expand :: Bool -- Whether eta-expansion is enabled
289 instance Outputable SimplifierMode where
290 ppr (SimplMode { sm_phase = p, sm_names = ss
291 , sm_rules = r, sm_inline = i
292 , sm_eta_expand = eta, sm_case_case = cc })
293 = ptext (sLit "SimplMode") <+> braces (
294 sep [ ptext (sLit "Phase =") <+> ppr p <+>
295 brackets (text (concat $ intersperse "," ss)) <> comma
296 , pp_flag i (sLit "inline") <> comma
297 , pp_flag r (sLit "rules") <> comma
298 , pp_flag eta (sLit "eta-expand") <> comma
299 , pp_flag cc (sLit "case-of-case") ])
301 pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
306 data FloatOutSwitches = FloatOutSwitches {
307 floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if
308 -- doing so will abstract over n or fewer
310 -- Nothing <=> float all lambdas to top level,
311 -- regardless of how many free variables
312 -- Just 0 is the vanilla case: float a lambda
313 -- iff it has no free vars
315 floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
316 -- even if they do not escape a lambda
317 floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
318 -- based on arity information.
320 instance Outputable FloatOutSwitches where
321 ppr = pprFloatOutSwitches
323 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
324 pprFloatOutSwitches sw
325 = ptext (sLit "FOS") <+> (braces $
326 sep $ punctuate comma $
327 [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw)
328 , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
329 , ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ])
333 %************************************************************************
335 Generating the main optimisation pipeline
337 %************************************************************************
340 getCoreToDo :: DynFlags -> [CoreToDo]
344 opt_level = optLevel dflags
345 phases = simplPhases dflags
346 max_iter = maxSimplIterations dflags
347 rule_check = ruleCheck dflags
348 strictness = dopt Opt_Strictness dflags
349 full_laziness = dopt Opt_FullLaziness dflags
350 do_specialise = dopt Opt_Specialise dflags
351 do_float_in = dopt Opt_FloatIn dflags
352 cse = dopt Opt_CSE dflags
353 spec_constr = dopt Opt_SpecConstr dflags
354 liberate_case = dopt Opt_LiberateCase dflags
355 static_args = dopt Opt_StaticArgumentTransformation dflags
356 rules_on = dopt Opt_EnableRewriteRules dflags
357 eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags
359 maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
361 maybe_strictness_before phase
362 = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
364 base_mode = SimplMode { sm_phase = panic "base_mode"
366 , sm_rules = rules_on
367 , sm_eta_expand = eta_expand_on
369 , sm_case_case = True }
371 simpl_phase phase names iter
373 $ [ maybe_strictness_before phase
374 , CoreDoSimplify iter
375 (base_mode { sm_phase = Phase phase
376 , sm_names = names })
378 , maybe_rule_check (Phase phase) ]
380 -- Vectorisation can introduce a fair few common sub expressions involving
381 -- DPH primitives. For example, see the Reverse test from dph-examples.
382 -- We need to eliminate these common sub expressions before their definitions
383 -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings,
384 -- so we also run simpl_gently to inline them.
385 ++ (if dopt Opt_Vectorise dflags && phase == 3
386 then [CoreCSE, simpl_gently]
390 = runWhen (dopt Opt_Vectorise dflags) $
391 CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
393 -- By default, we have 2 phases before phase 0.
395 -- Want to run with inline phase 2 after the specialiser to give
396 -- maximum chance for fusion to work before we inline build/augment
397 -- in phase 1. This made a difference in 'ansi' where an
398 -- overloaded function wasn't inlined till too late.
400 -- Need phase 1 so that build/augment get
401 -- inlined. I found that spectral/hartel/genfft lost some useful
402 -- strictness in the function sumcode' if augment is not inlined
403 -- before strictness analysis runs
404 simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
405 | phase <- [phases, phases-1 .. 1] ]
408 -- initial simplify: mk specialiser happy: minimum effort please
409 simpl_gently = CoreDoSimplify max_iter
410 (base_mode { sm_phase = InitialPhase
411 , sm_names = ["Gentle"]
412 , sm_rules = rules_on -- Note [RULEs enabled in SimplGently]
414 , sm_case_case = False })
415 -- Don't do case-of-case transformations.
416 -- This makes full laziness work better
419 if opt_level == 0 then
421 simpl_phase 0 ["final"] max_iter]
422 else {- opt_level >= 1 -} [
424 -- We want to do the static argument transform before full laziness as it
425 -- may expose extra opportunities to float things outwards. However, to fix
426 -- up the output of the transformation we need at do at least one simplify
427 -- after this before anything else
428 runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
430 -- We run vectorisation here for now, but we might also try to run
434 -- initial simplify: mk specialiser happy: minimum effort please
437 -- Specialisation is best done before full laziness
438 -- so that overloaded functions have all their dictionary lambdas manifest
439 runWhen do_specialise CoreDoSpecialising,
441 runWhen full_laziness $
442 CoreDoFloatOutwards FloatOutSwitches {
443 floatOutLambdas = Just 0,
444 floatOutConstants = True,
445 floatOutPartialApplications = False },
446 -- Was: gentleFloatOutSwitches
448 -- I have no idea why, but not floating constants to
449 -- top level is very bad in some cases.
451 -- Notably: p_ident in spectral/rewrite
452 -- Changing from "gentle" to "constantsOnly"
453 -- improved rewrite's allocation by 19%, and
454 -- made 0.0% difference to any other nofib
457 -- Not doing floatOutPartialApplications yet, we'll do
458 -- that later on when we've had a chance to get more
459 -- accurate arity information. In fact it makes no
460 -- difference at all to performance if we do it here,
461 -- but maybe we save some unnecessary to-and-fro in
464 runWhen do_float_in CoreDoFloatInwards,
468 -- Phase 0: allow all Ids to be inlined now
469 -- This gets foldr inlined before strictness analysis
471 -- At least 3 iterations because otherwise we land up with
472 -- huge dead expressions because of an infelicity in the
474 -- let k = BIG in foldr k z xs
475 -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
476 -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
478 simpl_phase 0 ["main"] (max max_iter 3),
480 runWhen strictness (CoreDoPasses [
484 simpl_phase 0 ["post-worker-wrapper"] max_iter
487 runWhen full_laziness $
488 CoreDoFloatOutwards FloatOutSwitches {
489 floatOutLambdas = floatLamArgs dflags,
490 floatOutConstants = True,
491 floatOutPartialApplications = True },
492 -- nofib/spectral/hartel/wang doubles in speed if you
493 -- do full laziness late in the day. It only happens
494 -- after fusion and other stuff, so the early pass doesn't
495 -- catch it. For the record, the redex is
496 -- f_el22 (f_el21 r_midblock)
500 -- We want CSE to follow the final full-laziness pass, because it may
501 -- succeed in commoning up things floated out by full laziness.
502 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
504 runWhen do_float_in CoreDoFloatInwards,
506 maybe_rule_check (Phase 0),
508 -- Case-liberation for -O2. This should be after
509 -- strictness analysis and the simplification which follows it.
510 runWhen liberate_case (CoreDoPasses [
512 simpl_phase 0 ["post-liberate-case"] max_iter
513 ]), -- Run the simplifier after LiberateCase to vastly
514 -- reduce the possiblility of shadowing
515 -- Reason: see Note [Shadowing] in SpecConstr.lhs
517 runWhen spec_constr CoreDoSpecConstr,
519 maybe_rule_check (Phase 0),
521 -- Final clean-up simplification:
522 simpl_phase 0 ["final"] max_iter
525 -- The core-to-core pass ordering is derived from the DynFlags:
526 runWhen :: Bool -> CoreToDo -> CoreToDo
527 runWhen True do_this = do_this
528 runWhen False _ = CoreDoNothing
530 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
531 runMaybe (Just x) f = f x
532 runMaybe Nothing _ = CoreDoNothing
534 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
535 dumpSimplPhase dflags mode
536 | Just spec_string <- shouldDumpSimplPhase dflags
537 = match_spec spec_string
539 = dopt Opt_D_verbose_core2core dflags
542 match_spec :: String -> Bool
543 match_spec spec_string
544 = or $ map (and . map match . split ':')
545 $ split ',' spec_string
547 match :: String -> Bool
549 match s = case reads s of
550 [(n,"")] -> phase_num n
553 phase_num :: Int -> Bool
554 phase_num n = case sm_phase mode of
558 phase_name :: String -> Bool
559 phase_name s = s `elem` sm_names mode
563 Note [RULEs enabled in SimplGently]
564 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
565 RULES are enabled when doing "gentle" simplification. Two reasons:
567 * We really want the class-op cancellation to happen:
568 op (df d1 d2) --> $cop3 d1 d2
569 because this breaks the mutual recursion between 'op' and 'df'
573 to work in Template Haskell when simplifying
574 splices, so we get simpler code for literal strings
576 But watch out: list fusion can prevent floating. So use phase control
577 to switch off those rules until after floating.
580 %************************************************************************
584 %************************************************************************
587 verboseSimplStats :: Bool
588 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
590 zeroSimplCount :: DynFlags -> SimplCount
591 isZeroSimplCount :: SimplCount -> Bool
592 pprSimplCount :: SimplCount -> SDoc
593 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
594 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
599 = VerySimplCount !Int -- Used when don't want detailed stats
602 ticks :: !Int, -- Total ticks
603 details :: !TickCounts, -- How many of each type
606 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
608 log2 :: [Tick] -- Last opt_HistorySize events before that
609 -- Having log1, log2 lets us accumulate the
610 -- recent history reasonably efficiently
613 type TickCounts = Map Tick Int
615 simplCountN :: SimplCount -> Int
616 simplCountN (VerySimplCount n) = n
617 simplCountN (SimplCount { ticks = n }) = n
619 zeroSimplCount dflags
620 -- This is where we decide whether to do
621 -- the VerySimpl version or the full-stats version
622 | dopt Opt_D_dump_simpl_stats dflags
623 = SimplCount {ticks = 0, details = Map.empty,
624 n_log = 0, log1 = [], log2 = []}
628 isZeroSimplCount (VerySimplCount n) = n==0
629 isZeroSimplCount (SimplCount { ticks = n }) = n==0
631 doFreeSimplTick tick sc@SimplCount { details = dts }
632 = sc { details = dts `addTick` tick }
633 doFreeSimplTick _ sc = sc
635 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
636 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
637 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
639 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
641 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
644 -- Don't use Map.unionWith because that's lazy, and we want to
645 -- be pretty strict here!
646 addTick :: TickCounts -> Tick -> TickCounts
647 addTick fm tick = case Map.lookup tick fm of
648 Nothing -> Map.insert tick 1 fm
649 Just n -> n1 `seq` Map.insert tick n1 fm
654 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
655 sc2@(SimplCount { ticks = tks2, details = dts2 })
656 = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
658 -- A hackish way of getting recent log info
659 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
660 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
663 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
664 plusSimplCount _ _ = panic "plusSimplCount"
665 -- We use one or the other consistently
667 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
668 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
669 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
671 pprTickCounts (Map.toList dts),
672 if verboseSimplStats then
674 ptext (sLit "Log (most recent first)"),
675 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
679 pprTickCounts :: [(Tick,Int)] -> SDoc
680 pprTickCounts [] = empty
681 pprTickCounts ((tick1,n1):ticks)
682 = vcat [int tot_n <+> text (tickString tick1),
683 pprTCDetails real_these,
687 tick1_tag = tickToTag tick1
688 (these, others) = span same_tick ticks
689 real_these = (tick1,n1):these
690 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
691 tot_n = sum [n | (_,n) <- real_these]
693 pprTCDetails :: [(Tick, Int)] -> SDoc
695 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
701 = PreInlineUnconditionally Id
702 | PostInlineUnconditionally Id
705 | RuleFired FastString -- Rule name
708 | EtaExpansion Id -- LHS binder
709 | EtaReduction Id -- Binder on outer lambda
710 | BetaReduction Id -- Lambda binder
713 | CaseOfCase Id -- Bndr on *inner* case
714 | KnownBranch Id -- Case binder
715 | CaseMerge Id -- Binder on outer case
716 | AltMerge Id -- Case binder
717 | CaseElim Id -- Case binder
718 | CaseIdentity Id -- Case binder
719 | FillInCaseDefault Id -- Case binder
722 | SimplifierDone -- Ticked at each iteration of the simplifier
724 instance Outputable Tick where
725 ppr tick = text (tickString tick) <+> pprTickCts tick
727 instance Eq Tick where
728 a == b = case a `cmpTick` b of
732 instance Ord Tick where
735 tickToTag :: Tick -> Int
736 tickToTag (PreInlineUnconditionally _) = 0
737 tickToTag (PostInlineUnconditionally _) = 1
738 tickToTag (UnfoldingDone _) = 2
739 tickToTag (RuleFired _) = 3
740 tickToTag LetFloatFromLet = 4
741 tickToTag (EtaExpansion _) = 5
742 tickToTag (EtaReduction _) = 6
743 tickToTag (BetaReduction _) = 7
744 tickToTag (CaseOfCase _) = 8
745 tickToTag (KnownBranch _) = 9
746 tickToTag (CaseMerge _) = 10
747 tickToTag (CaseElim _) = 11
748 tickToTag (CaseIdentity _) = 12
749 tickToTag (FillInCaseDefault _) = 13
750 tickToTag BottomFound = 14
751 tickToTag SimplifierDone = 16
752 tickToTag (AltMerge _) = 17
754 tickString :: Tick -> String
755 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
756 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
757 tickString (UnfoldingDone _) = "UnfoldingDone"
758 tickString (RuleFired _) = "RuleFired"
759 tickString LetFloatFromLet = "LetFloatFromLet"
760 tickString (EtaExpansion _) = "EtaExpansion"
761 tickString (EtaReduction _) = "EtaReduction"
762 tickString (BetaReduction _) = "BetaReduction"
763 tickString (CaseOfCase _) = "CaseOfCase"
764 tickString (KnownBranch _) = "KnownBranch"
765 tickString (CaseMerge _) = "CaseMerge"
766 tickString (AltMerge _) = "AltMerge"
767 tickString (CaseElim _) = "CaseElim"
768 tickString (CaseIdentity _) = "CaseIdentity"
769 tickString (FillInCaseDefault _) = "FillInCaseDefault"
770 tickString BottomFound = "BottomFound"
771 tickString SimplifierDone = "SimplifierDone"
773 pprTickCts :: Tick -> SDoc
774 pprTickCts (PreInlineUnconditionally v) = ppr v
775 pprTickCts (PostInlineUnconditionally v)= ppr v
776 pprTickCts (UnfoldingDone v) = ppr v
777 pprTickCts (RuleFired v) = ppr v
778 pprTickCts LetFloatFromLet = empty
779 pprTickCts (EtaExpansion v) = ppr v
780 pprTickCts (EtaReduction v) = ppr v
781 pprTickCts (BetaReduction v) = ppr v
782 pprTickCts (CaseOfCase v) = ppr v
783 pprTickCts (KnownBranch v) = ppr v
784 pprTickCts (CaseMerge v) = ppr v
785 pprTickCts (AltMerge v) = ppr v
786 pprTickCts (CaseElim v) = ppr v
787 pprTickCts (CaseIdentity v) = ppr v
788 pprTickCts (FillInCaseDefault v) = ppr v
791 cmpTick :: Tick -> Tick -> Ordering
792 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
797 cmpEqTick :: Tick -> Tick -> Ordering
798 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
799 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
800 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
801 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
802 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
803 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
804 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
805 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
806 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
807 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
808 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
809 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
810 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
811 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
816 %************************************************************************
818 Monad and carried data structure definitions
820 %************************************************************************
823 newtype CoreState = CoreState {
824 cs_uniq_supply :: UniqSupply
827 data CoreReader = CoreReader {
828 cr_hsc_env :: HscEnv,
829 cr_rule_base :: RuleBase,
833 data CoreWriter = CoreWriter {
834 cw_simpl_count :: SimplCount
837 emptyWriter :: DynFlags -> CoreWriter
838 emptyWriter dflags = CoreWriter {
839 cw_simpl_count = zeroSimplCount dflags
842 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
843 plusWriter w1 w2 = CoreWriter {
844 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
847 type CoreIOEnv = IOEnv CoreReader
849 -- | The monad used by Core-to-Core passes to access common state, register simplification
850 -- statistics and so on
851 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
853 instance Functor CoreM where
858 instance Monad CoreM where
859 return x = CoreM (\s -> nop s x)
860 mx >>= f = CoreM $ \s -> do
861 (x, s', w1) <- unCoreM mx s
862 (y, s'', w2) <- unCoreM (f x) s'
863 return (y, s'', w1 `plusWriter` w2)
865 instance Applicative CoreM where
869 -- For use if the user has imported Control.Monad.Error from MTL
870 -- Requires UndecidableInstances
871 instance MonadPlus IO => MonadPlus CoreM where
872 mzero = CoreM (const mzero)
873 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
875 instance MonadUnique CoreM where
876 getUniqueSupplyM = do
877 us <- getS cs_uniq_supply
878 let (us1, us2) = splitUniqSupply us
879 modifyS (\s -> s { cs_uniq_supply = us2 })
887 -> IO (a, SimplCount)
888 runCoreM hsc_env rule_base us mod m =
889 liftM extract $ runIOEnv reader $ unCoreM m state
891 reader = CoreReader {
892 cr_hsc_env = hsc_env,
893 cr_rule_base = rule_base,
900 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
901 extract (value, _, writer) = (value, cw_simpl_count writer)
906 %************************************************************************
908 Core combinators, not exported
910 %************************************************************************
914 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
917 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
919 read :: (CoreReader -> a) -> CoreM a
920 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
922 getS :: (CoreState -> a) -> CoreM a
923 getS f = CoreM (\s -> nop s (f s))
925 modifyS :: (CoreState -> CoreState) -> CoreM ()
926 modifyS f = CoreM (\s -> nop (f s) ())
928 write :: CoreWriter -> CoreM ()
929 write w = CoreM (\s -> return ((), s, w))
933 \subsection{Lifting IO into the monad}
937 -- | Lift an 'IOEnv' operation into 'CoreM'
938 liftIOEnv :: CoreIOEnv a -> CoreM a
939 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
941 instance MonadIO CoreM where
942 liftIO = liftIOEnv . IOEnv.liftIO
944 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
945 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
946 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
951 %************************************************************************
953 Reader, writer and state accessors
955 %************************************************************************
959 getHscEnv :: CoreM HscEnv
960 getHscEnv = read cr_hsc_env
962 getRuleBase :: CoreM RuleBase
963 getRuleBase = read cr_rule_base
965 getModule :: CoreM Module
966 getModule = read cr_module
968 addSimplCount :: SimplCount -> CoreM ()
969 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
971 -- Convenience accessors for useful fields of HscEnv
973 getDynFlags :: CoreM DynFlags
974 getDynFlags = fmap hsc_dflags getHscEnv
976 -- | The original name cache is the current mapping from 'Module' and
977 -- 'OccName' to a compiler-wide unique 'Name'
978 getOrigNameCache :: CoreM OrigNameCache
979 getOrigNameCache = do
980 nameCacheRef <- fmap hsc_NC getHscEnv
981 liftIO $ fmap nsNames $ readIORef nameCacheRef
986 %************************************************************************
988 Dealing with annotations
990 %************************************************************************
993 -- | Get all annotations of a given type. This happens lazily, that is
994 -- no deserialization will take place until the [a] is actually demanded and
995 -- the [a] can also be empty (the UniqFM is not filtered).
997 -- This should be done once at the start of a Core-to-Core pass that uses
1000 -- See Note [Annotations]
1001 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
1002 getAnnotations deserialize guts = do
1003 hsc_env <- getHscEnv
1004 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
1005 return (deserializeAnns deserialize ann_env)
1007 -- | Get at most one annotation of a given type per Unique.
1008 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
1009 getFirstAnnotations deserialize guts
1010 = liftM (mapUFM head . filterUFM (not . null))
1011 $ getAnnotations deserialize guts
1017 A Core-to-Core pass that wants to make use of annotations calls
1018 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
1019 annotations of a specific type. This produces all annotations from interface
1020 files read so far. However, annotations from interface files read during the
1021 pass will not be visible until getAnnotations is called again. This is similar
1022 to how rules work and probably isn't too bad.
1024 The current implementation could be optimised a bit: when looking up
1025 annotations for a thing from the HomePackageTable, we could search directly in
1026 the module where the thing is defined rather than building one UniqFM which
1027 contains all annotations we know of. This would work because annotations can
1028 only be given to things defined in the same module. However, since we would
1029 only want to deserialise every annotation once, we would have to build a cache
1030 for every module in the HTP. In the end, it's probably not worth it as long as
1031 we aren't using annotations heavily.
1033 %************************************************************************
1035 Direct screen output
1037 %************************************************************************
1041 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
1043 dflags <- getDynFlags
1044 liftIO $ how dflags doc
1046 -- | Output a String message to the screen
1047 putMsgS :: String -> CoreM ()
1048 putMsgS = putMsg . text
1050 -- | Output a message to the screen
1051 putMsg :: SDoc -> CoreM ()
1052 putMsg = msg Err.putMsg
1054 -- | Output a string error to the screen
1055 errorMsgS :: String -> CoreM ()
1056 errorMsgS = errorMsg . text
1058 -- | Output an error to the screen
1059 errorMsg :: SDoc -> CoreM ()
1060 errorMsg = msg Err.errorMsg
1062 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1063 fatalErrorMsgS :: String -> CoreM ()
1064 fatalErrorMsgS = fatalErrorMsg . text
1066 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1067 fatalErrorMsg :: SDoc -> CoreM ()
1068 fatalErrorMsg = msg Err.fatalErrorMsg
1070 -- | Output a string debugging message at verbosity level of @-v@ or higher
1071 debugTraceMsgS :: String -> CoreM ()
1072 debugTraceMsgS = debugTraceMsg . text
1074 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1075 debugTraceMsg :: SDoc -> CoreM ()
1076 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1078 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1079 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1080 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1085 initTcForLookup :: HscEnv -> TcM a -> IO a
1086 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1091 %************************************************************************
1095 %************************************************************************
1098 instance MonadThings CoreM where
1099 lookupThing name = do
1100 hsc_env <- getHscEnv
1101 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1104 %************************************************************************
1106 Template Haskell interoperability
1108 %************************************************************************
1112 -- | Attempt to convert a Template Haskell name to one that GHC can
1113 -- understand. Original TH names such as those you get when you use
1114 -- the @'foo@ syntax will be translated to their equivalent GHC name
1115 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1116 -- to names in the module being compiled, if possible. Exact TH names
1117 -- will be bound to the name they represent, exactly.
1118 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1119 thNameToGhcName th_name = do
1120 hsc_env <- getHscEnv
1121 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)