2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[CoreMonad]{The core pipeline monad}
7 {-# LANGUAGE UndecidableInstances #-}
10 -- * Configuration of the core-to-core passes
15 getCoreToDo, dumpSimplPhase,
18 SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
19 pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
24 -- ** Reading from the monad
25 getHscEnv, getRuleBase, getModule,
26 getDynFlags, getOrigNameCache,
28 -- ** Writing to the monad
31 -- ** Lifting into the monad
32 liftIO, liftIOWithCount,
33 liftIO1, liftIO2, liftIO3, liftIO4,
35 -- ** Dealing with annotations
36 getAnnotations, getFirstAnnotations,
39 showPass, endPass, endIteration, dumpIfSet,
42 putMsg, putMsgS, errorMsg, errorMsgS,
43 fatalErrorMsg, fatalErrorMsgS,
44 debugTraceMsg, debugTraceMsgS,
59 import CoreLint ( lintCoreBindings )
60 import PrelNames ( iNTERACTIVE )
62 import Module ( PackageId, Module )
65 import Rules ( RuleBase )
66 import BasicTypes ( CompilerPhase )
70 import IOEnv hiding ( liftIO, failM, failWithM )
71 import qualified IOEnv ( liftIO )
72 import TcEnv ( tcLookupGlobal )
73 import TcRnMonad ( TcM, initTc )
77 import qualified ErrUtils as Err
81 import UniqFM ( UniqFM, mapUFM, filterUFM )
84 import Data.List ( intersperse )
88 import qualified Data.Map as Map
92 import Prelude hiding ( read )
95 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
96 import qualified Language.Haskell.TH as TH
100 %************************************************************************
104 %************************************************************************
106 These functions are not CoreM monad stuff, but they probably ought to
107 be, and it makes a conveneint place. place for them. They print out
108 stuff before and after core passes, and do Core Lint when necessary.
111 showPass :: DynFlags -> CoreToDo -> IO ()
112 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
114 endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
115 endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
117 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
118 endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
119 endIteration dflags pass n
120 = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
121 (Just Opt_D_dump_simpl_iterations)
123 dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
124 dumpIfSet dump_me pass extra_info doc
125 = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
127 dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
128 -> [CoreBind] -> [CoreRule] -> IO ()
129 -- The "show_all" parameter says to print dump if -dverbose-core2core is on
130 dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
131 = do { -- Report result size if required
132 -- This has the side effect of forcing the intermediate to be evaluated
133 ; Err.debugTraceMsg dflags 2 $
134 (text " Result size =" <+> int (coreBindsSize binds))
136 -- Report verbosely, if required
137 ; let pass_name = showSDoc (ppr pass <+> extra_info)
138 dump_doc = pprCoreBindings binds
139 $$ ppUnless (null rules) pp_rules
141 ; case mb_dump_flag of
143 Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
145 dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core]
146 | otherwise = [dump_flag]
149 ; when (dopt Opt_DoCoreLinting dflags) $
150 do { let (warns, errs) = lintCoreBindings binds
151 ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
152 ; displayLintResults dflags pass warns errs binds } }
154 pp_rules = vcat [ blankLine
155 , ptext (sLit "------ Local rules for imported ids --------")
158 displayLintResults :: DynFlags -> CoreToDo
159 -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
161 displayLintResults dflags pass warns errs binds
162 | not (isEmptyBag errs)
163 = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
164 , ptext (sLit "*** Offending Program ***")
165 , pprCoreBindings binds
166 , ptext (sLit "*** End of Offense ***") ])
167 ; Err.ghcExit dflags 1 }
169 | not (isEmptyBag warns)
170 , not (case pass of { CoreDesugar -> True; _ -> False })
171 -- Suppress warnings after desugaring pass because some
172 -- are legitimate. Notably, the desugarer generates instance
173 -- methods with INLINE pragmas that form a mutually recursive
174 -- group. Only afer a round of simplification are they unravelled.
175 , not opt_NoDebugOutput
176 , showLintWarnings pass
177 = printDump (banner "warnings" $$ Err.pprMessageBag warns)
179 | otherwise = return ()
181 banner string = ptext (sLit "*** Core Lint") <+> text string
182 <+> ptext (sLit ": in result of") <+> ppr pass
183 <+> ptext (sLit "***")
185 showLintWarnings :: CoreToDo -> Bool
186 -- Disable Lint warnings on the first simplifier pass, because
187 -- there may be some INLINE knots still tied, which is tiresomely noisy
188 showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
189 showLintWarnings _ = True
193 %************************************************************************
195 The CoreToDo type and related types
196 Abstraction of core-to-core passes to run.
198 %************************************************************************
201 data CoreToDo -- These are diff core-to-core passes,
202 -- which may be invoked in any order,
203 -- as many times as you like.
205 = CoreDoSimplify -- The core-to-core simplifier.
207 Int -- Max iterations
208 [SimplifierSwitch] -- Each run of the simplifier can take a different
209 -- set of simplifier-specific flags.
211 | CoreDoFloatOutwards FloatOutSwitches
216 | CoreDoWorkerWrapper
221 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
222 -- matching this string
223 | CoreDoVectorisation PackageId
224 | CoreDoNothing -- Useful when building up
225 | CoreDoPasses [CoreToDo] -- lists of these things
227 | CoreDesugar -- Not strictly a core-to-core pass, but produces
228 -- Core output, and hence useful to pass to endPass
233 coreDumpFlag :: CoreToDo -> Maybe DynFlag
234 coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
235 coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
236 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
237 coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
238 coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
239 coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
240 coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
241 coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
242 coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
243 coreDumpFlag CoreCSE = Just Opt_D_dump_cse
244 coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
245 coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
246 coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
247 coreDumpFlag CorePrep = Just Opt_D_dump_prep
249 coreDumpFlag CoreDoPrintCore = Nothing
250 coreDumpFlag (CoreDoRuleCheck {}) = Nothing
251 coreDumpFlag CoreDoNothing = Nothing
252 coreDumpFlag CoreDoGlomBinds = Nothing
253 coreDumpFlag (CoreDoPasses {}) = Nothing
255 instance Outputable CoreToDo where
256 ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
258 <+> ptext (sLit "max-iterations=") <> int n
259 ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
260 ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
261 ppr CoreLiberateCase = ptext (sLit "Liberate case")
262 ppr CoreDoStaticArgs = ptext (sLit "Static argument")
263 ppr CoreDoStrictness = ptext (sLit "Demand analysis")
264 ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
265 ppr CoreDoSpecialising = ptext (sLit "Specialise")
266 ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
267 ppr CoreCSE = ptext (sLit "Common sub-expression")
268 ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
269 ppr CoreDesugar = ptext (sLit "Desugar")
270 ppr CoreTidy = ptext (sLit "Tidy Core")
271 ppr CorePrep = ptext (sLit "CorePrep")
272 ppr CoreDoPrintCore = ptext (sLit "Print core")
273 ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
274 ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
275 ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
276 ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
280 data SimplifierMode -- See comments in SimplMonad
282 { sm_rules :: Bool -- Whether RULES are enabled
283 , sm_inline :: Bool } -- Whether inlining is enabled
286 { sm_num :: Int -- Phase number; counts downward so 0 is last phase
287 , sm_names :: [String] } -- Name(s) of the phase
289 instance Outputable SimplifierMode where
290 ppr (SimplPhase { sm_num = n, sm_names = ss })
291 = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
292 ppr (SimplGently { sm_rules = r, sm_inline = i })
293 = ptext (sLit "gentle") <>
294 brackets (pp_flag r (sLit "rules") <> comma <>
295 pp_flag i (sLit "inline"))
297 pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
299 data SimplifierSwitch
305 data FloatOutSwitches = FloatOutSwitches {
306 floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
307 floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
308 -- even if they do not escape a lambda
309 floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
310 -- based on arity information.
312 instance Outputable FloatOutSwitches where
313 ppr = pprFloatOutSwitches
315 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
316 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
317 <+> pp_not (floatOutConstants sw) <+> text "constants"
320 pp_not False = text "not"
322 -- | Switches that specify the minimum amount of floating out
323 -- gentleFloatOutSwitches :: FloatOutSwitches
324 -- gentleFloatOutSwitches = FloatOutSwitches False False
328 %************************************************************************
330 Generating the main optimisation pipeline
332 %************************************************************************
335 getCoreToDo :: DynFlags -> [CoreToDo]
339 opt_level = optLevel dflags
340 phases = simplPhases dflags
341 max_iter = maxSimplIterations dflags
342 strictness = dopt Opt_Strictness dflags
343 full_laziness = dopt Opt_FullLaziness dflags
344 do_specialise = dopt Opt_Specialise dflags
345 do_float_in = dopt Opt_FloatIn dflags
346 cse = dopt Opt_CSE dflags
347 spec_constr = dopt Opt_SpecConstr dflags
348 liberate_case = dopt Opt_LiberateCase dflags
349 rule_check = ruleCheck dflags
350 static_args = dopt Opt_StaticArgumentTransformation dflags
352 maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
354 maybe_strictness_before phase
355 = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
357 simpl_phase phase names iter
359 [ maybe_strictness_before phase
360 , CoreDoSimplify (SimplPhase phase names)
362 , maybe_rule_check phase
366 = runWhen (dopt Opt_Vectorise dflags)
367 $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
370 -- By default, we have 2 phases before phase 0.
372 -- Want to run with inline phase 2 after the specialiser to give
373 -- maximum chance for fusion to work before we inline build/augment
374 -- in phase 1. This made a difference in 'ansi' where an
375 -- overloaded function wasn't inlined till too late.
377 -- Need phase 1 so that build/augment get
378 -- inlined. I found that spectral/hartel/genfft lost some useful
379 -- strictness in the function sumcode' if augment is not inlined
380 -- before strictness analysis runs
381 simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
382 | phase <- [phases, phases-1 .. 1] ]
385 -- initial simplify: mk specialiser happy: minimum effort please
386 simpl_gently = CoreDoSimplify
387 (SimplGently { sm_rules = True, sm_inline = False })
388 -- See Note [Gentle mode] and
389 -- Note [RULEs enabled in SimplGently] in SimplUtils
394 NoCaseOfCase -- Don't do case-of-case transformations.
395 -- This makes full laziness work better
399 if opt_level == 0 then
401 simpl_phase 0 ["final"] max_iter]
402 else {- opt_level >= 1 -} [
404 -- We want to do the static argument transform before full laziness as it
405 -- may expose extra opportunities to float things outwards. However, to fix
406 -- up the output of the transformation we need at do at least one simplify
407 -- after this before anything else
408 runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
410 -- We run vectorisation here for now, but we might also try to run
414 -- initial simplify: mk specialiser happy: minimum effort please
417 -- Specialisation is best done before full laziness
418 -- so that overloaded functions have all their dictionary lambdas manifest
419 runWhen do_specialise CoreDoSpecialising,
421 runWhen full_laziness $
422 CoreDoFloatOutwards FloatOutSwitches {
423 floatOutLambdas = False,
424 floatOutConstants = True,
425 floatOutPartialApplications = False },
426 -- Was: gentleFloatOutSwitches
428 -- I have no idea why, but not floating constants to
429 -- top level is very bad in some cases.
431 -- Notably: p_ident in spectral/rewrite
432 -- Changing from "gentle" to "constantsOnly"
433 -- improved rewrite's allocation by 19%, and
434 -- made 0.0% difference to any other nofib
437 -- Not doing floatOutPartialApplications yet, we'll do
438 -- that later on when we've had a chance to get more
439 -- accurate arity information. In fact it makes no
440 -- difference at all to performance if we do it here,
441 -- but maybe we save some unnecessary to-and-fro in
444 runWhen do_float_in CoreDoFloatInwards,
448 -- Phase 0: allow all Ids to be inlined now
449 -- This gets foldr inlined before strictness analysis
451 -- At least 3 iterations because otherwise we land up with
452 -- huge dead expressions because of an infelicity in the
454 -- let k = BIG in foldr k z xs
455 -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
456 -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
458 simpl_phase 0 ["main"] (max max_iter 3),
460 runWhen strictness (CoreDoPasses [
464 simpl_phase 0 ["post-worker-wrapper"] max_iter
467 runWhen full_laziness $
468 CoreDoFloatOutwards FloatOutSwitches {
469 floatOutLambdas = False,
470 floatOutConstants = True,
471 floatOutPartialApplications = True },
472 -- nofib/spectral/hartel/wang doubles in speed if you
473 -- do full laziness late in the day. It only happens
474 -- after fusion and other stuff, so the early pass doesn't
475 -- catch it. For the record, the redex is
476 -- f_el22 (f_el21 r_midblock)
480 -- We want CSE to follow the final full-laziness pass, because it may
481 -- succeed in commoning up things floated out by full laziness.
482 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
484 runWhen do_float_in CoreDoFloatInwards,
488 -- Case-liberation for -O2. This should be after
489 -- strictness analysis and the simplification which follows it.
490 runWhen liberate_case (CoreDoPasses [
492 simpl_phase 0 ["post-liberate-case"] max_iter
493 ]), -- Run the simplifier after LiberateCase to vastly
494 -- reduce the possiblility of shadowing
495 -- Reason: see Note [Shadowing] in SpecConstr.lhs
497 runWhen spec_constr CoreDoSpecConstr,
501 -- Final clean-up simplification:
502 simpl_phase 0 ["final"] max_iter
505 -- The core-to-core pass ordering is derived from the DynFlags:
506 runWhen :: Bool -> CoreToDo -> CoreToDo
507 runWhen True do_this = do_this
508 runWhen False _ = CoreDoNothing
510 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
511 runMaybe (Just x) f = f x
512 runMaybe Nothing _ = CoreDoNothing
514 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
515 dumpSimplPhase dflags mode
516 | Just spec_string <- shouldDumpSimplPhase dflags
517 = match_spec spec_string
519 = dopt Opt_D_verbose_core2core dflags
522 match_spec :: String -> Bool
523 match_spec spec_string
524 = or $ map (and . map match . split ':')
525 $ split ',' spec_string
527 match :: String -> Bool
529 match s = case reads s of
530 [(n,"")] -> phase_num n
533 phase_num :: Int -> Bool
534 phase_num n = case mode of
535 SimplPhase k _ -> n == k
538 phase_name :: String -> Bool
539 phase_name s = case mode of
540 SimplGently {} -> s == "gentle"
541 SimplPhase { sm_names = ss } -> s `elem` ss
545 %************************************************************************
549 %************************************************************************
552 verboseSimplStats :: Bool
553 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
555 zeroSimplCount :: DynFlags -> SimplCount
556 isZeroSimplCount :: SimplCount -> Bool
557 pprSimplCount :: SimplCount -> SDoc
558 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
559 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
564 = VerySimplCount !Int -- Used when don't want detailed stats
567 ticks :: !Int, -- Total ticks
568 details :: !TickCounts, -- How many of each type
571 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
573 log2 :: [Tick] -- Last opt_HistorySize events before that
574 -- Having log1, log2 lets us accumulate the
575 -- recent history reasonably efficiently
578 type TickCounts = Map Tick Int
580 simplCountN :: SimplCount -> Int
581 simplCountN (VerySimplCount n) = n
582 simplCountN (SimplCount { ticks = n }) = n
584 zeroSimplCount dflags
585 -- This is where we decide whether to do
586 -- the VerySimpl version or the full-stats version
587 | dopt Opt_D_dump_simpl_stats dflags
588 = SimplCount {ticks = 0, details = Map.empty,
589 n_log = 0, log1 = [], log2 = []}
593 isZeroSimplCount (VerySimplCount n) = n==0
594 isZeroSimplCount (SimplCount { ticks = n }) = n==0
596 doFreeSimplTick tick sc@SimplCount { details = dts }
597 = sc { details = dts `addTick` tick }
598 doFreeSimplTick _ sc = sc
600 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
601 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
602 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
604 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
606 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
609 -- Don't use Map.unionWith because that's lazy, and we want to
610 -- be pretty strict here!
611 addTick :: TickCounts -> Tick -> TickCounts
612 addTick fm tick = case Map.lookup tick fm of
613 Nothing -> Map.insert tick 1 fm
614 Just n -> n1 `seq` Map.insert tick n1 fm
619 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
620 sc2@(SimplCount { ticks = tks2, details = dts2 })
621 = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
623 -- A hackish way of getting recent log info
624 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
625 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
628 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
629 plusSimplCount _ _ = panic "plusSimplCount"
630 -- We use one or the other consistently
632 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
633 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
634 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
636 pprTickCounts (Map.toList dts),
637 if verboseSimplStats then
639 ptext (sLit "Log (most recent first)"),
640 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
644 pprTickCounts :: [(Tick,Int)] -> SDoc
645 pprTickCounts [] = empty
646 pprTickCounts ((tick1,n1):ticks)
647 = vcat [int tot_n <+> text (tickString tick1),
648 pprTCDetails real_these,
652 tick1_tag = tickToTag tick1
653 (these, others) = span same_tick ticks
654 real_these = (tick1,n1):these
655 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
656 tot_n = sum [n | (_,n) <- real_these]
658 pprTCDetails :: [(Tick, Int)] -> SDoc
660 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
666 = PreInlineUnconditionally Id
667 | PostInlineUnconditionally Id
670 | RuleFired FastString -- Rule name
673 | EtaExpansion Id -- LHS binder
674 | EtaReduction Id -- Binder on outer lambda
675 | BetaReduction Id -- Lambda binder
678 | CaseOfCase Id -- Bndr on *inner* case
679 | KnownBranch Id -- Case binder
680 | CaseMerge Id -- Binder on outer case
681 | AltMerge Id -- Case binder
682 | CaseElim Id -- Case binder
683 | CaseIdentity Id -- Case binder
684 | FillInCaseDefault Id -- Case binder
687 | SimplifierDone -- Ticked at each iteration of the simplifier
689 instance Outputable Tick where
690 ppr tick = text (tickString tick) <+> pprTickCts tick
692 instance Eq Tick where
693 a == b = case a `cmpTick` b of
697 instance Ord Tick where
700 tickToTag :: Tick -> Int
701 tickToTag (PreInlineUnconditionally _) = 0
702 tickToTag (PostInlineUnconditionally _) = 1
703 tickToTag (UnfoldingDone _) = 2
704 tickToTag (RuleFired _) = 3
705 tickToTag LetFloatFromLet = 4
706 tickToTag (EtaExpansion _) = 5
707 tickToTag (EtaReduction _) = 6
708 tickToTag (BetaReduction _) = 7
709 tickToTag (CaseOfCase _) = 8
710 tickToTag (KnownBranch _) = 9
711 tickToTag (CaseMerge _) = 10
712 tickToTag (CaseElim _) = 11
713 tickToTag (CaseIdentity _) = 12
714 tickToTag (FillInCaseDefault _) = 13
715 tickToTag BottomFound = 14
716 tickToTag SimplifierDone = 16
717 tickToTag (AltMerge _) = 17
719 tickString :: Tick -> String
720 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
721 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
722 tickString (UnfoldingDone _) = "UnfoldingDone"
723 tickString (RuleFired _) = "RuleFired"
724 tickString LetFloatFromLet = "LetFloatFromLet"
725 tickString (EtaExpansion _) = "EtaExpansion"
726 tickString (EtaReduction _) = "EtaReduction"
727 tickString (BetaReduction _) = "BetaReduction"
728 tickString (CaseOfCase _) = "CaseOfCase"
729 tickString (KnownBranch _) = "KnownBranch"
730 tickString (CaseMerge _) = "CaseMerge"
731 tickString (AltMerge _) = "AltMerge"
732 tickString (CaseElim _) = "CaseElim"
733 tickString (CaseIdentity _) = "CaseIdentity"
734 tickString (FillInCaseDefault _) = "FillInCaseDefault"
735 tickString BottomFound = "BottomFound"
736 tickString SimplifierDone = "SimplifierDone"
738 pprTickCts :: Tick -> SDoc
739 pprTickCts (PreInlineUnconditionally v) = ppr v
740 pprTickCts (PostInlineUnconditionally v)= ppr v
741 pprTickCts (UnfoldingDone v) = ppr v
742 pprTickCts (RuleFired v) = ppr v
743 pprTickCts LetFloatFromLet = empty
744 pprTickCts (EtaExpansion v) = ppr v
745 pprTickCts (EtaReduction v) = ppr v
746 pprTickCts (BetaReduction v) = ppr v
747 pprTickCts (CaseOfCase v) = ppr v
748 pprTickCts (KnownBranch v) = ppr v
749 pprTickCts (CaseMerge v) = ppr v
750 pprTickCts (AltMerge v) = ppr v
751 pprTickCts (CaseElim v) = ppr v
752 pprTickCts (CaseIdentity v) = ppr v
753 pprTickCts (FillInCaseDefault v) = ppr v
756 cmpTick :: Tick -> Tick -> Ordering
757 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
762 cmpEqTick :: Tick -> Tick -> Ordering
763 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
764 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
765 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
766 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
767 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
768 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
769 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
770 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
771 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
772 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
773 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
774 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
775 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
776 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
781 %************************************************************************
783 Monad and carried data structure definitions
785 %************************************************************************
788 newtype CoreState = CoreState {
789 cs_uniq_supply :: UniqSupply
792 data CoreReader = CoreReader {
793 cr_hsc_env :: HscEnv,
794 cr_rule_base :: RuleBase,
798 data CoreWriter = CoreWriter {
799 cw_simpl_count :: SimplCount
802 emptyWriter :: DynFlags -> CoreWriter
803 emptyWriter dflags = CoreWriter {
804 cw_simpl_count = zeroSimplCount dflags
807 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
808 plusWriter w1 w2 = CoreWriter {
809 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
812 type CoreIOEnv = IOEnv CoreReader
814 -- | The monad used by Core-to-Core passes to access common state, register simplification
815 -- statistics and so on
816 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
818 instance Functor CoreM where
823 instance Monad CoreM where
824 return x = CoreM (\s -> nop s x)
825 mx >>= f = CoreM $ \s -> do
826 (x, s', w1) <- unCoreM mx s
827 (y, s'', w2) <- unCoreM (f x) s'
828 return (y, s'', w1 `plusWriter` w2)
830 instance Applicative CoreM where
834 -- For use if the user has imported Control.Monad.Error from MTL
835 -- Requires UndecidableInstances
836 instance MonadPlus IO => MonadPlus CoreM where
837 mzero = CoreM (const mzero)
838 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
840 instance MonadUnique CoreM where
841 getUniqueSupplyM = do
842 us <- getS cs_uniq_supply
843 let (us1, us2) = splitUniqSupply us
844 modifyS (\s -> s { cs_uniq_supply = us2 })
852 -> IO (a, SimplCount)
853 runCoreM hsc_env rule_base us mod m =
854 liftM extract $ runIOEnv reader $ unCoreM m state
856 reader = CoreReader {
857 cr_hsc_env = hsc_env,
858 cr_rule_base = rule_base,
865 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
866 extract (value, _, writer) = (value, cw_simpl_count writer)
871 %************************************************************************
873 Core combinators, not exported
875 %************************************************************************
879 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
882 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
884 read :: (CoreReader -> a) -> CoreM a
885 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
887 getS :: (CoreState -> a) -> CoreM a
888 getS f = CoreM (\s -> nop s (f s))
890 modifyS :: (CoreState -> CoreState) -> CoreM ()
891 modifyS f = CoreM (\s -> nop (f s) ())
893 write :: CoreWriter -> CoreM ()
894 write w = CoreM (\s -> return ((), s, w))
898 \subsection{Lifting IO into the monad}
902 -- | Lift an 'IOEnv' operation into 'CoreM'
903 liftIOEnv :: CoreIOEnv a -> CoreM a
904 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
906 instance MonadIO CoreM where
907 liftIO = liftIOEnv . IOEnv.liftIO
909 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
910 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
911 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
916 %************************************************************************
918 Reader, writer and state accessors
920 %************************************************************************
924 getHscEnv :: CoreM HscEnv
925 getHscEnv = read cr_hsc_env
927 getRuleBase :: CoreM RuleBase
928 getRuleBase = read cr_rule_base
930 getModule :: CoreM Module
931 getModule = read cr_module
933 addSimplCount :: SimplCount -> CoreM ()
934 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
936 -- Convenience accessors for useful fields of HscEnv
938 getDynFlags :: CoreM DynFlags
939 getDynFlags = fmap hsc_dflags getHscEnv
941 -- | The original name cache is the current mapping from 'Module' and
942 -- 'OccName' to a compiler-wide unique 'Name'
943 getOrigNameCache :: CoreM OrigNameCache
944 getOrigNameCache = do
945 nameCacheRef <- fmap hsc_NC getHscEnv
946 liftIO $ fmap nsNames $ readIORef nameCacheRef
951 %************************************************************************
953 Dealing with annotations
955 %************************************************************************
958 -- | Get all annotations of a given type. This happens lazily, that is
959 -- no deserialization will take place until the [a] is actually demanded and
960 -- the [a] can also be empty (the UniqFM is not filtered).
962 -- This should be done once at the start of a Core-to-Core pass that uses
965 -- See Note [Annotations]
966 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
967 getAnnotations deserialize guts = do
969 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
970 return (deserializeAnns deserialize ann_env)
972 -- | Get at most one annotation of a given type per Unique.
973 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
974 getFirstAnnotations deserialize guts
975 = liftM (mapUFM head . filterUFM (not . null))
976 $ getAnnotations deserialize guts
982 A Core-to-Core pass that wants to make use of annotations calls
983 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
984 annotations of a specific type. This produces all annotations from interface
985 files read so far. However, annotations from interface files read during the
986 pass will not be visible until getAnnotations is called again. This is similar
987 to how rules work and probably isn't too bad.
989 The current implementation could be optimised a bit: when looking up
990 annotations for a thing from the HomePackageTable, we could search directly in
991 the module where the thing is defined rather than building one UniqFM which
992 contains all annotations we know of. This would work because annotations can
993 only be given to things defined in the same module. However, since we would
994 only want to deserialise every annotation once, we would have to build a cache
995 for every module in the HTP. In the end, it's probably not worth it as long as
996 we aren't using annotations heavily.
998 %************************************************************************
1000 Direct screen output
1002 %************************************************************************
1006 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
1008 dflags <- getDynFlags
1009 liftIO $ how dflags doc
1011 -- | Output a String message to the screen
1012 putMsgS :: String -> CoreM ()
1013 putMsgS = putMsg . text
1015 -- | Output a message to the screen
1016 putMsg :: SDoc -> CoreM ()
1017 putMsg = msg Err.putMsg
1019 -- | Output a string error to the screen
1020 errorMsgS :: String -> CoreM ()
1021 errorMsgS = errorMsg . text
1023 -- | Output an error to the screen
1024 errorMsg :: SDoc -> CoreM ()
1025 errorMsg = msg Err.errorMsg
1027 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1028 fatalErrorMsgS :: String -> CoreM ()
1029 fatalErrorMsgS = fatalErrorMsg . text
1031 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1032 fatalErrorMsg :: SDoc -> CoreM ()
1033 fatalErrorMsg = msg Err.fatalErrorMsg
1035 -- | Output a string debugging message at verbosity level of @-v@ or higher
1036 debugTraceMsgS :: String -> CoreM ()
1037 debugTraceMsgS = debugTraceMsg . text
1039 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1040 debugTraceMsg :: SDoc -> CoreM ()
1041 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1043 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1044 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1045 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1050 initTcForLookup :: HscEnv -> TcM a -> IO a
1051 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1056 %************************************************************************
1060 %************************************************************************
1063 instance MonadThings CoreM where
1064 lookupThing name = do
1065 hsc_env <- getHscEnv
1066 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1069 %************************************************************************
1071 Template Haskell interoperability
1073 %************************************************************************
1077 -- | Attempt to convert a Template Haskell name to one that GHC can
1078 -- understand. Original TH names such as those you get when you use
1079 -- the @'foo@ syntax will be translated to their equivalent GHC name
1080 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1081 -- to names in the module being compiled, if possible. Exact TH names
1082 -- will be bound to the name they represent, exactly.
1083 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1084 thNameToGhcName th_name = do
1085 hsc_env <- getHscEnv
1086 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)