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