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