Allow use of the external interpreter in stage1.
[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
137 instance Outputable CoreToDo where
138 ppr (CoreDoSimplify _ _) = text "Simplifier"
139 ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s
140 ppr CoreDoFloatInwards = text "Float inwards"
141 ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f)
142 ppr CoreLiberateCase = text "Liberate case"
143 ppr CoreDoStaticArgs = text "Static argument"
144 ppr CoreDoCallArity = text "Called arity analysis"
145 ppr CoreDoStrictness = text "Demand analysis"
146 ppr CoreDoWorkerWrapper = text "Worker Wrapper binds"
147 ppr CoreDoSpecialising = text "Specialise"
148 ppr CoreDoSpecConstr = text "SpecConstr"
149 ppr CoreCSE = text "Common sub-expression"
150 ppr CoreDoVectorisation = text "Vectorisation"
151 ppr CoreDesugar = text "Desugar (before optimization)"
152 ppr CoreDesugarOpt = text "Desugar (after optimization)"
153 ppr CoreTidy = text "Tidy Core"
154 ppr CorePrep = text "CorePrep"
155 ppr CoreDoPrintCore = text "Print core"
156 ppr (CoreDoRuleCheck {}) = text "Rule check"
157 ppr CoreDoNothing = text "CoreDoNothing"
158 ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes
159
160 pprPassDetails :: CoreToDo -> SDoc
161 pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n
162 , ppr md ]
163 pprPassDetails _ = Outputable.empty
164
165 data SimplifierMode -- See comments in SimplMonad
166 = SimplMode
167 { sm_names :: [String] -- Name(s) of the phase
168 , sm_phase :: CompilerPhase
169 , sm_rules :: Bool -- Whether RULES are enabled
170 , sm_inline :: Bool -- Whether inlining is enabled
171 , sm_case_case :: Bool -- Whether case-of-case is enabled
172 , sm_eta_expand :: Bool -- Whether eta-expansion is enabled
173 }
174
175 instance Outputable SimplifierMode where
176 ppr (SimplMode { sm_phase = p, sm_names = ss
177 , sm_rules = r, sm_inline = i
178 , sm_eta_expand = eta, sm_case_case = cc })
179 = text "SimplMode" <+> braces (
180 sep [ text "Phase =" <+> ppr p <+>
181 brackets (text (concat $ intersperse "," ss)) <> comma
182 , pp_flag i (sLit "inline") <> comma
183 , pp_flag r (sLit "rules") <> comma
184 , pp_flag eta (sLit "eta-expand") <> comma
185 , pp_flag cc (sLit "case-of-case") ])
186 where
187 pp_flag f s = ppUnless f (text "no") <+> ptext s
188
189 data FloatOutSwitches = FloatOutSwitches {
190 floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if
191 -- doing so will abstract over n or fewer
192 -- value variables
193 -- Nothing <=> float all lambdas to top level,
194 -- regardless of how many free variables
195 -- Just 0 is the vanilla case: float a lambda
196 -- iff it has no free vars
197
198 floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
199 -- even if they do not escape a lambda
200 floatOutOverSatApps :: Bool,
201 -- ^ True <=> float out over-saturated applications
202 -- based on arity information.
203 -- See Note [Floating over-saturated applications]
204 -- in SetLevels
205 floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only.
206 }
207 instance Outputable FloatOutSwitches where
208 ppr = pprFloatOutSwitches
209
210 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
211 pprFloatOutSwitches sw
212 = text "FOS" <+> (braces $
213 sep $ punctuate comma $
214 [ text "Lam =" <+> ppr (floatOutLambdas sw)
215 , text "Consts =" <+> ppr (floatOutConstants sw)
216 , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ])
217
218 -- The core-to-core pass ordering is derived from the DynFlags:
219 runWhen :: Bool -> CoreToDo -> CoreToDo
220 runWhen True do_this = do_this
221 runWhen False _ = CoreDoNothing
222
223 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
224 runMaybe (Just x) f = f x
225 runMaybe Nothing _ = CoreDoNothing
226
227 {-
228
229 ************************************************************************
230 * *
231 Types for Plugins
232 * *
233 ************************************************************************
234 -}
235
236 -- | A description of the plugin pass itself
237 type PluginPass = ModGuts -> CoreM ModGuts
238
239 bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
240 bindsOnlyPass pass guts
241 = do { binds' <- pass (mg_binds guts)
242 ; return (guts { mg_binds = binds' }) }
243
244 {-
245 ************************************************************************
246 * *
247 Counting and logging
248 * *
249 ************************************************************************
250 -}
251
252 verboseSimplStats :: Bool
253 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
254
255 zeroSimplCount :: DynFlags -> SimplCount
256 isZeroSimplCount :: SimplCount -> Bool
257 hasDetailedCounts :: SimplCount -> Bool
258 pprSimplCount :: SimplCount -> SDoc
259 doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount
260 doFreeSimplTick :: Tick -> SimplCount -> SimplCount
261 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
262
263 data SimplCount
264 = VerySimplCount !Int -- Used when don't want detailed stats
265
266 | SimplCount {
267 ticks :: !Int, -- Total ticks
268 details :: !TickCounts, -- How many of each type
269
270 n_log :: !Int, -- N
271 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
272 -- most recent first
273 log2 :: [Tick] -- Last opt_HistorySize events before that
274 -- Having log1, log2 lets us accumulate the
275 -- recent history reasonably efficiently
276 }
277
278 type TickCounts = Map Tick Int
279
280 simplCountN :: SimplCount -> Int
281 simplCountN (VerySimplCount n) = n
282 simplCountN (SimplCount { ticks = n }) = n
283
284 zeroSimplCount dflags
285 -- This is where we decide whether to do
286 -- the VerySimpl version or the full-stats version
287 | dopt Opt_D_dump_simpl_stats dflags
288 = SimplCount {ticks = 0, details = Map.empty,
289 n_log = 0, log1 = [], log2 = []}
290 | otherwise
291 = VerySimplCount 0
292
293 isZeroSimplCount (VerySimplCount n) = n==0
294 isZeroSimplCount (SimplCount { ticks = n }) = n==0
295
296 hasDetailedCounts (VerySimplCount {}) = False
297 hasDetailedCounts (SimplCount {}) = True
298
299 doFreeSimplTick tick sc@SimplCount { details = dts }
300 = sc { details = dts `addTick` tick }
301 doFreeSimplTick _ sc = sc
302
303 doSimplTick dflags tick
304 sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })
305 | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
306 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
307 where
308 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
309
310 doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
311
312
313 -- Don't use Map.unionWith because that's lazy, and we want to
314 -- be pretty strict here!
315 addTick :: TickCounts -> Tick -> TickCounts
316 addTick fm tick = case Map.lookup tick fm of
317 Nothing -> Map.insert tick 1 fm
318 Just n -> n1 `seq` Map.insert tick n1 fm
319 where
320 n1 = n+1
321
322
323 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
324 sc2@(SimplCount { ticks = tks2, details = dts2 })
325 = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
326 where
327 -- A hackish way of getting recent log info
328 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
329 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
330 | otherwise = sc2
331
332 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
333 plusSimplCount _ _ = panic "plusSimplCount"
334 -- We use one or the other consistently
335
336 pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n
337 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
338 = vcat [text "Total ticks: " <+> int tks,
339 blankLine,
340 pprTickCounts dts,
341 if verboseSimplStats 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 = runs 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 unqual AllTheWay
742 dump_sty = mkDumpStyle unqual
743 ; liftIO $
744 (log_action dflags) dflags NoReason sev loc sty doc }
745
746 -- | Output a String message to the screen
747 putMsgS :: String -> CoreM ()
748 putMsgS = putMsg . text
749
750 -- | Output a message to the screen
751 putMsg :: SDoc -> CoreM ()
752 putMsg = msg SevInfo
753
754 -- | Output an error to the screen. Does not cause the compiler to die.
755 errorMsgS :: String -> CoreM ()
756 errorMsgS = errorMsg . text
757
758 -- | Output an error to the screen. Does not cause the compiler to die.
759 errorMsg :: SDoc -> CoreM ()
760 errorMsg = msg SevError
761
762 warnMsg :: SDoc -> CoreM ()
763 warnMsg = msg SevWarning
764
765 -- | Output a fatal error to the screen. Does not cause the compiler to die.
766 fatalErrorMsgS :: String -> CoreM ()
767 fatalErrorMsgS = fatalErrorMsg . text
768
769 -- | Output a fatal error to the screen. Does not cause the compiler to die.
770 fatalErrorMsg :: SDoc -> CoreM ()
771 fatalErrorMsg = msg SevFatal
772
773 -- | Output a string debugging message at verbosity level of @-v@ or higher
774 debugTraceMsgS :: String -> CoreM ()
775 debugTraceMsgS = debugTraceMsg . text
776
777 -- | Outputs a debugging message at verbosity level of @-v@ or higher
778 debugTraceMsg :: SDoc -> CoreM ()
779 debugTraceMsg = msg SevDump
780
781 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
782 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
783 dumpIfSet_dyn flag str doc
784 = do { dflags <- getDynFlags
785 ; unqual <- getPrintUnqualified
786 ; when (dopt flag dflags) $ liftIO $
787 Err.dumpSDoc dflags unqual flag str doc }
788
789 {-
790 ************************************************************************
791 * *
792 Finding TyThings
793 * *
794 ************************************************************************
795 -}
796
797 instance MonadThings CoreM where
798 lookupThing name = do { hsc_env <- getHscEnv
799 ; liftIO $ lookupGlobal hsc_env name }
800
801 {-
802 ************************************************************************
803 * *
804 Template Haskell interoperability
805 * *
806 ************************************************************************
807 -}
808
809 -- | Attempt to convert a Template Haskell name to one that GHC can
810 -- understand. Original TH names such as those you get when you use
811 -- the @'foo@ syntax will be translated to their equivalent GHC name
812 -- exactly. Qualified or unqualifed TH names will be dynamically bound
813 -- to names in the module being compiled, if possible. Exact TH names
814 -- will be bound to the name they represent, exactly.
815 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
816 thNameToGhcName th_name = do
817 hsc_env <- getHscEnv
818 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)