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