ac3e2c4fb99757215ad3afba0fb8aa18b6452d6d
[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 ListSetOps ( runs )
80 import Data.List
81 import Data.Ord
82 import Data.Dynamic
83 import Data.IORef
84 import Data.Map (Map)
85 import qualified Data.Map as Map
86 import qualified Data.Map.Strict as MapStrict
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 getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
255 getVerboseSimplStats = sdocWithPprDebug -- 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 addTick :: TickCounts -> Tick -> TickCounts
316 addTick fm tick = MapStrict.insertWith (+) tick 1 fm
317
318 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
319 sc2@(SimplCount { ticks = tks2, details = dts2 })
320 = log_base { ticks = tks1 + tks2
321 , details = MapStrict.unionWith (+) dts1 dts2 }
322 where
323 -- A hackish way of getting recent log info
324 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
325 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
326 | otherwise = sc2
327
328 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
329 plusSimplCount _ _ = panic "plusSimplCount"
330 -- We use one or the other consistently
331
332 pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n
333 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
334 = vcat [text "Total ticks: " <+> int tks,
335 blankLine,
336 pprTickCounts dts,
337 getVerboseSimplStats $ \dbg -> if dbg
338 then
339 vcat [blankLine,
340 text "Log (most recent first)",
341 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
342 else Outputable.empty
343 ]
344
345 pprTickCounts :: Map Tick Int -> SDoc
346 pprTickCounts counts
347 = vcat (map pprTickGroup groups)
348 where
349 groups :: [[(Tick,Int)]] -- Each group shares a comon tag
350 -- toList returns common tags adjacent
351 groups = runs same_tag (Map.toList counts)
352 same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
353
354 pprTickGroup :: [(Tick, Int)] -> SDoc
355 pprTickGroup group@((tick1,_):_)
356 = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
357 2 (vcat [ int n <+> pprTickCts tick
358 -- flip as we want largest first
359 | (tick,n) <- sortBy (flip (comparing snd)) group])
360 pprTickGroup [] = panic "pprTickGroup"
361
362 data Tick
363 = PreInlineUnconditionally Id
364 | PostInlineUnconditionally Id
365
366 | UnfoldingDone Id
367 | RuleFired FastString -- Rule name
368
369 | LetFloatFromLet
370 | EtaExpansion Id -- LHS binder
371 | EtaReduction Id -- Binder on outer lambda
372 | BetaReduction Id -- Lambda binder
373
374
375 | CaseOfCase Id -- Bndr on *inner* case
376 | KnownBranch Id -- Case binder
377 | CaseMerge Id -- Binder on outer case
378 | AltMerge Id -- Case binder
379 | CaseElim Id -- Case binder
380 | CaseIdentity Id -- Case binder
381 | FillInCaseDefault Id -- Case binder
382
383 | BottomFound
384 | SimplifierDone -- Ticked at each iteration of the simplifier
385
386 instance Outputable Tick where
387 ppr tick = text (tickString tick) <+> pprTickCts tick
388
389 instance Eq Tick where
390 a == b = case a `cmpTick` b of
391 EQ -> True
392 _ -> False
393
394 instance Ord Tick where
395 compare = cmpTick
396
397 tickToTag :: Tick -> Int
398 tickToTag (PreInlineUnconditionally _) = 0
399 tickToTag (PostInlineUnconditionally _) = 1
400 tickToTag (UnfoldingDone _) = 2
401 tickToTag (RuleFired _) = 3
402 tickToTag LetFloatFromLet = 4
403 tickToTag (EtaExpansion _) = 5
404 tickToTag (EtaReduction _) = 6
405 tickToTag (BetaReduction _) = 7
406 tickToTag (CaseOfCase _) = 8
407 tickToTag (KnownBranch _) = 9
408 tickToTag (CaseMerge _) = 10
409 tickToTag (CaseElim _) = 11
410 tickToTag (CaseIdentity _) = 12
411 tickToTag (FillInCaseDefault _) = 13
412 tickToTag BottomFound = 14
413 tickToTag SimplifierDone = 16
414 tickToTag (AltMerge _) = 17
415
416 tickString :: Tick -> String
417 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
418 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
419 tickString (UnfoldingDone _) = "UnfoldingDone"
420 tickString (RuleFired _) = "RuleFired"
421 tickString LetFloatFromLet = "LetFloatFromLet"
422 tickString (EtaExpansion _) = "EtaExpansion"
423 tickString (EtaReduction _) = "EtaReduction"
424 tickString (BetaReduction _) = "BetaReduction"
425 tickString (CaseOfCase _) = "CaseOfCase"
426 tickString (KnownBranch _) = "KnownBranch"
427 tickString (CaseMerge _) = "CaseMerge"
428 tickString (AltMerge _) = "AltMerge"
429 tickString (CaseElim _) = "CaseElim"
430 tickString (CaseIdentity _) = "CaseIdentity"
431 tickString (FillInCaseDefault _) = "FillInCaseDefault"
432 tickString BottomFound = "BottomFound"
433 tickString SimplifierDone = "SimplifierDone"
434
435 pprTickCts :: Tick -> SDoc
436 pprTickCts (PreInlineUnconditionally v) = ppr v
437 pprTickCts (PostInlineUnconditionally v)= ppr v
438 pprTickCts (UnfoldingDone v) = ppr v
439 pprTickCts (RuleFired v) = ppr v
440 pprTickCts LetFloatFromLet = Outputable.empty
441 pprTickCts (EtaExpansion v) = ppr v
442 pprTickCts (EtaReduction v) = ppr v
443 pprTickCts (BetaReduction v) = ppr v
444 pprTickCts (CaseOfCase v) = ppr v
445 pprTickCts (KnownBranch v) = ppr v
446 pprTickCts (CaseMerge v) = ppr v
447 pprTickCts (AltMerge v) = ppr v
448 pprTickCts (CaseElim v) = ppr v
449 pprTickCts (CaseIdentity v) = ppr v
450 pprTickCts (FillInCaseDefault v) = ppr v
451 pprTickCts _ = Outputable.empty
452
453 cmpTick :: Tick -> Tick -> Ordering
454 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
455 GT -> GT
456 EQ -> cmpEqTick a b
457 LT -> LT
458
459 cmpEqTick :: Tick -> Tick -> Ordering
460 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
461 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
462 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
463 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
464 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
465 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
466 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
467 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
468 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
469 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
470 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
471 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
472 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
473 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
474 cmpEqTick _ _ = EQ
475
476 {-
477 ************************************************************************
478 * *
479 Monad and carried data structure definitions
480 * *
481 ************************************************************************
482 -}
483
484 newtype CoreState = CoreState {
485 cs_uniq_supply :: UniqSupply
486 }
487
488 data CoreReader = CoreReader {
489 cr_hsc_env :: HscEnv,
490 cr_rule_base :: RuleBase,
491 cr_module :: Module,
492 cr_print_unqual :: PrintUnqualified,
493 cr_loc :: SrcSpan, -- Use this for log/error messages so they
494 -- are at least tagged with the right source file
495 cr_visible_orphan_mods :: !ModuleSet
496 }
497
498 -- Note: CoreWriter used to be defined with data, rather than newtype. If it
499 -- is defined that way again, the cw_simpl_count field, at least, must be
500 -- strict to avoid a space leak (Trac #7702).
501 newtype CoreWriter = CoreWriter {
502 cw_simpl_count :: SimplCount
503 }
504
505 emptyWriter :: DynFlags -> CoreWriter
506 emptyWriter dflags = CoreWriter {
507 cw_simpl_count = zeroSimplCount dflags
508 }
509
510 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
511 plusWriter w1 w2 = CoreWriter {
512 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
513 }
514
515 type CoreIOEnv = IOEnv CoreReader
516
517 -- | The monad used by Core-to-Core passes to access common state, register simplification
518 -- statistics and so on
519 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
520
521 instance Functor CoreM where
522 fmap = liftM
523
524 instance Monad CoreM where
525 mx >>= f = CoreM $ \s -> do
526 (x, s', w1) <- unCoreM mx s
527 (y, s'', w2) <- unCoreM (f x) s'
528 let w = w1 `plusWriter` w2
529 return $ seq w (y, s'', w)
530 -- forcing w before building the tuple avoids a space leak
531 -- (Trac #7702)
532
533 instance Applicative CoreM where
534 pure x = CoreM $ \s -> nop s x
535 (<*>) = ap
536 m *> k = m >>= \_ -> k
537
538 instance Alternative CoreM where
539 empty = CoreM (const Control.Applicative.empty)
540 m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs)
541
542 instance MonadPlus CoreM
543
544 instance MonadUnique CoreM where
545 getUniqueSupplyM = do
546 us <- getS cs_uniq_supply
547 let (us1, us2) = splitUniqSupply us
548 modifyS (\s -> s { cs_uniq_supply = us2 })
549 return us1
550
551 getUniqueM = do
552 us <- getS cs_uniq_supply
553 let (u,us') = takeUniqFromSupply us
554 modifyS (\s -> s { cs_uniq_supply = us' })
555 return u
556
557 runCoreM :: HscEnv
558 -> RuleBase
559 -> UniqSupply
560 -> Module
561 -> ModuleSet
562 -> PrintUnqualified
563 -> SrcSpan
564 -> CoreM a
565 -> IO (a, SimplCount)
566 runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
567 = liftM extract $ runIOEnv reader $ unCoreM m state
568 where
569 reader = CoreReader {
570 cr_hsc_env = hsc_env,
571 cr_rule_base = rule_base,
572 cr_module = mod,
573 cr_visible_orphan_mods = orph_imps,
574 cr_print_unqual = print_unqual,
575 cr_loc = loc
576 }
577 state = CoreState {
578 cs_uniq_supply = us
579 }
580
581 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
582 extract (value, _, writer) = (value, cw_simpl_count writer)
583
584 {-
585 ************************************************************************
586 * *
587 Core combinators, not exported
588 * *
589 ************************************************************************
590 -}
591
592 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
593 nop s x = do
594 r <- getEnv
595 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
596
597 read :: (CoreReader -> a) -> CoreM a
598 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
599
600 getS :: (CoreState -> a) -> CoreM a
601 getS f = CoreM (\s -> nop s (f s))
602
603 modifyS :: (CoreState -> CoreState) -> CoreM ()
604 modifyS f = CoreM (\s -> nop (f s) ())
605
606 write :: CoreWriter -> CoreM ()
607 write w = CoreM (\s -> return ((), s, w))
608
609 -- \subsection{Lifting IO into the monad}
610
611 -- | Lift an 'IOEnv' operation into 'CoreM'
612 liftIOEnv :: CoreIOEnv a -> CoreM a
613 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
614
615 instance MonadIO CoreM where
616 liftIO = liftIOEnv . IOEnv.liftIO
617
618 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
619 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
620 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
621
622 {-
623 ************************************************************************
624 * *
625 Reader, writer and state accessors
626 * *
627 ************************************************************************
628 -}
629
630 getHscEnv :: CoreM HscEnv
631 getHscEnv = read cr_hsc_env
632
633 getRuleBase :: CoreM RuleBase
634 getRuleBase = read cr_rule_base
635
636 getVisibleOrphanMods :: CoreM ModuleSet
637 getVisibleOrphanMods = read cr_visible_orphan_mods
638
639 getPrintUnqualified :: CoreM PrintUnqualified
640 getPrintUnqualified = read cr_print_unqual
641
642 getSrcSpanM :: CoreM SrcSpan
643 getSrcSpanM = read cr_loc
644
645 addSimplCount :: SimplCount -> CoreM ()
646 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
647
648 -- Convenience accessors for useful fields of HscEnv
649
650 instance HasDynFlags CoreM where
651 getDynFlags = fmap hsc_dflags getHscEnv
652
653 instance HasModule CoreM where
654 getModule = read cr_module
655
656 -- | The original name cache is the current mapping from 'Module' and
657 -- 'OccName' to a compiler-wide unique 'Name'
658 getOrigNameCache :: CoreM OrigNameCache
659 getOrigNameCache = do
660 nameCacheRef <- fmap hsc_NC getHscEnv
661 liftIO $ fmap nsNames $ readIORef nameCacheRef
662
663 getPackageFamInstEnv :: CoreM PackageFamInstEnv
664 getPackageFamInstEnv = do
665 hsc_env <- getHscEnv
666 eps <- liftIO $ hscEPS hsc_env
667 return $ eps_fam_inst_env eps
668
669 {-# 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" #-}
670 reinitializeGlobals :: CoreM ()
671 reinitializeGlobals = return ()
672
673 {-
674 ************************************************************************
675 * *
676 Dealing with annotations
677 * *
678 ************************************************************************
679 -}
680
681 -- | Get all annotations of a given type. This happens lazily, that is
682 -- no deserialization will take place until the [a] is actually demanded and
683 -- the [a] can also be empty (the UniqFM is not filtered).
684 --
685 -- This should be done once at the start of a Core-to-Core pass that uses
686 -- annotations.
687 --
688 -- See Note [Annotations]
689 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
690 getAnnotations deserialize guts = do
691 hsc_env <- getHscEnv
692 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
693 return (deserializeAnns deserialize ann_env)
694
695 -- | Get at most one annotation of a given type per Unique.
696 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
697 getFirstAnnotations deserialize guts
698 = liftM (mapUFM head . filterUFM (not . null))
699 $ getAnnotations deserialize guts
700
701 {-
702 Note [Annotations]
703 ~~~~~~~~~~~~~~~~~~
704 A Core-to-Core pass that wants to make use of annotations calls
705 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
706 annotations of a specific type. This produces all annotations from interface
707 files read so far. However, annotations from interface files read during the
708 pass will not be visible until getAnnotations is called again. This is similar
709 to how rules work and probably isn't too bad.
710
711 The current implementation could be optimised a bit: when looking up
712 annotations for a thing from the HomePackageTable, we could search directly in
713 the module where the thing is defined rather than building one UniqFM which
714 contains all annotations we know of. This would work because annotations can
715 only be given to things defined in the same module. However, since we would
716 only want to deserialise every annotation once, we would have to build a cache
717 for every module in the HTP. In the end, it's probably not worth it as long as
718 we aren't using annotations heavily.
719
720 ************************************************************************
721 * *
722 Direct screen output
723 * *
724 ************************************************************************
725 -}
726
727 msg :: Severity -> SDoc -> CoreM ()
728 msg sev doc
729 = do { dflags <- getDynFlags
730 ; loc <- getSrcSpanM
731 ; unqual <- getPrintUnqualified
732 ; let sty = case sev of
733 SevError -> err_sty
734 SevWarning -> err_sty
735 SevDump -> dump_sty
736 _ -> user_sty
737 err_sty = mkErrStyle dflags unqual
738 user_sty = mkUserStyle dflags unqual AllTheWay
739 dump_sty = mkDumpStyle dflags unqual
740 ; liftIO $
741 (log_action dflags) dflags NoReason sev loc sty doc }
742
743 -- | Output a String message to the screen
744 putMsgS :: String -> CoreM ()
745 putMsgS = putMsg . text
746
747 -- | Output a message to the screen
748 putMsg :: SDoc -> CoreM ()
749 putMsg = msg SevInfo
750
751 -- | Output an error to the screen. Does not cause the compiler to die.
752 errorMsgS :: String -> CoreM ()
753 errorMsgS = errorMsg . text
754
755 -- | Output an error to the screen. Does not cause the compiler to die.
756 errorMsg :: SDoc -> CoreM ()
757 errorMsg = msg SevError
758
759 warnMsg :: SDoc -> CoreM ()
760 warnMsg = msg SevWarning
761
762 -- | Output a fatal error to the screen. Does not cause the compiler to die.
763 fatalErrorMsgS :: String -> CoreM ()
764 fatalErrorMsgS = fatalErrorMsg . text
765
766 -- | Output a fatal error to the screen. Does not cause the compiler to die.
767 fatalErrorMsg :: SDoc -> CoreM ()
768 fatalErrorMsg = msg SevFatal
769
770 -- | Output a string debugging message at verbosity level of @-v@ or higher
771 debugTraceMsgS :: String -> CoreM ()
772 debugTraceMsgS = debugTraceMsg . text
773
774 -- | Outputs a debugging message at verbosity level of @-v@ or higher
775 debugTraceMsg :: SDoc -> CoreM ()
776 debugTraceMsg = msg SevDump
777
778 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
779 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
780 dumpIfSet_dyn flag str doc
781 = do { dflags <- getDynFlags
782 ; unqual <- getPrintUnqualified
783 ; when (dopt flag dflags) $ liftIO $
784 Err.dumpSDoc dflags unqual flag str doc }
785
786 {-
787 ************************************************************************
788 * *
789 Finding TyThings
790 * *
791 ************************************************************************
792 -}
793
794 instance MonadThings CoreM where
795 lookupThing name = do { hsc_env <- getHscEnv
796 ; liftIO $ lookupGlobal hsc_env name }
797
798 {-
799 ************************************************************************
800 * *
801 Template Haskell interoperability
802 * *
803 ************************************************************************
804 -}
805
806 -- | Attempt to convert a Template Haskell name to one that GHC can
807 -- understand. Original TH names such as those you get when you use
808 -- the @'foo@ syntax will be translated to their equivalent GHC name
809 -- exactly. Qualified or unqualified TH names will be dynamically bound
810 -- to names in the module being compiled, if possible. Exact TH names
811 -- will be bound to the name they represent, exactly.
812 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
813 thNameToGhcName th_name = do
814 hsc_env <- getHscEnv
815 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)