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