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