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