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