Filter orphan rules based on imports, fixes #10294 and #10420.
[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, UndecidableInstances #-}
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,
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,
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 #endif
61 import CoreSyn
62 import HscTypes
63 import Module
64 import DynFlags
65 import StaticFlags
66 import BasicTypes ( CompilerPhase(..) )
67 import Annotations
68
69 import IOEnv hiding ( liftIO, failM, failWithM )
70 import qualified IOEnv ( liftIO )
71 import TcEnv ( tcLookupGlobal )
72 import TcRnMonad ( initTcForLookup )
73 import Var
74 import Outputable
75 import FastString
76 import qualified ErrUtils as Err
77 import Maybes
78 import UniqSupply
79 import UniqFM ( UniqFM, mapUFM, filterUFM )
80 import MonadUtils
81
82 import ListSetOps ( runs )
83 import Data.List
84 import Data.Ord
85 import Data.Dynamic
86 import Data.IORef
87 import Data.Map (Map)
88 import qualified Data.Map as Map
89 import Data.Word
90 import qualified Control.Applicative as A
91 import Control.Monad
92
93 import Prelude hiding ( read )
94
95 #ifdef GHCI
96 import Control.Concurrent.MVar (MVar)
97 import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
98 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
99 import qualified Language.Haskell.TH as TH
100 #else
101 saveLinkerGlobals :: IO ()
102 saveLinkerGlobals = return ()
103
104 restoreLinkerGlobals :: () -> IO ()
105 restoreLinkerGlobals () = return ()
106 #endif
107
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 _ _) = ptext (sLit "Simplifier")
152 ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s
153 ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
154 ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
155 ppr CoreLiberateCase = ptext (sLit "Liberate case")
156 ppr CoreDoStaticArgs = ptext (sLit "Static argument")
157 ppr CoreDoCallArity = ptext (sLit "Called arity analysis")
158 ppr CoreDoStrictness = ptext (sLit "Demand analysis")
159 ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
160 ppr CoreDoSpecialising = ptext (sLit "Specialise")
161 ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
162 ppr CoreCSE = ptext (sLit "Common sub-expression")
163 ppr CoreDoVectorisation = ptext (sLit "Vectorisation")
164 ppr CoreDesugar = ptext (sLit "Desugar (before optimization)")
165 ppr CoreDesugarOpt = ptext (sLit "Desugar (after optimization)")
166 ppr CoreTidy = ptext (sLit "Tidy Core")
167 ppr CorePrep = ptext (sLit "CorePrep")
168 ppr CoreDoPrintCore = ptext (sLit "Print core")
169 ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
170 ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
171 ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
172
173 pprPassDetails :: CoreToDo -> SDoc
174 pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "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 = ptext (sLit "SimplMode") <+> braces (
193 sep [ ptext (sLit "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 (ptext (sLit "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 = ptext (sLit "FOS") <+> (braces $
224 sep $ punctuate comma $
225 [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw)
226 , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
227 , ptext (sLit "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) = ptext (sLit "Total ticks:") <+> int n
364 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
365 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
366 blankLine,
367 pprTickCounts dts,
368 if verboseSimplStats then
369 vcat [blankLine,
370 ptext (sLit "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_visible_orphan_mods :: !ModuleSet,
523 cr_print_unqual :: PrintUnqualified,
524 #ifdef GHCI
525 cr_globals :: (MVar PersistentLinkerState, Bool)
526 #else
527 cr_globals :: ()
528 #endif
529 }
530
531 -- Note: CoreWriter used to be defined with data, rather than newtype. If it
532 -- is defined that way again, the cw_simpl_count field, at least, must be
533 -- strict to avoid a space leak (Trac #7702).
534 newtype CoreWriter = CoreWriter {
535 cw_simpl_count :: SimplCount
536 }
537
538 emptyWriter :: DynFlags -> CoreWriter
539 emptyWriter dflags = CoreWriter {
540 cw_simpl_count = zeroSimplCount dflags
541 }
542
543 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
544 plusWriter w1 w2 = CoreWriter {
545 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
546 }
547
548 type CoreIOEnv = IOEnv CoreReader
549
550 -- | The monad used by Core-to-Core passes to access common state, register simplification
551 -- statistics and so on
552 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
553
554 instance Functor CoreM where
555 fmap f ma = do
556 a <- ma
557 return (f a)
558
559 instance Monad CoreM where
560 return x = CoreM (\s -> nop s x)
561 mx >>= f = CoreM $ \s -> do
562 (x, s', w1) <- unCoreM mx s
563 (y, s'', w2) <- unCoreM (f x) s'
564 let w = w1 `plusWriter` w2
565 return $ seq w (y, s'', w)
566 -- forcing w before building the tuple avoids a space leak
567 -- (Trac #7702)
568 instance A.Applicative CoreM where
569 pure = return
570 (<*>) = ap
571 (*>) = (>>)
572
573 instance MonadPlus IO => A.Alternative CoreM where
574 empty = mzero
575 (<|>) = mplus
576
577 -- For use if the user has imported Control.Monad.Error from MTL
578 -- Requires UndecidableInstances
579 instance MonadPlus IO => MonadPlus CoreM where
580 mzero = CoreM (const mzero)
581 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
582
583 instance MonadUnique CoreM where
584 getUniqueSupplyM = do
585 us <- getS cs_uniq_supply
586 let (us1, us2) = splitUniqSupply us
587 modifyS (\s -> s { cs_uniq_supply = us2 })
588 return us1
589
590 getUniqueM = do
591 us <- getS cs_uniq_supply
592 let (u,us') = takeUniqFromSupply us
593 modifyS (\s -> s { cs_uniq_supply = us' })
594 return u
595
596 runCoreM :: HscEnv
597 -> RuleBase
598 -> UniqSupply
599 -> Module
600 -> ModuleSet
601 -> PrintUnqualified
602 -> CoreM a
603 -> IO (a, SimplCount)
604 runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do
605 glbls <- saveLinkerGlobals
606 liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
607 where
608 reader glbls = CoreReader {
609 cr_hsc_env = hsc_env,
610 cr_rule_base = rule_base,
611 cr_module = mod,
612 cr_visible_orphan_mods = orph_imps,
613 cr_globals = glbls,
614 cr_print_unqual = print_unqual
615 }
616 state = CoreState {
617 cs_uniq_supply = us
618 }
619
620 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
621 extract (value, _, writer) = (value, cw_simpl_count writer)
622
623 {-
624 ************************************************************************
625 * *
626 Core combinators, not exported
627 * *
628 ************************************************************************
629 -}
630
631 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
632 nop s x = do
633 r <- getEnv
634 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
635
636 read :: (CoreReader -> a) -> CoreM a
637 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
638
639 getS :: (CoreState -> a) -> CoreM a
640 getS f = CoreM (\s -> nop s (f s))
641
642 modifyS :: (CoreState -> CoreState) -> CoreM ()
643 modifyS f = CoreM (\s -> nop (f s) ())
644
645 write :: CoreWriter -> CoreM ()
646 write w = CoreM (\s -> return ((), s, w))
647
648 -- \subsection{Lifting IO into the monad}
649
650 -- | Lift an 'IOEnv' operation into 'CoreM'
651 liftIOEnv :: CoreIOEnv a -> CoreM a
652 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
653
654 instance MonadIO CoreM where
655 liftIO = liftIOEnv . IOEnv.liftIO
656
657 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
658 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
659 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
660
661 {-
662 ************************************************************************
663 * *
664 Reader, writer and state accessors
665 * *
666 ************************************************************************
667 -}
668
669 getHscEnv :: CoreM HscEnv
670 getHscEnv = read cr_hsc_env
671
672 getRuleBase :: CoreM RuleBase
673 getRuleBase = read cr_rule_base
674
675 getVisibleOrphanMods :: CoreM ModuleSet
676 getVisibleOrphanMods = read cr_visible_orphan_mods
677
678 getPrintUnqualified :: CoreM PrintUnqualified
679 getPrintUnqualified = read cr_print_unqual
680
681 addSimplCount :: SimplCount -> CoreM ()
682 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
683
684 -- Convenience accessors for useful fields of HscEnv
685
686 instance HasDynFlags CoreM where
687 getDynFlags = fmap hsc_dflags getHscEnv
688
689 instance HasModule CoreM where
690 getModule = read cr_module
691
692 -- | The original name cache is the current mapping from 'Module' and
693 -- 'OccName' to a compiler-wide unique 'Name'
694 getOrigNameCache :: CoreM OrigNameCache
695 getOrigNameCache = do
696 nameCacheRef <- fmap hsc_NC getHscEnv
697 liftIO $ fmap nsNames $ readIORef nameCacheRef
698
699 getPackageFamInstEnv :: CoreM PackageFamInstEnv
700 getPackageFamInstEnv = do
701 hsc_env <- getHscEnv
702 eps <- liftIO $ hscEPS hsc_env
703 return $ eps_fam_inst_env eps
704
705 {-
706 ************************************************************************
707 * *
708 Initializing globals
709 * *
710 ************************************************************************
711
712 This is a rather annoying function. When a plugin is loaded, it currently
713 gets linked against a *newly loaded* copy of the GHC package. This would
714 not be a problem, except that the new copy has its own mutable state
715 that is not shared with that state that has already been initialized by
716 the original GHC package.
717
718 (NB This mechanism is sufficient for granting plugins read-only access to
719 globals that are guaranteed to be initialized before the plugin is loaded. If
720 any further synchronization is necessary, I would suggest using the more
721 sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to
722 share a single instance of the global variable among the compiler and the
723 plugins. Perhaps we should migrate all global variables to use that mechanism,
724 for robustness... -- NSF July 2013)
725
726 This leads to loaded plugins calling GHC code which pokes the static flags,
727 and then dying with a panic because the static flags *it* sees are uninitialized.
728
729 There are two possible solutions:
730 1. Export the symbols from the GHC executable from the GHC library and link
731 against this existing copy rather than a new copy of the GHC library
732 2. Carefully ensure that the global state in the two copies of the GHC
733 library matches
734
735 I tried 1. and it *almost* works (and speeds up plugin load times!) except
736 on Windows. On Windows the GHC library tends to export more than 65536 symbols
737 (see #5292) which overflows the limit of what we can export from the EXE and
738 causes breakage.
739
740 (Note that if the GHC executable was dynamically linked this wouldn't be a
741 problem, because we could share the GHC library it links to.)
742
743 We are going to try 2. instead. Unfortunately, this means that every plugin
744 will have to say `reinitializeGlobals` before it does anything, but never mind.
745
746 I've threaded the cr_globals through CoreM rather than giving them as an
747 argument to the plugin function so that we can turn this function into
748 (return ()) without breaking any plugins when we eventually get 1. working.
749 -}
750
751 reinitializeGlobals :: CoreM ()
752 reinitializeGlobals = do
753 linker_globals <- read cr_globals
754 hsc_env <- getHscEnv
755 let dflags = hsc_dflags hsc_env
756 liftIO $ restoreLinkerGlobals linker_globals
757 liftIO $ setUnsafeGlobalDynFlags dflags
758
759 {-
760 ************************************************************************
761 * *
762 Dealing with annotations
763 * *
764 ************************************************************************
765 -}
766
767 -- | Get all annotations of a given type. This happens lazily, that is
768 -- no deserialization will take place until the [a] is actually demanded and
769 -- the [a] can also be empty (the UniqFM is not filtered).
770 --
771 -- This should be done once at the start of a Core-to-Core pass that uses
772 -- annotations.
773 --
774 -- See Note [Annotations]
775 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
776 getAnnotations deserialize guts = do
777 hsc_env <- getHscEnv
778 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
779 return (deserializeAnns deserialize ann_env)
780
781 -- | Get at most one annotation of a given type per Unique.
782 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
783 getFirstAnnotations deserialize guts
784 = liftM (mapUFM head . filterUFM (not . null))
785 $ getAnnotations deserialize guts
786
787 {-
788 Note [Annotations]
789 ~~~~~~~~~~~~~~~~~~
790 A Core-to-Core pass that wants to make use of annotations calls
791 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
792 annotations of a specific type. This produces all annotations from interface
793 files read so far. However, annotations from interface files read during the
794 pass will not be visible until getAnnotations is called again. This is similar
795 to how rules work and probably isn't too bad.
796
797 The current implementation could be optimised a bit: when looking up
798 annotations for a thing from the HomePackageTable, we could search directly in
799 the module where the thing is defined rather than building one UniqFM which
800 contains all annotations we know of. This would work because annotations can
801 only be given to things defined in the same module. However, since we would
802 only want to deserialise every annotation once, we would have to build a cache
803 for every module in the HTP. In the end, it's probably not worth it as long as
804 we aren't using annotations heavily.
805
806 ************************************************************************
807 * *
808 Direct screen output
809 * *
810 ************************************************************************
811 -}
812
813 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
814 msg how doc = do
815 dflags <- getDynFlags
816 liftIO $ how dflags doc
817
818 -- | Output a String message to the screen
819 putMsgS :: String -> CoreM ()
820 putMsgS = putMsg . text
821
822 -- | Output a message to the screen
823 putMsg :: SDoc -> CoreM ()
824 putMsg = msg Err.putMsg
825
826 -- | Output a string error to the screen
827 errorMsgS :: String -> CoreM ()
828 errorMsgS = errorMsg . text
829
830 -- | Output an error to the screen
831 errorMsg :: SDoc -> CoreM ()
832 errorMsg = msg Err.errorMsg
833
834 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
835 fatalErrorMsgS :: String -> CoreM ()
836 fatalErrorMsgS = fatalErrorMsg . text
837
838 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
839 fatalErrorMsg :: SDoc -> CoreM ()
840 fatalErrorMsg = msg Err.fatalErrorMsg
841
842 -- | Output a string debugging message at verbosity level of @-v@ or higher
843 debugTraceMsgS :: String -> CoreM ()
844 debugTraceMsgS = debugTraceMsg . text
845
846 -- | Outputs a debugging message at verbosity level of @-v@ or higher
847 debugTraceMsg :: SDoc -> CoreM ()
848 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
849
850 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
851 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
852 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
853
854 {-
855 ************************************************************************
856 * *
857 Finding TyThings
858 * *
859 ************************************************************************
860 -}
861
862 instance MonadThings CoreM where
863 lookupThing name = do
864 hsc_env <- getHscEnv
865 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
866
867 {-
868 ************************************************************************
869 * *
870 Template Haskell interoperability
871 * *
872 ************************************************************************
873 -}
874
875 #ifdef GHCI
876 -- | Attempt to convert a Template Haskell name to one that GHC can
877 -- understand. Original TH names such as those you get when you use
878 -- the @'foo@ syntax will be translated to their equivalent GHC name
879 -- exactly. Qualified or unqualifed TH names will be dynamically bound
880 -- to names in the module being compiled, if possible. Exact TH names
881 -- will be bound to the name they represent, exactly.
882 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
883 thNameToGhcName th_name = do
884 hsc_env <- getHscEnv
885 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
886 #endif