Provide details in `plusSimplCount` errors
[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 -- ** 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
586 instance Functor CoreM where
587 fmap = liftM
588
589 instance Monad CoreM where
590 mx >>= f = CoreM $ \s -> do
591 (x, s', w1) <- unCoreM mx s
592 (y, s'', w2) <- unCoreM (f x) s'
593 let w = w1 `plusWriter` w2
594 return $ seq w (y, s'', w)
595 -- forcing w before building the tuple avoids a space leak
596 -- (#7702)
597
598 instance Applicative CoreM where
599 pure x = CoreM $ \s -> nop s x
600 (<*>) = ap
601 m *> k = m >>= \_ -> k
602
603 instance Alternative CoreM where
604 empty = CoreM (const Control.Applicative.empty)
605 m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs)
606
607 instance MonadPlus CoreM
608
609 instance MonadUnique CoreM where
610 getUniqueSupplyM = do
611 us <- getS cs_uniq_supply
612 let (us1, us2) = splitUniqSupply us
613 modifyS (\s -> s { cs_uniq_supply = us2 })
614 return us1
615
616 getUniqueM = do
617 us <- getS cs_uniq_supply
618 let (u,us') = takeUniqFromSupply us
619 modifyS (\s -> s { cs_uniq_supply = us' })
620 return u
621
622 runCoreM :: HscEnv
623 -> RuleBase
624 -> UniqSupply
625 -> Module
626 -> ModuleSet
627 -> PrintUnqualified
628 -> SrcSpan
629 -> CoreM a
630 -> IO (a, SimplCount)
631 runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
632 = liftM extract $ runIOEnv reader $ unCoreM m state
633 where
634 reader = CoreReader {
635 cr_hsc_env = hsc_env,
636 cr_rule_base = rule_base,
637 cr_module = mod,
638 cr_visible_orphan_mods = orph_imps,
639 cr_print_unqual = print_unqual,
640 cr_loc = loc
641 }
642 state = CoreState {
643 cs_uniq_supply = us
644 }
645
646 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
647 extract (value, _, writer) = (value, cw_simpl_count writer)
648
649 {-
650 ************************************************************************
651 * *
652 Core combinators, not exported
653 * *
654 ************************************************************************
655 -}
656
657 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
658 nop s x = do
659 r <- getEnv
660 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
661
662 read :: (CoreReader -> a) -> CoreM a
663 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
664
665 getS :: (CoreState -> a) -> CoreM a
666 getS f = CoreM (\s -> nop s (f s))
667
668 modifyS :: (CoreState -> CoreState) -> CoreM ()
669 modifyS f = CoreM (\s -> nop (f s) ())
670
671 write :: CoreWriter -> CoreM ()
672 write w = CoreM (\s -> return ((), s, w))
673
674 -- \subsection{Lifting IO into the monad}
675
676 -- | Lift an 'IOEnv' operation into 'CoreM'
677 liftIOEnv :: CoreIOEnv a -> CoreM a
678 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
679
680 instance MonadIO CoreM where
681 liftIO = liftIOEnv . IOEnv.liftIO
682
683 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
684 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
685 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
686
687 {-
688 ************************************************************************
689 * *
690 Reader, writer and state accessors
691 * *
692 ************************************************************************
693 -}
694
695 getHscEnv :: CoreM HscEnv
696 getHscEnv = read cr_hsc_env
697
698 getRuleBase :: CoreM RuleBase
699 getRuleBase = read cr_rule_base
700
701 getVisibleOrphanMods :: CoreM ModuleSet
702 getVisibleOrphanMods = read cr_visible_orphan_mods
703
704 getPrintUnqualified :: CoreM PrintUnqualified
705 getPrintUnqualified = read cr_print_unqual
706
707 getSrcSpanM :: CoreM SrcSpan
708 getSrcSpanM = read cr_loc
709
710 addSimplCount :: SimplCount -> CoreM ()
711 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
712
713 -- Convenience accessors for useful fields of HscEnv
714
715 instance HasDynFlags CoreM where
716 getDynFlags = fmap hsc_dflags getHscEnv
717
718 instance HasModule CoreM where
719 getModule = read cr_module
720
721 -- | The original name cache is the current mapping from 'Module' and
722 -- 'OccName' to a compiler-wide unique 'Name'
723 getOrigNameCache :: CoreM OrigNameCache
724 getOrigNameCache = do
725 nameCacheRef <- fmap hsc_NC getHscEnv
726 liftIO $ fmap nsNames $ readIORef nameCacheRef
727
728 getPackageFamInstEnv :: CoreM PackageFamInstEnv
729 getPackageFamInstEnv = do
730 hsc_env <- getHscEnv
731 eps <- liftIO $ hscEPS hsc_env
732 return $ eps_fam_inst_env eps
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 -> WarnReason -> SDoc -> CoreM ()
789 msg sev reason 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 reason 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 NoReason
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 NoReason
818
819 warnMsg :: WarnReason -> 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 NoReason
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 NoReason
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 }