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