Allow proper errors/warnings in core2core passes
[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 #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 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 f ma = do
559 a <- ma
560 return (f a)
561
562 instance Monad CoreM where
563 return x = CoreM (\s -> nop s x)
564 mx >>= f = CoreM $ \s -> do
565 (x, s', w1) <- unCoreM mx s
566 (y, s'', w2) <- unCoreM (f x) s'
567 let w = w1 `plusWriter` w2
568 return $ seq w (y, s'', w)
569 -- forcing w before building the tuple avoids a space leak
570 -- (Trac #7702)
571 instance A.Applicative CoreM where
572 pure = return
573 (<*>) = ap
574 (*>) = (>>)
575
576 instance MonadPlus IO => A.Alternative CoreM where
577 empty = mzero
578 (<|>) = mplus
579
580 -- For use if the user has imported Control.Monad.Error from MTL
581 -- Requires UndecidableInstances
582 instance MonadPlus IO => MonadPlus CoreM where
583 mzero = CoreM (const mzero)
584 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
585
586 instance MonadUnique CoreM where
587 getUniqueSupplyM = do
588 us <- getS cs_uniq_supply
589 let (us1, us2) = splitUniqSupply us
590 modifyS (\s -> s { cs_uniq_supply = us2 })
591 return us1
592
593 getUniqueM = do
594 us <- getS cs_uniq_supply
595 let (u,us') = takeUniqFromSupply us
596 modifyS (\s -> s { cs_uniq_supply = us' })
597 return u
598
599 runCoreM :: HscEnv
600 -> RuleBase
601 -> UniqSupply
602 -> Module
603 -> ModuleSet
604 -> PrintUnqualified
605 -> SrcSpan
606 -> CoreM a
607 -> IO (a, SimplCount)
608 runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
609 = do { glbls <- saveLinkerGlobals
610 ; liftM extract $ runIOEnv (reader glbls) $ unCoreM m state }
611 where
612 reader glbls = CoreReader {
613 cr_hsc_env = hsc_env,
614 cr_rule_base = rule_base,
615 cr_module = mod,
616 cr_visible_orphan_mods = orph_imps,
617 cr_globals = glbls,
618 cr_print_unqual = print_unqual,
619 cr_loc = loc
620 }
621 state = CoreState {
622 cs_uniq_supply = us
623 }
624
625 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
626 extract (value, _, writer) = (value, cw_simpl_count writer)
627
628 {-
629 ************************************************************************
630 * *
631 Core combinators, not exported
632 * *
633 ************************************************************************
634 -}
635
636 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
637 nop s x = do
638 r <- getEnv
639 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
640
641 read :: (CoreReader -> a) -> CoreM a
642 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
643
644 getS :: (CoreState -> a) -> CoreM a
645 getS f = CoreM (\s -> nop s (f s))
646
647 modifyS :: (CoreState -> CoreState) -> CoreM ()
648 modifyS f = CoreM (\s -> nop (f s) ())
649
650 write :: CoreWriter -> CoreM ()
651 write w = CoreM (\s -> return ((), s, w))
652
653 -- \subsection{Lifting IO into the monad}
654
655 -- | Lift an 'IOEnv' operation into 'CoreM'
656 liftIOEnv :: CoreIOEnv a -> CoreM a
657 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
658
659 instance MonadIO CoreM where
660 liftIO = liftIOEnv . IOEnv.liftIO
661
662 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
663 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
664 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
665
666 {-
667 ************************************************************************
668 * *
669 Reader, writer and state accessors
670 * *
671 ************************************************************************
672 -}
673
674 getHscEnv :: CoreM HscEnv
675 getHscEnv = read cr_hsc_env
676
677 getRuleBase :: CoreM RuleBase
678 getRuleBase = read cr_rule_base
679
680 getVisibleOrphanMods :: CoreM ModuleSet
681 getVisibleOrphanMods = read cr_visible_orphan_mods
682
683 getPrintUnqualified :: CoreM PrintUnqualified
684 getPrintUnqualified = read cr_print_unqual
685
686 getSrcSpanM :: CoreM SrcSpan
687 getSrcSpanM = read cr_loc
688
689 addSimplCount :: SimplCount -> CoreM ()
690 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
691
692 -- Convenience accessors for useful fields of HscEnv
693
694 instance HasDynFlags CoreM where
695 getDynFlags = fmap hsc_dflags getHscEnv
696
697 instance HasModule CoreM where
698 getModule = read cr_module
699
700 -- | The original name cache is the current mapping from 'Module' and
701 -- 'OccName' to a compiler-wide unique 'Name'
702 getOrigNameCache :: CoreM OrigNameCache
703 getOrigNameCache = do
704 nameCacheRef <- fmap hsc_NC getHscEnv
705 liftIO $ fmap nsNames $ readIORef nameCacheRef
706
707 getPackageFamInstEnv :: CoreM PackageFamInstEnv
708 getPackageFamInstEnv = do
709 hsc_env <- getHscEnv
710 eps <- liftIO $ hscEPS hsc_env
711 return $ eps_fam_inst_env eps
712
713 {-
714 ************************************************************************
715 * *
716 Initializing globals
717 * *
718 ************************************************************************
719
720 This is a rather annoying function. When a plugin is loaded, it currently
721 gets linked against a *newly loaded* copy of the GHC package. This would
722 not be a problem, except that the new copy has its own mutable state
723 that is not shared with that state that has already been initialized by
724 the original GHC package.
725
726 (NB This mechanism is sufficient for granting plugins read-only access to
727 globals that are guaranteed to be initialized before the plugin is loaded. If
728 any further synchronization is necessary, I would suggest using the more
729 sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to
730 share a single instance of the global variable among the compiler and the
731 plugins. Perhaps we should migrate all global variables to use that mechanism,
732 for robustness... -- NSF July 2013)
733
734 This leads to loaded plugins calling GHC code which pokes the static flags,
735 and then dying with a panic because the static flags *it* sees are uninitialized.
736
737 There are two possible solutions:
738 1. Export the symbols from the GHC executable from the GHC library and link
739 against this existing copy rather than a new copy of the GHC library
740 2. Carefully ensure that the global state in the two copies of the GHC
741 library matches
742
743 I tried 1. and it *almost* works (and speeds up plugin load times!) except
744 on Windows. On Windows the GHC library tends to export more than 65536 symbols
745 (see #5292) which overflows the limit of what we can export from the EXE and
746 causes breakage.
747
748 (Note that if the GHC executable was dynamically linked this wouldn't be a
749 problem, because we could share the GHC library it links to.)
750
751 We are going to try 2. instead. Unfortunately, this means that every plugin
752 will have to say `reinitializeGlobals` before it does anything, but never mind.
753
754 I've threaded the cr_globals through CoreM rather than giving them as an
755 argument to the plugin function so that we can turn this function into
756 (return ()) without breaking any plugins when we eventually get 1. working.
757 -}
758
759 reinitializeGlobals :: CoreM ()
760 reinitializeGlobals = do
761 linker_globals <- read cr_globals
762 hsc_env <- getHscEnv
763 let dflags = hsc_dflags hsc_env
764 liftIO $ restoreLinkerGlobals linker_globals
765 liftIO $ setUnsafeGlobalDynFlags dflags
766
767 {-
768 ************************************************************************
769 * *
770 Dealing with annotations
771 * *
772 ************************************************************************
773 -}
774
775 -- | Get all annotations of a given type. This happens lazily, that is
776 -- no deserialization will take place until the [a] is actually demanded and
777 -- the [a] can also be empty (the UniqFM is not filtered).
778 --
779 -- This should be done once at the start of a Core-to-Core pass that uses
780 -- annotations.
781 --
782 -- See Note [Annotations]
783 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
784 getAnnotations deserialize guts = do
785 hsc_env <- getHscEnv
786 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
787 return (deserializeAnns deserialize ann_env)
788
789 -- | Get at most one annotation of a given type per Unique.
790 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
791 getFirstAnnotations deserialize guts
792 = liftM (mapUFM head . filterUFM (not . null))
793 $ getAnnotations deserialize guts
794
795 {-
796 Note [Annotations]
797 ~~~~~~~~~~~~~~~~~~
798 A Core-to-Core pass that wants to make use of annotations calls
799 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
800 annotations of a specific type. This produces all annotations from interface
801 files read so far. However, annotations from interface files read during the
802 pass will not be visible until getAnnotations is called again. This is similar
803 to how rules work and probably isn't too bad.
804
805 The current implementation could be optimised a bit: when looking up
806 annotations for a thing from the HomePackageTable, we could search directly in
807 the module where the thing is defined rather than building one UniqFM which
808 contains all annotations we know of. This would work because annotations can
809 only be given to things defined in the same module. However, since we would
810 only want to deserialise every annotation once, we would have to build a cache
811 for every module in the HTP. In the end, it's probably not worth it as long as
812 we aren't using annotations heavily.
813
814 ************************************************************************
815 * *
816 Direct screen output
817 * *
818 ************************************************************************
819 -}
820
821 msg :: Severity -> SDoc -> CoreM ()
822 msg sev doc
823 = do { dflags <- getDynFlags
824 ; loc <- getSrcSpanM
825 ; unqual <- getPrintUnqualified
826 ; let sty = case sev of
827 SevError -> err_sty
828 SevWarning -> err_sty
829 SevDump -> dump_sty
830 _ -> user_sty
831 err_sty = mkErrStyle dflags unqual
832 user_sty = mkUserStyle unqual AllTheWay
833 dump_sty = mkDumpStyle unqual
834 ; liftIO $
835 (log_action dflags) dflags sev loc sty doc }
836
837 -- | Output a String message to the screen
838 putMsgS :: String -> CoreM ()
839 putMsgS = putMsg . text
840
841 -- | Output a message to the screen
842 putMsg :: SDoc -> CoreM ()
843 putMsg = msg SevInfo
844
845 -- | Output a string error to the screen
846 errorMsgS :: String -> CoreM ()
847 errorMsgS = errorMsg . text
848
849 -- | Output an error to the screen
850 errorMsg :: SDoc -> CoreM ()
851 errorMsg = msg SevError
852
853 warnMsg :: SDoc -> CoreM ()
854 warnMsg = msg SevWarning
855
856 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
857 fatalErrorMsgS :: String -> CoreM ()
858 fatalErrorMsgS = fatalErrorMsg . text
859
860 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
861 fatalErrorMsg :: SDoc -> CoreM ()
862 fatalErrorMsg = msg SevFatal
863
864 -- | Output a string debugging message at verbosity level of @-v@ or higher
865 debugTraceMsgS :: String -> CoreM ()
866 debugTraceMsgS = debugTraceMsg . text
867
868 -- | Outputs a debugging message at verbosity level of @-v@ or higher
869 debugTraceMsg :: SDoc -> CoreM ()
870 debugTraceMsg = msg SevDump
871
872 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
873 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
874 dumpIfSet_dyn flag str doc
875 = do { dflags <- getDynFlags
876 ; unqual <- getPrintUnqualified
877 ; when (dopt flag dflags) $ liftIO $
878 Err.dumpSDoc dflags unqual flag str doc }
879
880 {-
881 ************************************************************************
882 * *
883 Finding TyThings
884 * *
885 ************************************************************************
886 -}
887
888 instance MonadThings CoreM where
889 lookupThing name = do
890 hsc_env <- getHscEnv
891 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
892
893 {-
894 ************************************************************************
895 * *
896 Template Haskell interoperability
897 * *
898 ************************************************************************
899 -}
900
901 #ifdef GHCI
902 -- | Attempt to convert a Template Haskell name to one that GHC can
903 -- understand. Original TH names such as those you get when you use
904 -- the @'foo@ syntax will be translated to their equivalent GHC name
905 -- exactly. Qualified or unqualifed TH names will be dynamically bound
906 -- to names in the module being compiled, if possible. Exact TH names
907 -- will be bound to the name they represent, exactly.
908 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
909 thNameToGhcName th_name = do
910 hsc_env <- getHscEnv
911 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
912 #endif