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