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