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