Implement a dedicated exitfication pass #14152
[ghc.git] / compiler / simplCore / CoreMonad.hs
1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
3
4 \section[CoreMonad]{The core pipeline monad}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module CoreMonad (
10 -- * Configuration of the core-to-core passes
11 CoreToDo(..), runWhen, runMaybe,
12 SimplMode(..),
13 FloatOutSwitches(..),
14 pprPassDetails,
15
16 -- * Plugins
17 PluginPass, bindsOnlyPass,
18
19 -- * Counting
20 SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
21 pprSimplCount, plusSimplCount, zeroSimplCount,
22 isZeroSimplCount, hasDetailedCounts, Tick(..),
23
24 -- * The monad
25 CoreM, runCoreM,
26
27 -- ** Reading from the monad
28 getHscEnv, getRuleBase, getModule,
29 getDynFlags, getOrigNameCache, getPackageFamInstEnv,
30 getVisibleOrphanMods,
31 getPrintUnqualified, getSrcSpanM,
32
33 -- ** Writing to the monad
34 addSimplCount,
35
36 -- ** Lifting into the monad
37 liftIO, liftIOWithCount,
38 liftIO1, liftIO2, liftIO3, liftIO4,
39
40 -- ** Global initialization
41 reinitializeGlobals,
42
43 -- ** Dealing with annotations
44 getAnnotations, getFirstAnnotations,
45
46 -- ** Screen output
47 putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
48 fatalErrorMsg, fatalErrorMsgS,
49 debugTraceMsg, debugTraceMsgS,
50 dumpIfSet_dyn,
51
52 -- * Getting 'Name's
53 thNameToGhcName
54 ) where
55
56 import GhcPrelude hiding ( read )
57
58 import Name( Name )
59 import TcRnMonad ( initTcForLookup )
60 import CoreSyn
61 import HscTypes
62 import Module
63 import DynFlags
64 import BasicTypes ( CompilerPhase(..) )
65 import Annotations
66
67 import IOEnv hiding ( liftIO, failM, failWithM )
68 import qualified IOEnv ( liftIO )
69 import TcEnv ( lookupGlobal )
70 import Var
71 import Outputable
72 import FastString
73 import qualified ErrUtils as Err
74 import ErrUtils( Severity(..) )
75 import UniqSupply
76 import UniqFM ( UniqFM, mapUFM, filterUFM )
77 import MonadUtils
78 import NameCache
79 import SrcLoc
80 import Data.List
81 import Data.Ord
82 import Data.Dynamic
83 import Data.IORef
84 import Data.Map (Map)
85 import qualified Data.Map as Map
86 import qualified Data.Map.Strict as MapStrict
87 import Data.Word
88 import Control.Monad
89 import Control.Applicative ( Alternative(..) )
90
91 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
92 import qualified Language.Haskell.TH as TH
93
94 {-
95 ************************************************************************
96 * *
97 The CoreToDo type and related types
98 Abstraction of core-to-core passes to run.
99 * *
100 ************************************************************************
101 -}
102
103 data CoreToDo -- These are diff core-to-core passes,
104 -- which may be invoked in any order,
105 -- as many times as you like.
106
107 = CoreDoSimplify -- The core-to-core simplifier.
108 Int -- Max iterations
109 SimplMode
110 | CoreDoPluginPass String PluginPass
111 | CoreDoFloatInwards
112 | CoreDoFloatOutwards FloatOutSwitches
113 | CoreLiberateCase
114 | CoreDoPrintCore
115 | CoreDoStaticArgs
116 | CoreDoCallArity
117 | CoreDoExitify
118 | CoreDoStrictness
119 | CoreDoWorkerWrapper
120 | CoreDoSpecialising
121 | CoreDoSpecConstr
122 | CoreCSE
123 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
124 -- matching this string
125 | CoreDoVectorisation
126 | CoreDoNothing -- Useful when building up
127 | CoreDoPasses [CoreToDo] -- lists of these things
128
129 | CoreDesugar -- Right after desugaring, no simple optimisation yet!
130 | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
131 -- Core output, and hence useful to pass to endPass
132
133 | CoreTidy
134 | CorePrep
135 | CoreOccurAnal
136
137 instance Outputable CoreToDo where
138 ppr (CoreDoSimplify _ _) = text "Simplifier"
139 ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s
140 ppr CoreDoFloatInwards = text "Float inwards"
141 ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f)
142 ppr CoreLiberateCase = text "Liberate case"
143 ppr CoreDoStaticArgs = text "Static argument"
144 ppr CoreDoCallArity = text "Called arity analysis"
145 ppr CoreDoExitify = text "Exitification transformation"
146 ppr CoreDoStrictness = text "Demand analysis"
147 ppr CoreDoWorkerWrapper = text "Worker Wrapper binds"
148 ppr CoreDoSpecialising = text "Specialise"
149 ppr CoreDoSpecConstr = text "SpecConstr"
150 ppr CoreCSE = text "Common sub-expression"
151 ppr CoreDoVectorisation = text "Vectorisation"
152 ppr CoreDesugar = text "Desugar (before optimization)"
153 ppr CoreDesugarOpt = text "Desugar (after optimization)"
154 ppr CoreTidy = text "Tidy Core"
155 ppr CorePrep = text "CorePrep"
156 ppr CoreOccurAnal = text "Occurrence analysis"
157 ppr CoreDoPrintCore = text "Print core"
158 ppr (CoreDoRuleCheck {}) = text "Rule check"
159 ppr CoreDoNothing = text "CoreDoNothing"
160 ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes
161
162 pprPassDetails :: CoreToDo -> SDoc
163 pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n
164 , ppr md ]
165 pprPassDetails _ = Outputable.empty
166
167 data SimplMode -- See comments in SimplMonad
168 = SimplMode
169 { sm_names :: [String] -- Name(s) of the phase
170 , sm_phase :: CompilerPhase
171 , sm_dflags :: DynFlags -- Just for convenient non-monadic
172 -- access; we don't override these
173 , sm_rules :: Bool -- Whether RULES are enabled
174 , sm_inline :: Bool -- Whether inlining is enabled
175 , sm_case_case :: Bool -- Whether case-of-case is enabled
176 , sm_eta_expand :: Bool -- Whether eta-expansion is enabled
177 }
178
179 instance Outputable SimplMode where
180 ppr (SimplMode { sm_phase = p, sm_names = ss
181 , sm_rules = r, sm_inline = i
182 , sm_eta_expand = eta, sm_case_case = cc })
183 = text "SimplMode" <+> braces (
184 sep [ text "Phase =" <+> ppr p <+>
185 brackets (text (concat $ intersperse "," ss)) <> comma
186 , pp_flag i (sLit "inline") <> comma
187 , pp_flag r (sLit "rules") <> comma
188 , pp_flag eta (sLit "eta-expand") <> comma
189 , pp_flag cc (sLit "case-of-case") ])
190 where
191 pp_flag f s = ppUnless f (text "no") <+> ptext s
192
193 data FloatOutSwitches = FloatOutSwitches {
194 floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if
195 -- doing so will abstract over n or fewer
196 -- value variables
197 -- Nothing <=> float all lambdas to top level,
198 -- regardless of how many free variables
199 -- Just 0 is the vanilla case: float a lambda
200 -- iff it has no free vars
201
202 floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
203 -- even if they do not escape a lambda
204 floatOutOverSatApps :: Bool,
205 -- ^ True <=> float out over-saturated applications
206 -- based on arity information.
207 -- See Note [Floating over-saturated applications]
208 -- in SetLevels
209 floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only.
210 }
211 instance Outputable FloatOutSwitches where
212 ppr = pprFloatOutSwitches
213
214 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
215 pprFloatOutSwitches sw
216 = text "FOS" <+> (braces $
217 sep $ punctuate comma $
218 [ text "Lam =" <+> ppr (floatOutLambdas sw)
219 , text "Consts =" <+> ppr (floatOutConstants sw)
220 , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ])
221
222 -- The core-to-core pass ordering is derived from the DynFlags:
223 runWhen :: Bool -> CoreToDo -> CoreToDo
224 runWhen True do_this = do_this
225 runWhen False _ = CoreDoNothing
226
227 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
228 runMaybe (Just x) f = f x
229 runMaybe Nothing _ = CoreDoNothing
230
231 {-
232
233 ************************************************************************
234 * *
235 Types for Plugins
236 * *
237 ************************************************************************
238 -}
239
240 -- | A description of the plugin pass itself
241 type PluginPass = ModGuts -> CoreM ModGuts
242
243 bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
244 bindsOnlyPass pass guts
245 = do { binds' <- pass (mg_binds guts)
246 ; return (guts { mg_binds = binds' }) }
247
248 {-
249 ************************************************************************
250 * *
251 Counting and logging
252 * *
253 ************************************************************************
254 -}
255
256 getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
257 getVerboseSimplStats = getPprDebug -- For now, anyway
258
259 zeroSimplCount :: DynFlags -> SimplCount
260 isZeroSimplCount :: SimplCount -> Bool
261 hasDetailedCounts :: SimplCount -> Bool
262 pprSimplCount :: SimplCount -> SDoc
263 doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount
264 doFreeSimplTick :: Tick -> SimplCount -> SimplCount
265 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
266
267 data SimplCount
268 = VerySimplCount !Int -- Used when don't want detailed stats
269
270 | SimplCount {
271 ticks :: !Int, -- Total ticks
272 details :: !TickCounts, -- How many of each type
273
274 n_log :: !Int, -- N
275 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
276 -- most recent first
277 log2 :: [Tick] -- Last opt_HistorySize events before that
278 -- Having log1, log2 lets us accumulate the
279 -- recent history reasonably efficiently
280 }
281
282 type TickCounts = Map Tick Int
283
284 simplCountN :: SimplCount -> Int
285 simplCountN (VerySimplCount n) = n
286 simplCountN (SimplCount { ticks = n }) = n
287
288 zeroSimplCount dflags
289 -- This is where we decide whether to do
290 -- the VerySimpl version or the full-stats version
291 | dopt Opt_D_dump_simpl_stats dflags
292 = SimplCount {ticks = 0, details = Map.empty,
293 n_log = 0, log1 = [], log2 = []}
294 | otherwise
295 = VerySimplCount 0
296
297 isZeroSimplCount (VerySimplCount n) = n==0
298 isZeroSimplCount (SimplCount { ticks = n }) = n==0
299
300 hasDetailedCounts (VerySimplCount {}) = False
301 hasDetailedCounts (SimplCount {}) = True
302
303 doFreeSimplTick tick sc@SimplCount { details = dts }
304 = sc { details = dts `addTick` tick }
305 doFreeSimplTick _ sc = sc
306
307 doSimplTick dflags tick
308 sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })
309 | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
310 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
311 where
312 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
313
314 doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
315
316
317 addTick :: TickCounts -> Tick -> TickCounts
318 addTick fm tick = MapStrict.insertWith (+) tick 1 fm
319
320 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
321 sc2@(SimplCount { ticks = tks2, details = dts2 })
322 = log_base { ticks = tks1 + tks2
323 , details = MapStrict.unionWith (+) dts1 dts2 }
324 where
325 -- A hackish way of getting recent log info
326 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
327 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
328 | otherwise = sc2
329
330 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
331 plusSimplCount _ _ = panic "plusSimplCount"
332 -- We use one or the other consistently
333
334 pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n
335 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
336 = vcat [text "Total ticks: " <+> int tks,
337 blankLine,
338 pprTickCounts dts,
339 getVerboseSimplStats $ \dbg -> if dbg
340 then
341 vcat [blankLine,
342 text "Log (most recent first)",
343 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
344 else Outputable.empty
345 ]
346
347 pprTickCounts :: Map Tick Int -> SDoc
348 pprTickCounts counts
349 = vcat (map pprTickGroup groups)
350 where
351 groups :: [[(Tick,Int)]] -- Each group shares a comon tag
352 -- toList returns common tags adjacent
353 groups = groupBy same_tag (Map.toList counts)
354 same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
355
356 pprTickGroup :: [(Tick, Int)] -> SDoc
357 pprTickGroup group@((tick1,_):_)
358 = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
359 2 (vcat [ int n <+> pprTickCts tick
360 -- flip as we want largest first
361 | (tick,n) <- sortBy (flip (comparing snd)) group])
362 pprTickGroup [] = panic "pprTickGroup"
363
364 data Tick
365 = PreInlineUnconditionally Id
366 | PostInlineUnconditionally Id
367
368 | UnfoldingDone Id
369 | RuleFired FastString -- Rule name
370
371 | LetFloatFromLet
372 | EtaExpansion Id -- LHS binder
373 | EtaReduction Id -- Binder on outer lambda
374 | BetaReduction Id -- Lambda binder
375
376
377 | CaseOfCase Id -- Bndr on *inner* case
378 | KnownBranch Id -- Case binder
379 | CaseMerge Id -- Binder on outer case
380 | AltMerge Id -- Case binder
381 | CaseElim Id -- Case binder
382 | CaseIdentity Id -- Case binder
383 | FillInCaseDefault Id -- Case binder
384
385 | BottomFound
386 | SimplifierDone -- Ticked at each iteration of the simplifier
387
388 instance Outputable Tick where
389 ppr tick = text (tickString tick) <+> pprTickCts tick
390
391 instance Eq Tick where
392 a == b = case a `cmpTick` b of
393 EQ -> True
394 _ -> False
395
396 instance Ord Tick where
397 compare = cmpTick
398
399 tickToTag :: Tick -> Int
400 tickToTag (PreInlineUnconditionally _) = 0
401 tickToTag (PostInlineUnconditionally _) = 1
402 tickToTag (UnfoldingDone _) = 2
403 tickToTag (RuleFired _) = 3
404 tickToTag LetFloatFromLet = 4
405 tickToTag (EtaExpansion _) = 5
406 tickToTag (EtaReduction _) = 6
407 tickToTag (BetaReduction _) = 7
408 tickToTag (CaseOfCase _) = 8
409 tickToTag (KnownBranch _) = 9
410 tickToTag (CaseMerge _) = 10
411 tickToTag (CaseElim _) = 11
412 tickToTag (CaseIdentity _) = 12
413 tickToTag (FillInCaseDefault _) = 13
414 tickToTag BottomFound = 14
415 tickToTag SimplifierDone = 16
416 tickToTag (AltMerge _) = 17
417
418 tickString :: Tick -> String
419 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
420 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
421 tickString (UnfoldingDone _) = "UnfoldingDone"
422 tickString (RuleFired _) = "RuleFired"
423 tickString LetFloatFromLet = "LetFloatFromLet"
424 tickString (EtaExpansion _) = "EtaExpansion"
425 tickString (EtaReduction _) = "EtaReduction"
426 tickString (BetaReduction _) = "BetaReduction"
427 tickString (CaseOfCase _) = "CaseOfCase"
428 tickString (KnownBranch _) = "KnownBranch"
429 tickString (CaseMerge _) = "CaseMerge"
430 tickString (AltMerge _) = "AltMerge"
431 tickString (CaseElim _) = "CaseElim"
432 tickString (CaseIdentity _) = "CaseIdentity"
433 tickString (FillInCaseDefault _) = "FillInCaseDefault"
434 tickString BottomFound = "BottomFound"
435 tickString SimplifierDone = "SimplifierDone"
436
437 pprTickCts :: Tick -> SDoc
438 pprTickCts (PreInlineUnconditionally v) = ppr v
439 pprTickCts (PostInlineUnconditionally v)= ppr v
440 pprTickCts (UnfoldingDone v) = ppr v
441 pprTickCts (RuleFired v) = ppr v
442 pprTickCts LetFloatFromLet = Outputable.empty
443 pprTickCts (EtaExpansion v) = ppr v
444 pprTickCts (EtaReduction v) = ppr v
445 pprTickCts (BetaReduction v) = ppr v
446 pprTickCts (CaseOfCase v) = ppr v
447 pprTickCts (KnownBranch v) = ppr v
448 pprTickCts (CaseMerge v) = ppr v
449 pprTickCts (AltMerge v) = ppr v
450 pprTickCts (CaseElim v) = ppr v
451 pprTickCts (CaseIdentity v) = ppr v
452 pprTickCts (FillInCaseDefault v) = ppr v
453 pprTickCts _ = Outputable.empty
454
455 cmpTick :: Tick -> Tick -> Ordering
456 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
457 GT -> GT
458 EQ -> cmpEqTick a b
459 LT -> LT
460
461 cmpEqTick :: Tick -> Tick -> Ordering
462 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
463 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
464 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
465 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
466 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
467 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
468 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
469 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
470 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
471 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
472 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
473 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
474 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
475 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
476 cmpEqTick _ _ = EQ
477
478 {-
479 ************************************************************************
480 * *
481 Monad and carried data structure definitions
482 * *
483 ************************************************************************
484 -}
485
486 newtype CoreState = CoreState {
487 cs_uniq_supply :: UniqSupply
488 }
489
490 data CoreReader = CoreReader {
491 cr_hsc_env :: HscEnv,
492 cr_rule_base :: RuleBase,
493 cr_module :: Module,
494 cr_print_unqual :: PrintUnqualified,
495 cr_loc :: SrcSpan, -- Use this for log/error messages so they
496 -- are at least tagged with the right source file
497 cr_visible_orphan_mods :: !ModuleSet
498 }
499
500 -- Note: CoreWriter used to be defined with data, rather than newtype. If it
501 -- is defined that way again, the cw_simpl_count field, at least, must be
502 -- strict to avoid a space leak (Trac #7702).
503 newtype CoreWriter = CoreWriter {
504 cw_simpl_count :: SimplCount
505 }
506
507 emptyWriter :: DynFlags -> CoreWriter
508 emptyWriter dflags = CoreWriter {
509 cw_simpl_count = zeroSimplCount dflags
510 }
511
512 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
513 plusWriter w1 w2 = CoreWriter {
514 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
515 }
516
517 type CoreIOEnv = IOEnv CoreReader
518
519 -- | The monad used by Core-to-Core passes to access common state, register simplification
520 -- statistics and so on
521 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
522
523 instance Functor CoreM where
524 fmap = liftM
525
526 instance Monad CoreM where
527 mx >>= f = CoreM $ \s -> do
528 (x, s', w1) <- unCoreM mx s
529 (y, s'', w2) <- unCoreM (f x) s'
530 let w = w1 `plusWriter` w2
531 return $ seq w (y, s'', w)
532 -- forcing w before building the tuple avoids a space leak
533 -- (Trac #7702)
534
535 instance Applicative CoreM where
536 pure x = CoreM $ \s -> nop s x
537 (<*>) = ap
538 m *> k = m >>= \_ -> k
539
540 instance Alternative CoreM where
541 empty = CoreM (const Control.Applicative.empty)
542 m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs)
543
544 instance MonadPlus CoreM
545
546 instance MonadUnique CoreM where
547 getUniqueSupplyM = do
548 us <- getS cs_uniq_supply
549 let (us1, us2) = splitUniqSupply us
550 modifyS (\s -> s { cs_uniq_supply = us2 })
551 return us1
552
553 getUniqueM = do
554 us <- getS cs_uniq_supply
555 let (u,us') = takeUniqFromSupply us
556 modifyS (\s -> s { cs_uniq_supply = us' })
557 return u
558
559 runCoreM :: HscEnv
560 -> RuleBase
561 -> UniqSupply
562 -> Module
563 -> ModuleSet
564 -> PrintUnqualified
565 -> SrcSpan
566 -> CoreM a
567 -> IO (a, SimplCount)
568 runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
569 = liftM extract $ runIOEnv reader $ unCoreM m state
570 where
571 reader = CoreReader {
572 cr_hsc_env = hsc_env,
573 cr_rule_base = rule_base,
574 cr_module = mod,
575 cr_visible_orphan_mods = orph_imps,
576 cr_print_unqual = print_unqual,
577 cr_loc = loc
578 }
579 state = CoreState {
580 cs_uniq_supply = us
581 }
582
583 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
584 extract (value, _, writer) = (value, cw_simpl_count writer)
585
586 {-
587 ************************************************************************
588 * *
589 Core combinators, not exported
590 * *
591 ************************************************************************
592 -}
593
594 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
595 nop s x = do
596 r <- getEnv
597 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
598
599 read :: (CoreReader -> a) -> CoreM a
600 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
601
602 getS :: (CoreState -> a) -> CoreM a
603 getS f = CoreM (\s -> nop s (f s))
604
605 modifyS :: (CoreState -> CoreState) -> CoreM ()
606 modifyS f = CoreM (\s -> nop (f s) ())
607
608 write :: CoreWriter -> CoreM ()
609 write w = CoreM (\s -> return ((), s, w))
610
611 -- \subsection{Lifting IO into the monad}
612
613 -- | Lift an 'IOEnv' operation into 'CoreM'
614 liftIOEnv :: CoreIOEnv a -> CoreM a
615 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
616
617 instance MonadIO CoreM where
618 liftIO = liftIOEnv . IOEnv.liftIO
619
620 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
621 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
622 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
623
624 {-
625 ************************************************************************
626 * *
627 Reader, writer and state accessors
628 * *
629 ************************************************************************
630 -}
631
632 getHscEnv :: CoreM HscEnv
633 getHscEnv = read cr_hsc_env
634
635 getRuleBase :: CoreM RuleBase
636 getRuleBase = read cr_rule_base
637
638 getVisibleOrphanMods :: CoreM ModuleSet
639 getVisibleOrphanMods = read cr_visible_orphan_mods
640
641 getPrintUnqualified :: CoreM PrintUnqualified
642 getPrintUnqualified = read cr_print_unqual
643
644 getSrcSpanM :: CoreM SrcSpan
645 getSrcSpanM = read cr_loc
646
647 addSimplCount :: SimplCount -> CoreM ()
648 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
649
650 -- Convenience accessors for useful fields of HscEnv
651
652 instance HasDynFlags CoreM where
653 getDynFlags = fmap hsc_dflags getHscEnv
654
655 instance HasModule CoreM where
656 getModule = read cr_module
657
658 -- | The original name cache is the current mapping from 'Module' and
659 -- 'OccName' to a compiler-wide unique 'Name'
660 getOrigNameCache :: CoreM OrigNameCache
661 getOrigNameCache = do
662 nameCacheRef <- fmap hsc_NC getHscEnv
663 liftIO $ fmap nsNames $ readIORef nameCacheRef
664
665 getPackageFamInstEnv :: CoreM PackageFamInstEnv
666 getPackageFamInstEnv = do
667 hsc_env <- getHscEnv
668 eps <- liftIO $ hscEPS hsc_env
669 return $ eps_fam_inst_env eps
670
671 {-# DEPRECATED reinitializeGlobals "It is not necessary to call reinitializeGlobals. Since GHC 8.2, this function is a no-op and will be removed in GHC 8.4" #-}
672 reinitializeGlobals :: CoreM ()
673 reinitializeGlobals = return ()
674
675 {-
676 ************************************************************************
677 * *
678 Dealing with annotations
679 * *
680 ************************************************************************
681 -}
682
683 -- | Get all annotations of a given type. This happens lazily, that is
684 -- no deserialization will take place until the [a] is actually demanded and
685 -- the [a] can also be empty (the UniqFM is not filtered).
686 --
687 -- This should be done once at the start of a Core-to-Core pass that uses
688 -- annotations.
689 --
690 -- See Note [Annotations]
691 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
692 getAnnotations deserialize guts = do
693 hsc_env <- getHscEnv
694 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
695 return (deserializeAnns deserialize ann_env)
696
697 -- | Get at most one annotation of a given type per Unique.
698 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
699 getFirstAnnotations deserialize guts
700 = liftM (mapUFM head . filterUFM (not . null))
701 $ getAnnotations deserialize guts
702
703 {-
704 Note [Annotations]
705 ~~~~~~~~~~~~~~~~~~
706 A Core-to-Core pass that wants to make use of annotations calls
707 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
708 annotations of a specific type. This produces all annotations from interface
709 files read so far. However, annotations from interface files read during the
710 pass will not be visible until getAnnotations is called again. This is similar
711 to how rules work and probably isn't too bad.
712
713 The current implementation could be optimised a bit: when looking up
714 annotations for a thing from the HomePackageTable, we could search directly in
715 the module where the thing is defined rather than building one UniqFM which
716 contains all annotations we know of. This would work because annotations can
717 only be given to things defined in the same module. However, since we would
718 only want to deserialise every annotation once, we would have to build a cache
719 for every module in the HTP. In the end, it's probably not worth it as long as
720 we aren't using annotations heavily.
721
722 ************************************************************************
723 * *
724 Direct screen output
725 * *
726 ************************************************************************
727 -}
728
729 msg :: Severity -> SDoc -> CoreM ()
730 msg sev doc
731 = do { dflags <- getDynFlags
732 ; loc <- getSrcSpanM
733 ; unqual <- getPrintUnqualified
734 ; let sty = case sev of
735 SevError -> err_sty
736 SevWarning -> err_sty
737 SevDump -> dump_sty
738 _ -> user_sty
739 err_sty = mkErrStyle dflags unqual
740 user_sty = mkUserStyle dflags unqual AllTheWay
741 dump_sty = mkDumpStyle dflags unqual
742 ; liftIO $ putLogMsg dflags NoReason sev loc sty doc }
743
744 -- | Output a String message to the screen
745 putMsgS :: String -> CoreM ()
746 putMsgS = putMsg . text
747
748 -- | Output a message to the screen
749 putMsg :: SDoc -> CoreM ()
750 putMsg = msg SevInfo
751
752 -- | Output an error to the screen. Does not cause the compiler to die.
753 errorMsgS :: String -> CoreM ()
754 errorMsgS = errorMsg . text
755
756 -- | Output an error to the screen. Does not cause the compiler to die.
757 errorMsg :: SDoc -> CoreM ()
758 errorMsg = msg SevError
759
760 warnMsg :: SDoc -> CoreM ()
761 warnMsg = msg SevWarning
762
763 -- | Output a fatal error to the screen. Does not cause the compiler to die.
764 fatalErrorMsgS :: String -> CoreM ()
765 fatalErrorMsgS = fatalErrorMsg . text
766
767 -- | Output a fatal error to the screen. Does not cause the compiler to die.
768 fatalErrorMsg :: SDoc -> CoreM ()
769 fatalErrorMsg = msg SevFatal
770
771 -- | Output a string debugging message at verbosity level of @-v@ or higher
772 debugTraceMsgS :: String -> CoreM ()
773 debugTraceMsgS = debugTraceMsg . text
774
775 -- | Outputs a debugging message at verbosity level of @-v@ or higher
776 debugTraceMsg :: SDoc -> CoreM ()
777 debugTraceMsg = msg SevDump
778
779 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
780 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
781 dumpIfSet_dyn flag str doc
782 = do { dflags <- getDynFlags
783 ; unqual <- getPrintUnqualified
784 ; when (dopt flag dflags) $ liftIO $
785 Err.dumpSDoc dflags unqual flag str doc }
786
787 {-
788 ************************************************************************
789 * *
790 Finding TyThings
791 * *
792 ************************************************************************
793 -}
794
795 instance MonadThings CoreM where
796 lookupThing name = do { hsc_env <- getHscEnv
797 ; liftIO $ lookupGlobal hsc_env name }
798
799 {-
800 ************************************************************************
801 * *
802 Template Haskell interoperability
803 * *
804 ************************************************************************
805 -}
806
807 -- | Attempt to convert a Template Haskell name to one that GHC can
808 -- understand. Original TH names such as those you get when you use
809 -- the @'foo@ syntax will be translated to their equivalent GHC name
810 -- exactly. Qualified or unqualified TH names will be dynamically bound
811 -- to names in the module being compiled, if possible. Exact TH names
812 -- will be bound to the name they represent, exactly.
813 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
814 thNameToGhcName th_name = do
815 hsc_env <- getHscEnv
816 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)