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,
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 endPass, endPassIf, endIteration,
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
80 import LazyUniqFM ( UniqFM, mapUFM, filterUFM )
84 import Data.List ( intersperse )
90 import Prelude hiding ( read )
93 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
94 import qualified Language.Haskell.TH as TH
98 %************************************************************************
102 %************************************************************************
104 These functions are not CoreM monad stuff, but they probably ought to
105 be, and it makes a conveneint place. place for them. They print out
106 stuff before and after core passes, and do Core Lint when necessary.
109 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
110 endPass = dumpAndLint Err.dumpIfSet_core
112 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
113 endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
115 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
116 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
117 endIteration = dumpAndLint Err.dumpIfSet_dyn
119 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
120 -> DynFlags -> String -> DynFlag
121 -> [CoreBind] -> [CoreRule] -> IO ()
122 dumpAndLint dump dflags pass_name dump_flag binds rules
123 = do { -- Report result size if required
124 -- This has the side effect of forcing the intermediate to be evaluated
125 ; Err.debugTraceMsg dflags 2 $
126 (text " Result size =" <+> int (coreBindsSize binds))
128 -- Report verbosely, if required
129 ; dump dflags dump_flag pass_name
130 (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
133 ; lintCoreBindings dflags pass_name binds }
135 pp_rules = vcat [ blankLine
136 , ptext (sLit "------ Local rules for imported ids --------")
141 %************************************************************************
143 The CoreToDo type and related types
144 Abstraction of core-to-core passes to run.
146 %************************************************************************
149 data CoreToDo -- These are diff core-to-core passes,
150 -- which may be invoked in any order,
151 -- as many times as you like.
153 = CoreDoSimplify -- The core-to-core simplifier.
156 -- Each run of the simplifier can take a different
157 -- set of simplifier-specific flags.
159 | CoreDoFloatOutwards FloatOutSwitches
164 | CoreDoWorkerWrapper
167 | CoreDoOldStrictness
170 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
171 -- matching this string
172 | CoreDoVectorisation PackageId
173 | CoreDoNothing -- Useful when building up
174 | CoreDoPasses [CoreToDo] -- lists of these things
177 data SimplifierMode -- See comments in SimplMonad
179 { sm_rules :: Bool -- Whether RULES are enabled
180 , sm_inline :: Bool } -- Whether inlining is enabled
183 { sm_num :: Int -- Phase number; counts downward so 0 is last phase
184 , sm_names :: [String] } -- Name(s) of the phase
186 instance Outputable SimplifierMode where
187 ppr (SimplPhase { sm_num = n, sm_names = ss })
188 = int n <+> brackets (text (concat $ intersperse "," ss))
189 ppr (SimplGently { sm_rules = r, sm_inline = i })
190 = ptext (sLit "gentle") <>
191 brackets (pp_flag r (sLit "rules") <> comma <>
192 pp_flag i (sLit "inline"))
194 pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
196 data SimplifierSwitch
197 = MaxSimplifierIterations Int
200 data FloatOutSwitches = FloatOutSwitches {
201 floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
202 floatOutConstants :: Bool -- ^ True <=> float constants to top level,
203 -- even if they do not escape a lambda
206 instance Outputable FloatOutSwitches where
207 ppr = pprFloatOutSwitches
209 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
210 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
211 <+> pp_not (floatOutConstants sw) <+> text "constants"
214 pp_not False = text "not"
216 -- | Switches that specify the minimum amount of floating out
217 -- gentleFloatOutSwitches :: FloatOutSwitches
218 -- gentleFloatOutSwitches = FloatOutSwitches False False
220 -- | Switches that do not specify floating out of lambdas, just of constants
221 constantsOnlyFloatOutSwitches :: FloatOutSwitches
222 constantsOnlyFloatOutSwitches = FloatOutSwitches False True
226 %************************************************************************
228 Generating the main optimisation pipeline
230 %************************************************************************
233 getCoreToDo :: DynFlags -> [CoreToDo]
237 opt_level = optLevel dflags
238 phases = simplPhases dflags
239 max_iter = maxSimplIterations dflags
240 strictness = dopt Opt_Strictness dflags
241 full_laziness = dopt Opt_FullLaziness dflags
242 do_specialise = dopt Opt_Specialise dflags
243 do_float_in = dopt Opt_FloatIn dflags
244 cse = dopt Opt_CSE dflags
245 spec_constr = dopt Opt_SpecConstr dflags
246 liberate_case = dopt Opt_LiberateCase dflags
247 rule_check = ruleCheck dflags
248 static_args = dopt Opt_StaticArgumentTransformation dflags
250 maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
252 maybe_strictness_before phase
253 = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
255 simpl_phase phase names iter
257 [ maybe_strictness_before phase,
258 CoreDoSimplify (SimplPhase phase names) [
259 MaxSimplifierIterations iter
261 maybe_rule_check phase
265 = runWhen (dopt Opt_Vectorise dflags)
266 $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
269 -- By default, we have 2 phases before phase 0.
271 -- Want to run with inline phase 2 after the specialiser to give
272 -- maximum chance for fusion to work before we inline build/augment
273 -- in phase 1. This made a difference in 'ansi' where an
274 -- overloaded function wasn't inlined till too late.
276 -- Need phase 1 so that build/augment get
277 -- inlined. I found that spectral/hartel/genfft lost some useful
278 -- strictness in the function sumcode' if augment is not inlined
279 -- before strictness analysis runs
280 simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
281 | phase <- [phases, phases-1 .. 1] ]
284 -- initial simplify: mk specialiser happy: minimum effort please
285 simpl_gently = CoreDoSimplify
286 (SimplGently { sm_rules = True, sm_inline = False })
289 -- Don't inline anything till full laziness has bitten
290 -- In particular, inlining wrappers inhibits floating
291 -- e.g. ...(case f x of ...)...
292 -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
293 -- ==> ...(case x of I# x# -> case fw x# of ...)...
294 -- and now the redex (f x) isn't floatable any more
295 -- Similarly, don't apply any rules until after full
296 -- laziness. Notably, list fusion can prevent floating.
298 NoCaseOfCase, -- Don't do case-of-case transformations.
299 -- This makes full laziness work better
300 MaxSimplifierIterations max_iter
304 if opt_level == 0 then
306 simpl_phase 0 ["final"] max_iter]
307 else {- opt_level >= 1 -} [
309 -- We want to do the static argument transform before full laziness as it
310 -- may expose extra opportunities to float things outwards. However, to fix
311 -- up the output of the transformation we need at do at least one simplify
312 -- after this before anything else
313 runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
315 -- We run vectorisation here for now, but we might also try to run
319 -- initial simplify: mk specialiser happy: minimum effort please
322 -- Specialisation is best done before full laziness
323 -- so that overloaded functions have all their dictionary lambdas manifest
324 runWhen do_specialise CoreDoSpecialising,
326 runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
327 -- Was: gentleFloatOutSwitches
328 -- I have no idea why, but not floating constants to top level is
329 -- very bad in some cases.
330 -- Notably: p_ident in spectral/rewrite
331 -- Changing from "gentle" to "constantsOnly" improved
332 -- rewrite's allocation by 19%, and made 0.0% difference
333 -- to any other nofib benchmark
335 runWhen do_float_in CoreDoFloatInwards,
339 -- Phase 0: allow all Ids to be inlined now
340 -- This gets foldr inlined before strictness analysis
342 -- At least 3 iterations because otherwise we land up with
343 -- huge dead expressions because of an infelicity in the
345 -- let k = BIG in foldr k z xs
346 -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
347 -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
349 simpl_phase 0 ["main"] (max max_iter 3),
351 runWhen strictness (CoreDoPasses [
355 simpl_phase 0 ["post-worker-wrapper"] max_iter
358 runWhen full_laziness
359 (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
360 -- nofib/spectral/hartel/wang doubles in speed if you
361 -- do full laziness late in the day. It only happens
362 -- after fusion and other stuff, so the early pass doesn't
363 -- catch it. For the record, the redex is
364 -- f_el22 (f_el21 r_midblock)
368 -- We want CSE to follow the final full-laziness pass, because it may
369 -- succeed in commoning up things floated out by full laziness.
370 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
372 runWhen do_float_in CoreDoFloatInwards,
376 -- Case-liberation for -O2. This should be after
377 -- strictness analysis and the simplification which follows it.
378 runWhen liberate_case (CoreDoPasses [
380 simpl_phase 0 ["post-liberate-case"] max_iter
381 ]), -- Run the simplifier after LiberateCase to vastly
382 -- reduce the possiblility of shadowing
383 -- Reason: see Note [Shadowing] in SpecConstr.lhs
385 runWhen spec_constr CoreDoSpecConstr,
389 -- Final clean-up simplification:
390 simpl_phase 0 ["final"] max_iter
393 -- The core-to-core pass ordering is derived from the DynFlags:
394 runWhen :: Bool -> CoreToDo -> CoreToDo
395 runWhen True do_this = do_this
396 runWhen False _ = CoreDoNothing
398 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
399 runMaybe (Just x) f = f x
400 runMaybe Nothing _ = CoreDoNothing
402 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
403 dumpSimplPhase dflags mode
404 | Just spec_string <- shouldDumpSimplPhase dflags
405 = match_spec spec_string
407 = dopt Opt_D_verbose_core2core dflags
410 match_spec :: String -> Bool
411 match_spec spec_string
412 = or $ map (and . map match . split ':')
413 $ split ',' spec_string
415 match :: String -> Bool
417 match s = case reads s of
418 [(n,"")] -> phase_num n
421 phase_num :: Int -> Bool
422 phase_num n = case mode of
423 SimplPhase k _ -> n == k
426 phase_name :: String -> Bool
427 phase_name s = case mode of
428 SimplGently {} -> s == "gentle"
429 SimplPhase { sm_names = ss } -> s `elem` ss
433 %************************************************************************
437 %************************************************************************
440 verboseSimplStats :: Bool
441 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
443 zeroSimplCount :: DynFlags -> SimplCount
444 isZeroSimplCount :: SimplCount -> Bool
445 pprSimplCount :: SimplCount -> SDoc
446 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
447 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
452 = VerySimplZero -- These two are used when
453 | VerySimplNonZero -- we are only interested in
457 ticks :: !Int, -- Total ticks
458 details :: !TickCounts, -- How many of each type
461 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
463 log2 :: [Tick] -- Last opt_HistorySize events before that
464 -- Having log1, log2 lets us accumulate the
465 -- recent history reasonably efficiently
468 type TickCounts = FiniteMap Tick Int
470 zeroSimplCount dflags
471 -- This is where we decide whether to do
472 -- the VerySimpl version or the full-stats version
473 | dopt Opt_D_dump_simpl_stats dflags
474 = SimplCount {ticks = 0, details = emptyFM,
475 n_log = 0, log1 = [], log2 = []}
479 isZeroSimplCount VerySimplZero = True
480 isZeroSimplCount (SimplCount { ticks = 0 }) = True
481 isZeroSimplCount _ = False
483 doFreeSimplTick tick sc@SimplCount { details = dts }
484 = sc { details = dts `addTick` tick }
485 doFreeSimplTick _ sc = sc
487 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
488 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
489 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
491 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
493 doSimplTick _ _ = VerySimplNonZero -- The very simple case
496 -- Don't use plusFM_C because that's lazy, and we want to
497 -- be pretty strict here!
498 addTick :: TickCounts -> Tick -> TickCounts
499 addTick fm tick = case lookupFM fm tick of
500 Nothing -> addToFM fm tick 1
501 Just n -> n1 `seq` addToFM fm tick n1
506 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
507 sc2@(SimplCount { ticks = tks2, details = dts2 })
508 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
510 -- A hackish way of getting recent log info
511 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
512 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
515 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
516 plusSimplCount _ _ = VerySimplNonZero
518 pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
519 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
520 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
521 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
523 pprTickCounts (fmToList dts),
524 if verboseSimplStats then
526 ptext (sLit "Log (most recent first)"),
527 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
531 pprTickCounts :: [(Tick,Int)] -> SDoc
532 pprTickCounts [] = empty
533 pprTickCounts ((tick1,n1):ticks)
534 = vcat [int tot_n <+> text (tickString tick1),
535 pprTCDetails real_these,
539 tick1_tag = tickToTag tick1
540 (these, others) = span same_tick ticks
541 real_these = (tick1,n1):these
542 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
543 tot_n = sum [n | (_,n) <- real_these]
545 pprTCDetails :: [(Tick, Int)] -> SDoc
547 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
553 = PreInlineUnconditionally Id
554 | PostInlineUnconditionally Id
557 | RuleFired FastString -- Rule name
560 | EtaExpansion Id -- LHS binder
561 | EtaReduction Id -- Binder on outer lambda
562 | BetaReduction Id -- Lambda binder
565 | CaseOfCase Id -- Bndr on *inner* case
566 | KnownBranch Id -- Case binder
567 | CaseMerge Id -- Binder on outer case
568 | AltMerge Id -- Case binder
569 | CaseElim Id -- Case binder
570 | CaseIdentity Id -- Case binder
571 | FillInCaseDefault Id -- Case binder
574 | SimplifierDone -- Ticked at each iteration of the simplifier
576 instance Outputable Tick where
577 ppr tick = text (tickString tick) <+> pprTickCts tick
579 instance Eq Tick where
580 a == b = case a `cmpTick` b of
584 instance Ord Tick where
587 tickToTag :: Tick -> Int
588 tickToTag (PreInlineUnconditionally _) = 0
589 tickToTag (PostInlineUnconditionally _) = 1
590 tickToTag (UnfoldingDone _) = 2
591 tickToTag (RuleFired _) = 3
592 tickToTag LetFloatFromLet = 4
593 tickToTag (EtaExpansion _) = 5
594 tickToTag (EtaReduction _) = 6
595 tickToTag (BetaReduction _) = 7
596 tickToTag (CaseOfCase _) = 8
597 tickToTag (KnownBranch _) = 9
598 tickToTag (CaseMerge _) = 10
599 tickToTag (CaseElim _) = 11
600 tickToTag (CaseIdentity _) = 12
601 tickToTag (FillInCaseDefault _) = 13
602 tickToTag BottomFound = 14
603 tickToTag SimplifierDone = 16
604 tickToTag (AltMerge _) = 17
606 tickString :: Tick -> String
607 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
608 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
609 tickString (UnfoldingDone _) = "UnfoldingDone"
610 tickString (RuleFired _) = "RuleFired"
611 tickString LetFloatFromLet = "LetFloatFromLet"
612 tickString (EtaExpansion _) = "EtaExpansion"
613 tickString (EtaReduction _) = "EtaReduction"
614 tickString (BetaReduction _) = "BetaReduction"
615 tickString (CaseOfCase _) = "CaseOfCase"
616 tickString (KnownBranch _) = "KnownBranch"
617 tickString (CaseMerge _) = "CaseMerge"
618 tickString (AltMerge _) = "AltMerge"
619 tickString (CaseElim _) = "CaseElim"
620 tickString (CaseIdentity _) = "CaseIdentity"
621 tickString (FillInCaseDefault _) = "FillInCaseDefault"
622 tickString BottomFound = "BottomFound"
623 tickString SimplifierDone = "SimplifierDone"
625 pprTickCts :: Tick -> SDoc
626 pprTickCts (PreInlineUnconditionally v) = ppr v
627 pprTickCts (PostInlineUnconditionally v)= ppr v
628 pprTickCts (UnfoldingDone v) = ppr v
629 pprTickCts (RuleFired v) = ppr v
630 pprTickCts LetFloatFromLet = empty
631 pprTickCts (EtaExpansion v) = ppr v
632 pprTickCts (EtaReduction v) = ppr v
633 pprTickCts (BetaReduction v) = ppr v
634 pprTickCts (CaseOfCase v) = ppr v
635 pprTickCts (KnownBranch v) = ppr v
636 pprTickCts (CaseMerge v) = ppr v
637 pprTickCts (AltMerge v) = ppr v
638 pprTickCts (CaseElim v) = ppr v
639 pprTickCts (CaseIdentity v) = ppr v
640 pprTickCts (FillInCaseDefault v) = ppr v
643 cmpTick :: Tick -> Tick -> Ordering
644 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
649 cmpEqTick :: Tick -> Tick -> Ordering
650 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
651 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
652 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
653 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
654 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
655 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
656 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
657 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
658 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
659 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
660 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
661 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
662 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
663 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
668 %************************************************************************
670 Monad and carried data structure definitions
672 %************************************************************************
675 newtype CoreState = CoreState {
676 cs_uniq_supply :: UniqSupply
679 data CoreReader = CoreReader {
680 cr_hsc_env :: HscEnv,
681 cr_rule_base :: RuleBase,
685 data CoreWriter = CoreWriter {
686 cw_simpl_count :: SimplCount
689 emptyWriter :: DynFlags -> CoreWriter
690 emptyWriter dflags = CoreWriter {
691 cw_simpl_count = zeroSimplCount dflags
694 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
695 plusWriter w1 w2 = CoreWriter {
696 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
699 type CoreIOEnv = IOEnv CoreReader
701 -- | The monad used by Core-to-Core passes to access common state, register simplification
702 -- statistics and so on
703 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
705 instance Functor CoreM where
710 instance Monad CoreM where
711 return x = CoreM (\s -> nop s x)
712 mx >>= f = CoreM $ \s -> do
713 (x, s', w1) <- unCoreM mx s
714 (y, s'', w2) <- unCoreM (f x) s'
715 return (y, s'', w1 `plusWriter` w2)
717 instance Applicative CoreM where
721 -- For use if the user has imported Control.Monad.Error from MTL
722 -- Requires UndecidableInstances
723 instance MonadPlus IO => MonadPlus CoreM where
724 mzero = CoreM (const mzero)
725 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
727 instance MonadUnique CoreM where
728 getUniqueSupplyM = do
729 us <- getS cs_uniq_supply
730 let (us1, us2) = splitUniqSupply us
731 modifyS (\s -> s { cs_uniq_supply = us2 })
739 -> IO (a, SimplCount)
740 runCoreM hsc_env rule_base us mod m =
741 liftM extract $ runIOEnv reader $ unCoreM m state
743 reader = CoreReader {
744 cr_hsc_env = hsc_env,
745 cr_rule_base = rule_base,
752 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
753 extract (value, _, writer) = (value, cw_simpl_count writer)
758 %************************************************************************
760 Core combinators, not exported
762 %************************************************************************
766 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
769 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
771 read :: (CoreReader -> a) -> CoreM a
772 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
774 getS :: (CoreState -> a) -> CoreM a
775 getS f = CoreM (\s -> nop s (f s))
777 modifyS :: (CoreState -> CoreState) -> CoreM ()
778 modifyS f = CoreM (\s -> nop (f s) ())
780 write :: CoreWriter -> CoreM ()
781 write w = CoreM (\s -> return ((), s, w))
785 \subsection{Lifting IO into the monad}
789 -- | Lift an 'IOEnv' operation into 'CoreM'
790 liftIOEnv :: CoreIOEnv a -> CoreM a
791 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
793 instance MonadIO CoreM where
794 liftIO = liftIOEnv . IOEnv.liftIO
796 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
797 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
798 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
803 %************************************************************************
805 Reader, writer and state accessors
807 %************************************************************************
811 getHscEnv :: CoreM HscEnv
812 getHscEnv = read cr_hsc_env
814 getRuleBase :: CoreM RuleBase
815 getRuleBase = read cr_rule_base
817 getModule :: CoreM Module
818 getModule = read cr_module
820 addSimplCount :: SimplCount -> CoreM ()
821 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
823 -- Convenience accessors for useful fields of HscEnv
825 getDynFlags :: CoreM DynFlags
826 getDynFlags = fmap hsc_dflags getHscEnv
828 -- | The original name cache is the current mapping from 'Module' and
829 -- 'OccName' to a compiler-wide unique 'Name'
830 getOrigNameCache :: CoreM OrigNameCache
831 getOrigNameCache = do
832 nameCacheRef <- fmap hsc_NC getHscEnv
833 liftIO $ fmap nsNames $ readIORef nameCacheRef
838 %************************************************************************
840 Dealing with annotations
842 %************************************************************************
845 -- | Get all annotations of a given type. This happens lazily, that is
846 -- no deserialization will take place until the [a] is actually demanded and
847 -- the [a] can also be empty (the UniqFM is not filtered).
849 -- This should be done once at the start of a Core-to-Core pass that uses
852 -- See Note [Annotations]
853 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
854 getAnnotations deserialize guts = do
856 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
857 return (deserializeAnns deserialize ann_env)
859 -- | Get at most one annotation of a given type per Unique.
860 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
861 getFirstAnnotations deserialize guts
862 = liftM (mapUFM head . filterUFM (not . null))
863 $ getAnnotations deserialize guts
869 A Core-to-Core pass that wants to make use of annotations calls
870 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
871 annotations of a specific type. This produces all annotations from interface
872 files read so far. However, annotations from interface files read during the
873 pass will not be visible until getAnnotations is called again. This is similar
874 to how rules work and probably isn't too bad.
876 The current implementation could be optimised a bit: when looking up
877 annotations for a thing from the HomePackageTable, we could search directly in
878 the module where the thing is defined rather than building one UniqFM which
879 contains all annotations we know of. This would work because annotations can
880 only be given to things defined in the same module. However, since we would
881 only want to deserialise every annotation once, we would have to build a cache
882 for every module in the HTP. In the end, it's probably not worth it as long as
883 we aren't using annotations heavily.
885 %************************************************************************
889 %************************************************************************
893 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
895 dflags <- getDynFlags
896 liftIO $ how dflags doc
898 -- | Output a String message to the screen
899 putMsgS :: String -> CoreM ()
900 putMsgS = putMsg . text
902 -- | Output a message to the screen
903 putMsg :: SDoc -> CoreM ()
904 putMsg = msg Err.putMsg
906 -- | Output a string error to the screen
907 errorMsgS :: String -> CoreM ()
908 errorMsgS = errorMsg . text
910 -- | Output an error to the screen
911 errorMsg :: SDoc -> CoreM ()
912 errorMsg = msg Err.errorMsg
914 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
915 fatalErrorMsgS :: String -> CoreM ()
916 fatalErrorMsgS = fatalErrorMsg . text
918 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
919 fatalErrorMsg :: SDoc -> CoreM ()
920 fatalErrorMsg = msg Err.fatalErrorMsg
922 -- | Output a string debugging message at verbosity level of @-v@ or higher
923 debugTraceMsgS :: String -> CoreM ()
924 debugTraceMsgS = debugTraceMsg . text
926 -- | Outputs a debugging message at verbosity level of @-v@ or higher
927 debugTraceMsg :: SDoc -> CoreM ()
928 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
930 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
931 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
932 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
937 initTcForLookup :: HscEnv -> TcM a -> IO a
938 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
943 %************************************************************************
947 %************************************************************************
950 instance MonadThings CoreM where
951 lookupThing name = do
953 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
956 %************************************************************************
958 Template Haskell interoperability
960 %************************************************************************
964 -- | Attempt to convert a Template Haskell name to one that GHC can
965 -- understand. Original TH names such as those you get when you use
966 -- the @'foo@ syntax will be translated to their equivalent GHC name
967 -- exactly. Qualified or unqualifed TH names will be dynamically bound
968 -- to names in the module being compiled, if possible. Exact TH names
969 -- will be bound to the name they represent, exactly.
970 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
971 thNameToGhcName th_name = do
973 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)