Replace calls to `ptext . sLit` with `text`
[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 SimplifierMode(..),
13 FloatOutSwitches(..),
14 pprPassDetails,
15
16 -- * Plugins
17 PluginPass, bindsOnlyPass,
18
19 -- * Counting
20 SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
21 pprSimplCount, plusSimplCount, zeroSimplCount,
22 isZeroSimplCount, hasDetailedCounts, Tick(..),
23
24 -- * The monad
25 CoreM, runCoreM,
26
27 -- ** Reading from the monad
28 getHscEnv, getRuleBase, getModule,
29 getDynFlags, getOrigNameCache, getPackageFamInstEnv,
30 getVisibleOrphanMods,
31 getPrintUnqualified, getSrcSpanM,
32
33 -- ** Writing to the monad
34 addSimplCount,
35
36 -- ** Lifting into the monad
37 liftIO, liftIOWithCount,
38 liftIO1, liftIO2, liftIO3, liftIO4,
39
40 -- ** Global initialization
41 reinitializeGlobals,
42
43 -- ** Dealing with annotations
44 getAnnotations, getFirstAnnotations,
45
46 -- ** Screen output
47 putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
48 fatalErrorMsg, fatalErrorMsgS,
49 debugTraceMsg, debugTraceMsgS,
50 dumpIfSet_dyn,
51
52 #ifdef GHCI
53 -- * Getting 'Name's
54 thNameToGhcName
55 #endif
56 ) where
57
58 #ifdef GHCI
59 import Name( Name )
60 import TcRnMonad ( initTcForLookup )
61 #endif
62 import CoreSyn
63 import HscTypes
64 import Module
65 import DynFlags
66 import StaticFlags
67 import BasicTypes ( CompilerPhase(..) )
68 import Annotations
69
70 import IOEnv hiding ( liftIO, failM, failWithM )
71 import qualified IOEnv ( liftIO )
72 import TcEnv ( lookupGlobal )
73 import Var
74 import Outputable
75 import FastString
76 import qualified ErrUtils as Err
77 import ErrUtils( Severity(..) )
78 import Maybes
79 import UniqSupply
80 import UniqFM ( UniqFM, mapUFM, filterUFM )
81 import MonadUtils
82 import SrcLoc
83 import ListSetOps ( runs )
84 import Data.List
85 import Data.Ord
86 import Data.Dynamic
87 import Data.IORef
88 import Data.Map (Map)
89 import qualified Data.Map as Map
90 import Data.Word
91 import Control.Monad
92 import Control.Applicative ( Alternative(..) )
93
94 import Prelude hiding ( read )
95
96 #ifdef GHCI
97 import Control.Concurrent.MVar (MVar)
98 import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
99 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
100 import qualified Language.Haskell.TH as TH
101 #else
102 saveLinkerGlobals :: IO ()
103 saveLinkerGlobals = return ()
104
105 restoreLinkerGlobals :: () -> IO ()
106 restoreLinkerGlobals () = return ()
107 #endif
108
109 {-
110 ************************************************************************
111 * *
112 The CoreToDo type and related types
113 Abstraction of core-to-core passes to run.
114 * *
115 ************************************************************************
116 -}
117
118 data CoreToDo -- These are diff core-to-core passes,
119 -- which may be invoked in any order,
120 -- as many times as you like.
121
122 = CoreDoSimplify -- The core-to-core simplifier.
123 Int -- Max iterations
124 SimplifierMode
125 | CoreDoPluginPass String PluginPass
126 | CoreDoFloatInwards
127 | CoreDoFloatOutwards FloatOutSwitches
128 | CoreLiberateCase
129 | CoreDoPrintCore
130 | CoreDoStaticArgs
131 | CoreDoCallArity
132 | CoreDoStrictness
133 | CoreDoWorkerWrapper
134 | CoreDoSpecialising
135 | CoreDoSpecConstr
136 | CoreCSE
137 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
138 -- matching this string
139 | CoreDoVectorisation
140 | CoreDoNothing -- Useful when building up
141 | CoreDoPasses [CoreToDo] -- lists of these things
142
143 | CoreDesugar -- Right after desugaring, no simple optimisation yet!
144 | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
145 -- Core output, and hence useful to pass to endPass
146
147 | CoreTidy
148 | CorePrep
149
150 instance Outputable CoreToDo where
151 ppr (CoreDoSimplify _ _) = text "Simplifier"
152 ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s
153 ppr CoreDoFloatInwards = text "Float inwards"
154 ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f)
155 ppr CoreLiberateCase = text "Liberate case"
156 ppr CoreDoStaticArgs = text "Static argument"
157 ppr CoreDoCallArity = text "Called arity analysis"
158 ppr CoreDoStrictness = text "Demand analysis"
159 ppr CoreDoWorkerWrapper = text "Worker Wrapper binds"
160 ppr CoreDoSpecialising = text "Specialise"
161 ppr CoreDoSpecConstr = text "SpecConstr"
162 ppr CoreCSE = text "Common sub-expression"
163 ppr CoreDoVectorisation = text "Vectorisation"
164 ppr CoreDesugar = text "Desugar (before optimization)"
165 ppr CoreDesugarOpt = text "Desugar (after optimization)"
166 ppr CoreTidy = text "Tidy Core"
167 ppr CorePrep = text "CorePrep"
168 ppr CoreDoPrintCore = text "Print core"
169 ppr (CoreDoRuleCheck {}) = text "Rule check"
170 ppr CoreDoNothing = text "CoreDoNothing"
171 ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes
172
173 pprPassDetails :: CoreToDo -> SDoc
174 pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n
175 , ppr md ]
176 pprPassDetails _ = Outputable.empty
177
178 data SimplifierMode -- See comments in SimplMonad
179 = SimplMode
180 { sm_names :: [String] -- Name(s) of the phase
181 , sm_phase :: CompilerPhase
182 , sm_rules :: Bool -- Whether RULES are enabled
183 , sm_inline :: Bool -- Whether inlining is enabled
184 , sm_case_case :: Bool -- Whether case-of-case is enabled
185 , sm_eta_expand :: Bool -- Whether eta-expansion is enabled
186 }
187
188 instance Outputable SimplifierMode where
189 ppr (SimplMode { sm_phase = p, sm_names = ss
190 , sm_rules = r, sm_inline = i
191 , sm_eta_expand = eta, sm_case_case = cc })
192 = text "SimplMode" <+> braces (
193 sep [ text "Phase =" <+> ppr p <+>
194 brackets (text (concat $ intersperse "," ss)) <> comma
195 , pp_flag i (sLit "inline") <> comma
196 , pp_flag r (sLit "rules") <> comma
197 , pp_flag eta (sLit "eta-expand") <> comma
198 , pp_flag cc (sLit "case-of-case") ])
199 where
200 pp_flag f s = ppUnless f (text "no") <+> ptext s
201
202 data FloatOutSwitches = FloatOutSwitches {
203 floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if
204 -- doing so will abstract over n or fewer
205 -- value variables
206 -- Nothing <=> float all lambdas to top level,
207 -- regardless of how many free variables
208 -- Just 0 is the vanilla case: float a lambda
209 -- iff it has no free vars
210
211 floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
212 -- even if they do not escape a lambda
213 floatOutOverSatApps :: Bool -- ^ True <=> float out over-saturated applications
214 -- based on arity information.
215 -- See Note [Floating over-saturated applications]
216 -- in SetLevels
217 }
218 instance Outputable FloatOutSwitches where
219 ppr = pprFloatOutSwitches
220
221 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
222 pprFloatOutSwitches sw
223 = text "FOS" <+> (braces $
224 sep $ punctuate comma $
225 [ text "Lam =" <+> ppr (floatOutLambdas sw)
226 , text "Consts =" <+> ppr (floatOutConstants sw)
227 , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ])
228
229 -- The core-to-core pass ordering is derived from the DynFlags:
230 runWhen :: Bool -> CoreToDo -> CoreToDo
231 runWhen True do_this = do_this
232 runWhen False _ = CoreDoNothing
233
234 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
235 runMaybe (Just x) f = f x
236 runMaybe Nothing _ = CoreDoNothing
237
238 {-
239 Note [RULEs enabled in SimplGently]
240 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
241 RULES are enabled when doing "gentle" simplification. Two reasons:
242
243 * We really want the class-op cancellation to happen:
244 op (df d1 d2) --> $cop3 d1 d2
245 because this breaks the mutual recursion between 'op' and 'df'
246
247 * I wanted the RULE
248 lift String ===> ...
249 to work in Template Haskell when simplifying
250 splices, so we get simpler code for literal strings
251
252 But watch out: list fusion can prevent floating. So use phase control
253 to switch off those rules until after floating.
254
255
256 ************************************************************************
257 * *
258 Types for Plugins
259 * *
260 ************************************************************************
261 -}
262
263 -- | A description of the plugin pass itself
264 type PluginPass = ModGuts -> CoreM ModGuts
265
266 bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
267 bindsOnlyPass pass guts
268 = do { binds' <- pass (mg_binds guts)
269 ; return (guts { mg_binds = binds' }) }
270
271 {-
272 ************************************************************************
273 * *
274 Counting and logging
275 * *
276 ************************************************************************
277 -}
278
279 verboseSimplStats :: Bool
280 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
281
282 zeroSimplCount :: DynFlags -> SimplCount
283 isZeroSimplCount :: SimplCount -> Bool
284 hasDetailedCounts :: SimplCount -> Bool
285 pprSimplCount :: SimplCount -> SDoc
286 doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount
287 doFreeSimplTick :: Tick -> SimplCount -> SimplCount
288 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
289
290 data SimplCount
291 = VerySimplCount !Int -- Used when don't want detailed stats
292
293 | SimplCount {
294 ticks :: !Int, -- Total ticks
295 details :: !TickCounts, -- How many of each type
296
297 n_log :: !Int, -- N
298 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
299 -- most recent first
300 log2 :: [Tick] -- Last opt_HistorySize events before that
301 -- Having log1, log2 lets us accumulate the
302 -- recent history reasonably efficiently
303 }
304
305 type TickCounts = Map Tick Int
306
307 simplCountN :: SimplCount -> Int
308 simplCountN (VerySimplCount n) = n
309 simplCountN (SimplCount { ticks = n }) = n
310
311 zeroSimplCount dflags
312 -- This is where we decide whether to do
313 -- the VerySimpl version or the full-stats version
314 | dopt Opt_D_dump_simpl_stats dflags
315 = SimplCount {ticks = 0, details = Map.empty,
316 n_log = 0, log1 = [], log2 = []}
317 | otherwise
318 = VerySimplCount 0
319
320 isZeroSimplCount (VerySimplCount n) = n==0
321 isZeroSimplCount (SimplCount { ticks = n }) = n==0
322
323 hasDetailedCounts (VerySimplCount {}) = False
324 hasDetailedCounts (SimplCount {}) = True
325
326 doFreeSimplTick tick sc@SimplCount { details = dts }
327 = sc { details = dts `addTick` tick }
328 doFreeSimplTick _ sc = sc
329
330 doSimplTick dflags tick
331 sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })
332 | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
333 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
334 where
335 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
336
337 doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
338
339
340 -- Don't use Map.unionWith because that's lazy, and we want to
341 -- be pretty strict here!
342 addTick :: TickCounts -> Tick -> TickCounts
343 addTick fm tick = case Map.lookup tick fm of
344 Nothing -> Map.insert tick 1 fm
345 Just n -> n1 `seq` Map.insert tick n1 fm
346 where
347 n1 = n+1
348
349
350 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
351 sc2@(SimplCount { ticks = tks2, details = dts2 })
352 = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
353 where
354 -- A hackish way of getting recent log info
355 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
356 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
357 | otherwise = sc2
358
359 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
360 plusSimplCount _ _ = panic "plusSimplCount"
361 -- We use one or the other consistently
362
363 pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n
364 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
365 = vcat [text "Total ticks: " <+> int tks,
366 blankLine,
367 pprTickCounts dts,
368 if verboseSimplStats then
369 vcat [blankLine,
370 text "Log (most recent first)",
371 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
372 else Outputable.empty
373 ]
374
375 pprTickCounts :: Map Tick Int -> SDoc
376 pprTickCounts counts
377 = vcat (map pprTickGroup groups)
378 where
379 groups :: [[(Tick,Int)]] -- Each group shares a comon tag
380 -- toList returns common tags adjacent
381 groups = runs same_tag (Map.toList counts)
382 same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
383
384 pprTickGroup :: [(Tick, Int)] -> SDoc
385 pprTickGroup group@((tick1,_):_)
386 = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
387 2 (vcat [ int n <+> pprTickCts tick
388 -- flip as we want largest first
389 | (tick,n) <- sortBy (flip (comparing snd)) group])
390 pprTickGroup [] = panic "pprTickGroup"
391
392 data Tick
393 = PreInlineUnconditionally Id
394 | PostInlineUnconditionally Id
395
396 | UnfoldingDone Id
397 | RuleFired FastString -- Rule name
398
399 | LetFloatFromLet
400 | EtaExpansion Id -- LHS binder
401 | EtaReduction Id -- Binder on outer lambda
402 | BetaReduction Id -- Lambda binder
403
404
405 | CaseOfCase Id -- Bndr on *inner* case
406 | KnownBranch Id -- Case binder
407 | CaseMerge Id -- Binder on outer case
408 | AltMerge Id -- Case binder
409 | CaseElim Id -- Case binder
410 | CaseIdentity Id -- Case binder
411 | FillInCaseDefault Id -- Case binder
412
413 | BottomFound
414 | SimplifierDone -- Ticked at each iteration of the simplifier
415
416 instance Outputable Tick where
417 ppr tick = text (tickString tick) <+> pprTickCts tick
418
419 instance Eq Tick where
420 a == b = case a `cmpTick` b of
421 EQ -> True
422 _ -> False
423
424 instance Ord Tick where
425 compare = cmpTick
426
427 tickToTag :: Tick -> Int
428 tickToTag (PreInlineUnconditionally _) = 0
429 tickToTag (PostInlineUnconditionally _) = 1
430 tickToTag (UnfoldingDone _) = 2
431 tickToTag (RuleFired _) = 3
432 tickToTag LetFloatFromLet = 4
433 tickToTag (EtaExpansion _) = 5
434 tickToTag (EtaReduction _) = 6
435 tickToTag (BetaReduction _) = 7
436 tickToTag (CaseOfCase _) = 8
437 tickToTag (KnownBranch _) = 9
438 tickToTag (CaseMerge _) = 10
439 tickToTag (CaseElim _) = 11
440 tickToTag (CaseIdentity _) = 12
441 tickToTag (FillInCaseDefault _) = 13
442 tickToTag BottomFound = 14
443 tickToTag SimplifierDone = 16
444 tickToTag (AltMerge _) = 17
445
446 tickString :: Tick -> String
447 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
448 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
449 tickString (UnfoldingDone _) = "UnfoldingDone"
450 tickString (RuleFired _) = "RuleFired"
451 tickString LetFloatFromLet = "LetFloatFromLet"
452 tickString (EtaExpansion _) = "EtaExpansion"
453 tickString (EtaReduction _) = "EtaReduction"
454 tickString (BetaReduction _) = "BetaReduction"
455 tickString (CaseOfCase _) = "CaseOfCase"
456 tickString (KnownBranch _) = "KnownBranch"
457 tickString (CaseMerge _) = "CaseMerge"
458 tickString (AltMerge _) = "AltMerge"
459 tickString (CaseElim _) = "CaseElim"
460 tickString (CaseIdentity _) = "CaseIdentity"
461 tickString (FillInCaseDefault _) = "FillInCaseDefault"
462 tickString BottomFound = "BottomFound"
463 tickString SimplifierDone = "SimplifierDone"
464
465 pprTickCts :: Tick -> SDoc
466 pprTickCts (PreInlineUnconditionally v) = ppr v
467 pprTickCts (PostInlineUnconditionally v)= ppr v
468 pprTickCts (UnfoldingDone v) = ppr v
469 pprTickCts (RuleFired v) = ppr v
470 pprTickCts LetFloatFromLet = Outputable.empty
471 pprTickCts (EtaExpansion v) = ppr v
472 pprTickCts (EtaReduction v) = ppr v
473 pprTickCts (BetaReduction v) = ppr v
474 pprTickCts (CaseOfCase v) = ppr v
475 pprTickCts (KnownBranch v) = ppr v
476 pprTickCts (CaseMerge v) = ppr v
477 pprTickCts (AltMerge v) = ppr v
478 pprTickCts (CaseElim v) = ppr v
479 pprTickCts (CaseIdentity v) = ppr v
480 pprTickCts (FillInCaseDefault v) = ppr v
481 pprTickCts _ = Outputable.empty
482
483 cmpTick :: Tick -> Tick -> Ordering
484 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
485 GT -> GT
486 EQ -> cmpEqTick a b
487 LT -> LT
488
489 cmpEqTick :: Tick -> Tick -> Ordering
490 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
491 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
492 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
493 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
494 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
495 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
496 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
497 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
498 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
499 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
500 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
501 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
502 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
503 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
504 cmpEqTick _ _ = EQ
505
506 {-
507 ************************************************************************
508 * *
509 Monad and carried data structure definitions
510 * *
511 ************************************************************************
512 -}
513
514 newtype CoreState = CoreState {
515 cs_uniq_supply :: UniqSupply
516 }
517
518 data CoreReader = CoreReader {
519 cr_hsc_env :: HscEnv,
520 cr_rule_base :: RuleBase,
521 cr_module :: Module,
522 cr_print_unqual :: PrintUnqualified,
523 cr_loc :: SrcSpan, -- Use this for log/error messages so they
524 -- are at least tagged with the right source file
525 cr_visible_orphan_mods :: !ModuleSet,
526 #ifdef GHCI
527 cr_globals :: (MVar PersistentLinkerState, Bool)
528 #else
529 cr_globals :: ()
530 #endif
531 }
532
533 -- Note: CoreWriter used to be defined with data, rather than newtype. If it
534 -- is defined that way again, the cw_simpl_count field, at least, must be
535 -- strict to avoid a space leak (Trac #7702).
536 newtype CoreWriter = CoreWriter {
537 cw_simpl_count :: SimplCount
538 }
539
540 emptyWriter :: DynFlags -> CoreWriter
541 emptyWriter dflags = CoreWriter {
542 cw_simpl_count = zeroSimplCount dflags
543 }
544
545 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
546 plusWriter w1 w2 = CoreWriter {
547 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
548 }
549
550 type CoreIOEnv = IOEnv CoreReader
551
552 -- | The monad used by Core-to-Core passes to access common state, register simplification
553 -- statistics and so on
554 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
555
556 instance Functor CoreM where
557 fmap = liftM
558
559 instance Monad CoreM where
560 mx >>= f = CoreM $ \s -> do
561 (x, s', w1) <- unCoreM mx s
562 (y, s'', w2) <- unCoreM (f x) s'
563 let w = w1 `plusWriter` w2
564 return $ seq w (y, s'', w)
565 -- forcing w before building the tuple avoids a space leak
566 -- (Trac #7702)
567
568 instance Applicative CoreM where
569 pure x = CoreM $ \s -> nop s x
570 (<*>) = ap
571 m *> k = m >>= \_ -> k
572
573 instance Alternative CoreM where
574 empty = CoreM (const Control.Applicative.empty)
575 m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs)
576
577 instance MonadPlus CoreM
578
579 instance MonadUnique CoreM where
580 getUniqueSupplyM = do
581 us <- getS cs_uniq_supply
582 let (us1, us2) = splitUniqSupply us
583 modifyS (\s -> s { cs_uniq_supply = us2 })
584 return us1
585
586 getUniqueM = do
587 us <- getS cs_uniq_supply
588 let (u,us') = takeUniqFromSupply us
589 modifyS (\s -> s { cs_uniq_supply = us' })
590 return u
591
592 runCoreM :: HscEnv
593 -> RuleBase
594 -> UniqSupply
595 -> Module
596 -> ModuleSet
597 -> PrintUnqualified
598 -> SrcSpan
599 -> CoreM a
600 -> IO (a, SimplCount)
601 runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
602 = do { glbls <- saveLinkerGlobals
603 ; liftM extract $ runIOEnv (reader glbls) $ unCoreM m state }
604 where
605 reader glbls = CoreReader {
606 cr_hsc_env = hsc_env,
607 cr_rule_base = rule_base,
608 cr_module = mod,
609 cr_visible_orphan_mods = orph_imps,
610 cr_globals = glbls,
611 cr_print_unqual = print_unqual,
612 cr_loc = loc
613 }
614 state = CoreState {
615 cs_uniq_supply = us
616 }
617
618 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
619 extract (value, _, writer) = (value, cw_simpl_count writer)
620
621 {-
622 ************************************************************************
623 * *
624 Core combinators, not exported
625 * *
626 ************************************************************************
627 -}
628
629 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
630 nop s x = do
631 r <- getEnv
632 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
633
634 read :: (CoreReader -> a) -> CoreM a
635 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
636
637 getS :: (CoreState -> a) -> CoreM a
638 getS f = CoreM (\s -> nop s (f s))
639
640 modifyS :: (CoreState -> CoreState) -> CoreM ()
641 modifyS f = CoreM (\s -> nop (f s) ())
642
643 write :: CoreWriter -> CoreM ()
644 write w = CoreM (\s -> return ((), s, w))
645
646 -- \subsection{Lifting IO into the monad}
647
648 -- | Lift an 'IOEnv' operation into 'CoreM'
649 liftIOEnv :: CoreIOEnv a -> CoreM a
650 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
651
652 instance MonadIO CoreM where
653 liftIO = liftIOEnv . IOEnv.liftIO
654
655 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
656 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
657 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
658
659 {-
660 ************************************************************************
661 * *
662 Reader, writer and state accessors
663 * *
664 ************************************************************************
665 -}
666
667 getHscEnv :: CoreM HscEnv
668 getHscEnv = read cr_hsc_env
669
670 getRuleBase :: CoreM RuleBase
671 getRuleBase = read cr_rule_base
672
673 getVisibleOrphanMods :: CoreM ModuleSet
674 getVisibleOrphanMods = read cr_visible_orphan_mods
675
676 getPrintUnqualified :: CoreM PrintUnqualified
677 getPrintUnqualified = read cr_print_unqual
678
679 getSrcSpanM :: CoreM SrcSpan
680 getSrcSpanM = read cr_loc
681
682 addSimplCount :: SimplCount -> CoreM ()
683 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
684
685 -- Convenience accessors for useful fields of HscEnv
686
687 instance HasDynFlags CoreM where
688 getDynFlags = fmap hsc_dflags getHscEnv
689
690 instance HasModule CoreM where
691 getModule = read cr_module
692
693 -- | The original name cache is the current mapping from 'Module' and
694 -- 'OccName' to a compiler-wide unique 'Name'
695 getOrigNameCache :: CoreM OrigNameCache
696 getOrigNameCache = do
697 nameCacheRef <- fmap hsc_NC getHscEnv
698 liftIO $ fmap nsNames $ readIORef nameCacheRef
699
700 getPackageFamInstEnv :: CoreM PackageFamInstEnv
701 getPackageFamInstEnv = do
702 hsc_env <- getHscEnv
703 eps <- liftIO $ hscEPS hsc_env
704 return $ eps_fam_inst_env eps
705
706 {-
707 ************************************************************************
708 * *
709 Initializing globals
710 * *
711 ************************************************************************
712
713 This is a rather annoying function. When a plugin is loaded, it currently
714 gets linked against a *newly loaded* copy of the GHC package. This would
715 not be a problem, except that the new copy has its own mutable state
716 that is not shared with that state that has already been initialized by
717 the original GHC package.
718
719 (NB This mechanism is sufficient for granting plugins read-only access to
720 globals that are guaranteed to be initialized before the plugin is loaded. If
721 any further synchronization is necessary, I would suggest using the more
722 sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to
723 share a single instance of the global variable among the compiler and the
724 plugins. Perhaps we should migrate all global variables to use that mechanism,
725 for robustness... -- NSF July 2013)
726
727 This leads to loaded plugins calling GHC code which pokes the static flags,
728 and then dying with a panic because the static flags *it* sees are uninitialized.
729
730 There are two possible solutions:
731 1. Export the symbols from the GHC executable from the GHC library and link
732 against this existing copy rather than a new copy of the GHC library
733 2. Carefully ensure that the global state in the two copies of the GHC
734 library matches
735
736 I tried 1. and it *almost* works (and speeds up plugin load times!) except
737 on Windows. On Windows the GHC library tends to export more than 65536 symbols
738 (see #5292) which overflows the limit of what we can export from the EXE and
739 causes breakage.
740
741 (Note that if the GHC executable was dynamically linked this wouldn't be a
742 problem, because we could share the GHC library it links to.)
743
744 We are going to try 2. instead. Unfortunately, this means that every plugin
745 will have to say `reinitializeGlobals` before it does anything, but never mind.
746
747 I've threaded the cr_globals through CoreM rather than giving them as an
748 argument to the plugin function so that we can turn this function into
749 (return ()) without breaking any plugins when we eventually get 1. working.
750 -}
751
752 reinitializeGlobals :: CoreM ()
753 reinitializeGlobals = do
754 linker_globals <- read cr_globals
755 hsc_env <- getHscEnv
756 let dflags = hsc_dflags hsc_env
757 liftIO $ restoreLinkerGlobals linker_globals
758 liftIO $ setUnsafeGlobalDynFlags dflags
759
760 {-
761 ************************************************************************
762 * *
763 Dealing with annotations
764 * *
765 ************************************************************************
766 -}
767
768 -- | Get all annotations of a given type. This happens lazily, that is
769 -- no deserialization will take place until the [a] is actually demanded and
770 -- the [a] can also be empty (the UniqFM is not filtered).
771 --
772 -- This should be done once at the start of a Core-to-Core pass that uses
773 -- annotations.
774 --
775 -- See Note [Annotations]
776 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
777 getAnnotations deserialize guts = do
778 hsc_env <- getHscEnv
779 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
780 return (deserializeAnns deserialize ann_env)
781
782 -- | Get at most one annotation of a given type per Unique.
783 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
784 getFirstAnnotations deserialize guts
785 = liftM (mapUFM head . filterUFM (not . null))
786 $ getAnnotations deserialize guts
787
788 {-
789 Note [Annotations]
790 ~~~~~~~~~~~~~~~~~~
791 A Core-to-Core pass that wants to make use of annotations calls
792 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
793 annotations of a specific type. This produces all annotations from interface
794 files read so far. However, annotations from interface files read during the
795 pass will not be visible until getAnnotations is called again. This is similar
796 to how rules work and probably isn't too bad.
797
798 The current implementation could be optimised a bit: when looking up
799 annotations for a thing from the HomePackageTable, we could search directly in
800 the module where the thing is defined rather than building one UniqFM which
801 contains all annotations we know of. This would work because annotations can
802 only be given to things defined in the same module. However, since we would
803 only want to deserialise every annotation once, we would have to build a cache
804 for every module in the HTP. In the end, it's probably not worth it as long as
805 we aren't using annotations heavily.
806
807 ************************************************************************
808 * *
809 Direct screen output
810 * *
811 ************************************************************************
812 -}
813
814 msg :: Severity -> SDoc -> CoreM ()
815 msg sev doc
816 = do { dflags <- getDynFlags
817 ; loc <- getSrcSpanM
818 ; unqual <- getPrintUnqualified
819 ; let sty = case sev of
820 SevError -> err_sty
821 SevWarning -> err_sty
822 SevDump -> dump_sty
823 _ -> user_sty
824 err_sty = mkErrStyle dflags unqual
825 user_sty = mkUserStyle unqual AllTheWay
826 dump_sty = mkDumpStyle unqual
827 ; liftIO $
828 (log_action dflags) dflags sev loc sty doc }
829
830 -- | Output a String message to the screen
831 putMsgS :: String -> CoreM ()
832 putMsgS = putMsg . text
833
834 -- | Output a message to the screen
835 putMsg :: SDoc -> CoreM ()
836 putMsg = msg SevInfo
837
838 -- | Output a string error to the screen
839 errorMsgS :: String -> CoreM ()
840 errorMsgS = errorMsg . text
841
842 -- | Output an error to the screen
843 errorMsg :: SDoc -> CoreM ()
844 errorMsg = msg SevError
845
846 warnMsg :: SDoc -> CoreM ()
847 warnMsg = msg SevWarning
848
849 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
850 fatalErrorMsgS :: String -> CoreM ()
851 fatalErrorMsgS = fatalErrorMsg . text
852
853 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
854 fatalErrorMsg :: SDoc -> CoreM ()
855 fatalErrorMsg = msg SevFatal
856
857 -- | Output a string debugging message at verbosity level of @-v@ or higher
858 debugTraceMsgS :: String -> CoreM ()
859 debugTraceMsgS = debugTraceMsg . text
860
861 -- | Outputs a debugging message at verbosity level of @-v@ or higher
862 debugTraceMsg :: SDoc -> CoreM ()
863 debugTraceMsg = msg SevDump
864
865 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
866 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
867 dumpIfSet_dyn flag str doc
868 = do { dflags <- getDynFlags
869 ; unqual <- getPrintUnqualified
870 ; when (dopt flag dflags) $ liftIO $
871 Err.dumpSDoc dflags unqual flag str doc }
872
873 {-
874 ************************************************************************
875 * *
876 Finding TyThings
877 * *
878 ************************************************************************
879 -}
880
881 instance MonadThings CoreM where
882 lookupThing name = do { hsc_env <- getHscEnv
883 ; liftIO $ lookupGlobal hsc_env name }
884
885 {-
886 ************************************************************************
887 * *
888 Template Haskell interoperability
889 * *
890 ************************************************************************
891 -}
892
893 #ifdef GHCI
894 -- | Attempt to convert a Template Haskell name to one that GHC can
895 -- understand. Original TH names such as those you get when you use
896 -- the @'foo@ syntax will be translated to their equivalent GHC name
897 -- exactly. Qualified or unqualifed TH names will be dynamically bound
898 -- to names in the module being compiled, if possible. Exact TH names
899 -- will be bound to the name they represent, exactly.
900 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
901 thNameToGhcName th_name = do
902 hsc_env <- getHscEnv
903 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
904 #endif