Move all the CoreToDo stuff into CoreMonad
[ghc.git] / compiler / simplCore / CoreMonad.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[CoreMonad]{The core pipeline monad}
5
6 \begin{code}
7 {-# LANGUAGE UndecidableInstances #-}
8
9 module CoreMonad (
10     -- * Configuration of the core-to-core passes
11     CoreToDo(..),
12     SimplifierMode(..),
13     SimplifierSwitch(..),
14     FloatOutSwitches(..),
15     getCoreToDo, dumpSimplPhase,
16
17     -- * Counting
18     SimplCount, doSimplTick, doFreeSimplTick,
19     pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
20
21     -- * The monad
22     CoreM, runCoreM,
23     
24     -- ** Reading from the monad
25     getHscEnv, getRuleBase, getModule,
26     getDynFlags, getOrigNameCache,
27     
28     -- ** Writing to the monad
29     addSimplCount,
30     
31     -- ** Lifting into the monad
32     liftIO, liftIOWithCount,
33     liftIO1, liftIO2, liftIO3, liftIO4,
34     
35     -- ** Dealing with annotations
36     getAnnotations, getFirstAnnotations,
37     
38     -- ** Debug output
39     endPass, endPassIf, endIteration,
40
41     -- ** Screen output
42     putMsg, putMsgS, errorMsg, errorMsgS, 
43     fatalErrorMsg, fatalErrorMsgS, 
44     debugTraceMsg, debugTraceMsgS,
45     dumpIfSet_dyn,
46
47 #ifdef GHCI
48     -- * Getting 'Name's
49     thNameToGhcName
50 #endif
51   ) where
52
53 #ifdef GHCI
54 import Name( Name )
55 #endif
56 import CoreSyn
57 import PprCore
58 import CoreUtils
59 import CoreLint         ( lintCoreBindings )
60 import PrelNames        ( iNTERACTIVE )
61 import HscTypes
62 import Module           ( PackageId, Module )
63 import DynFlags
64 import StaticFlags      
65 import Rules            ( RuleBase )
66 import BasicTypes       ( CompilerPhase )
67 import Annotations
68 import Id               ( Id )
69
70 import IOEnv hiding     ( liftIO, failM, failWithM )
71 import qualified IOEnv  ( liftIO )
72 import TcEnv            ( tcLookupGlobal )
73 import TcRnMonad        ( TcM, initTc )
74
75 import Outputable
76 import FastString
77 import qualified ErrUtils as Err
78 import Maybes
79 import UniqSupply
80 import LazyUniqFM       ( UniqFM, mapUFM, filterUFM )
81 import FiniteMap
82
83 import Util             ( split )
84 import Data.List        ( intersperse )
85 import Data.Dynamic
86 import Data.IORef
87 import Data.Word
88 import Control.Monad
89
90 import Prelude hiding   ( read )
91
92 #ifdef GHCI
93 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
94 import qualified Language.Haskell.TH as TH
95 #endif
96 \end{code}
97
98 %************************************************************************
99 %*                                                                      *
100                        Debug output
101 %*                                                                      *
102 %************************************************************************
103
104 These functions are not CoreM monad stuff, but they probably ought to
105 be, and it makes a conveneint place.  place for them.  They print out
106 stuff before and after core passes, and do Core Lint when necessary.
107
108 \begin{code}
109 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
110 endPass = dumpAndLint Err.dumpIfSet_core
111
112 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
113 endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
114
115 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
116 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
117 endIteration = dumpAndLint Err.dumpIfSet_dyn
118
119 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
120             -> DynFlags -> String -> DynFlag 
121             -> [CoreBind] -> [CoreRule] -> IO ()
122 dumpAndLint dump dflags pass_name dump_flag binds rules
123   = do {  -- Report result size if required
124           -- This has the side effect of forcing the intermediate to be evaluated
125        ; Err.debugTraceMsg dflags 2 $
126                 (text "    Result size =" <+> int (coreBindsSize binds))
127
128         -- Report verbosely, if required
129        ; dump dflags dump_flag pass_name
130               (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
131
132         -- Type check
133        ; lintCoreBindings dflags pass_name binds }
134   where
135     pp_rules = vcat [ blankLine
136                     , ptext (sLit "------ Local rules for imported ids --------")
137                     , pprRules rules ]
138 \end{code}
139
140
141 %************************************************************************
142 %*                                                                      *
143               The CoreToDo type and related types
144           Abstraction of core-to-core passes to run.
145 %*                                                                      *
146 %************************************************************************
147
148 \begin{code}
149 data CoreToDo           -- These are diff core-to-core passes,
150                         -- which may be invoked in any order,
151                         -- as many times as you like.
152
153   = CoreDoSimplify      -- The core-to-core simplifier.
154         SimplifierMode
155         [SimplifierSwitch]
156                         -- Each run of the simplifier can take a different
157                         -- set of simplifier-specific flags.
158   | CoreDoFloatInwards
159   | CoreDoFloatOutwards FloatOutSwitches
160   | CoreLiberateCase
161   | CoreDoPrintCore
162   | CoreDoStaticArgs
163   | CoreDoStrictness
164   | CoreDoWorkerWrapper
165   | CoreDoSpecialising
166   | CoreDoSpecConstr
167   | CoreDoOldStrictness
168   | CoreDoGlomBinds
169   | CoreCSE
170   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
171                                            -- matching this string
172   | CoreDoVectorisation PackageId
173   | CoreDoNothing                -- Useful when building up
174   | CoreDoPasses [CoreToDo]      -- lists of these things
175
176
177 data SimplifierMode             -- See comments in SimplMonad
178   = SimplGently
179         { sm_rules :: Bool      -- Whether RULES are enabled 
180         , sm_inline :: Bool }   -- Whether inlining is enabled
181
182   | SimplPhase 
183         { sm_num :: Int           -- Phase number; counts downward so 0 is last phase
184         , sm_names :: [String] }  -- Name(s) of the phase
185
186 instance Outputable SimplifierMode where
187     ppr (SimplPhase { sm_num = n, sm_names = ss })
188        = int n <+> brackets (text (concat $ intersperse "," ss))
189     ppr (SimplGently { sm_rules = r, sm_inline = i }) 
190        = ptext (sLit "gentle") <> 
191            brackets (pp_flag r (sLit "rules") <> comma <>
192                      pp_flag i (sLit "inline"))
193          where
194            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
195
196 data SimplifierSwitch
197   = MaxSimplifierIterations Int
198   | NoCaseOfCase
199
200 data FloatOutSwitches = FloatOutSwitches {
201         floatOutLambdas :: Bool,     -- ^ True <=> float lambdas to top level
202         floatOutConstants :: Bool    -- ^ True <=> float constants to top level,
203                                      --            even if they do not escape a lambda
204     }
205
206 instance Outputable FloatOutSwitches where
207     ppr = pprFloatOutSwitches
208
209 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
210 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
211                      <+> pp_not (floatOutConstants sw) <+> text "constants"
212   where
213     pp_not True  = empty
214     pp_not False = text "not"
215
216 -- | Switches that specify the minimum amount of floating out
217 -- gentleFloatOutSwitches :: FloatOutSwitches
218 -- gentleFloatOutSwitches = FloatOutSwitches False False
219
220 -- | Switches that do not specify floating out of lambdas, just of constants
221 constantsOnlyFloatOutSwitches :: FloatOutSwitches
222 constantsOnlyFloatOutSwitches = FloatOutSwitches False True
223 \end{code}
224
225
226 %************************************************************************
227 %*                                                                      *
228            Generating the main optimisation pipeline
229 %*                                                                      *
230 %************************************************************************
231
232 \begin{code}
233 getCoreToDo :: DynFlags -> [CoreToDo]
234 getCoreToDo dflags
235   = core_todo
236   where
237     opt_level     = optLevel dflags
238     phases        = simplPhases dflags
239     max_iter      = maxSimplIterations dflags
240     strictness    = dopt Opt_Strictness dflags
241     full_laziness = dopt Opt_FullLaziness dflags
242     do_specialise = dopt Opt_Specialise dflags
243     do_float_in   = dopt Opt_FloatIn dflags
244     cse           = dopt Opt_CSE dflags
245     spec_constr   = dopt Opt_SpecConstr dflags
246     liberate_case = dopt Opt_LiberateCase dflags
247     rule_check    = ruleCheck dflags
248     static_args   = dopt Opt_StaticArgumentTransformation dflags
249
250     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
251
252     maybe_strictness_before phase
253       = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
254
255     simpl_phase phase names iter
256       = CoreDoPasses
257           [ maybe_strictness_before phase,
258             CoreDoSimplify (SimplPhase phase names) [
259               MaxSimplifierIterations iter
260             ],
261             maybe_rule_check phase
262           ]
263
264     vectorisation
265       = runWhen (dopt Opt_Vectorise dflags)
266         $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
267
268
269                 -- By default, we have 2 phases before phase 0.
270
271                 -- Want to run with inline phase 2 after the specialiser to give
272                 -- maximum chance for fusion to work before we inline build/augment
273                 -- in phase 1.  This made a difference in 'ansi' where an
274                 -- overloaded function wasn't inlined till too late.
275
276                 -- Need phase 1 so that build/augment get
277                 -- inlined.  I found that spectral/hartel/genfft lost some useful
278                 -- strictness in the function sumcode' if augment is not inlined
279                 -- before strictness analysis runs
280     simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
281                                   | phase <- [phases, phases-1 .. 1] ]
282
283
284         -- initial simplify: mk specialiser happy: minimum effort please
285     simpl_gently = CoreDoSimplify 
286                        (SimplGently { sm_rules = True, sm_inline = False })
287                        [
288                         --      Simplify "gently"
289                         -- Don't inline anything till full laziness has bitten
290                         -- In particular, inlining wrappers inhibits floating
291                         -- e.g. ...(case f x of ...)...
292                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
293                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
294                         -- and now the redex (f x) isn't floatable any more
295                         -- Similarly, don't apply any rules until after full
296                         -- laziness.  Notably, list fusion can prevent floating.
297
298             NoCaseOfCase,       -- Don't do case-of-case transformations.
299                                 -- This makes full laziness work better
300             MaxSimplifierIterations max_iter
301         ]
302
303     core_todo =
304      if opt_level == 0 then
305        [vectorisation,
306         simpl_phase 0 ["final"] max_iter]
307      else {- opt_level >= 1 -} [
308
309     -- We want to do the static argument transform before full laziness as it
310     -- may expose extra opportunities to float things outwards. However, to fix
311     -- up the output of the transformation we need at do at least one simplify
312     -- after this before anything else
313         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
314
315         -- We run vectorisation here for now, but we might also try to run
316         -- it later
317         vectorisation,
318
319         -- initial simplify: mk specialiser happy: minimum effort please
320         simpl_gently,
321
322         -- Specialisation is best done before full laziness
323         -- so that overloaded functions have all their dictionary lambdas manifest
324         runWhen do_specialise CoreDoSpecialising,
325
326         runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
327                 -- Was: gentleFloatOutSwitches  
328                 -- I have no idea why, but not floating constants to top level is
329                 -- very bad in some cases. 
330                 -- Notably: p_ident in spectral/rewrite
331                 --          Changing from "gentle" to "constantsOnly" improved
332                 --          rewrite's allocation by 19%, and made  0.0% difference
333                 --          to any other nofib benchmark
334
335         runWhen do_float_in CoreDoFloatInwards,
336
337         simpl_phases,
338
339                 -- Phase 0: allow all Ids to be inlined now
340                 -- This gets foldr inlined before strictness analysis
341
342                 -- At least 3 iterations because otherwise we land up with
343                 -- huge dead expressions because of an infelicity in the
344                 -- simpifier.
345                 --      let k = BIG in foldr k z xs
346                 -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
347                 -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
348                 -- Don't stop now!
349         simpl_phase 0 ["main"] (max max_iter 3),
350
351         runWhen strictness (CoreDoPasses [
352                 CoreDoStrictness,
353                 CoreDoWorkerWrapper,
354                 CoreDoGlomBinds,
355                 simpl_phase 0 ["post-worker-wrapper"] max_iter
356                 ]),
357
358         runWhen full_laziness
359           (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
360                 -- nofib/spectral/hartel/wang doubles in speed if you
361                 -- do full laziness late in the day.  It only happens
362                 -- after fusion and other stuff, so the early pass doesn't
363                 -- catch it.  For the record, the redex is
364                 --        f_el22 (f_el21 r_midblock)
365
366
367         runWhen cse CoreCSE,
368                 -- We want CSE to follow the final full-laziness pass, because it may
369                 -- succeed in commoning up things floated out by full laziness.
370                 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
371
372         runWhen do_float_in CoreDoFloatInwards,
373
374         maybe_rule_check 0,
375
376                 -- Case-liberation for -O2.  This should be after
377                 -- strictness analysis and the simplification which follows it.
378         runWhen liberate_case (CoreDoPasses [
379             CoreLiberateCase,
380             simpl_phase 0 ["post-liberate-case"] max_iter
381             ]),         -- Run the simplifier after LiberateCase to vastly
382                         -- reduce the possiblility of shadowing
383                         -- Reason: see Note [Shadowing] in SpecConstr.lhs
384
385         runWhen spec_constr CoreDoSpecConstr,
386
387         maybe_rule_check 0,
388
389         -- Final clean-up simplification:
390         simpl_phase 0 ["final"] max_iter
391      ]
392
393 -- The core-to-core pass ordering is derived from the DynFlags:
394 runWhen :: Bool -> CoreToDo -> CoreToDo
395 runWhen True  do_this = do_this
396 runWhen False _       = CoreDoNothing
397
398 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
399 runMaybe (Just x) f = f x
400 runMaybe Nothing  _ = CoreDoNothing
401
402 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
403 dumpSimplPhase dflags mode
404    | Just spec_string <- shouldDumpSimplPhase dflags
405    = match_spec spec_string
406    | otherwise
407    = dopt Opt_D_verbose_core2core dflags
408
409   where
410     match_spec :: String -> Bool
411     match_spec spec_string 
412       = or $ map (and . map match . split ':') 
413            $ split ',' spec_string
414
415     match :: String -> Bool
416     match "" = True
417     match s  = case reads s of
418                 [(n,"")] -> phase_num  n
419                 _        -> phase_name s
420
421     phase_num :: Int -> Bool
422     phase_num n = case mode of
423                     SimplPhase k _ -> n == k
424                     _              -> False
425
426     phase_name :: String -> Bool
427     phase_name s = case mode of
428                      SimplGently {}               -> s == "gentle"
429                      SimplPhase { sm_names = ss } -> s `elem` ss
430 \end{code}
431
432
433 %************************************************************************
434 %*                                                                      *
435              Counting and logging
436 %*                                                                      *
437 %************************************************************************
438
439 \begin{code}
440 verboseSimplStats :: Bool
441 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
442
443 zeroSimplCount     :: DynFlags -> SimplCount
444 isZeroSimplCount   :: SimplCount -> Bool
445 pprSimplCount      :: SimplCount -> SDoc
446 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
447 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
448 \end{code}
449
450 \begin{code}
451 data SimplCount 
452    = VerySimplZero              -- These two are used when 
453    | VerySimplNonZero   -- we are only interested in 
454                                 -- termination info
455
456    | SimplCount {
457         ticks   :: !Int,        -- Total ticks
458         details :: !TickCounts, -- How many of each type
459
460         n_log   :: !Int,        -- N
461         log1    :: [Tick],      -- Last N events; <= opt_HistorySize, 
462                                 --   most recent first
463         log2    :: [Tick]       -- Last opt_HistorySize events before that
464                                 -- Having log1, log2 lets us accumulate the
465                                 -- recent history reasonably efficiently
466      }
467
468 type TickCounts = FiniteMap Tick Int
469
470 zeroSimplCount dflags
471                 -- This is where we decide whether to do
472                 -- the VerySimpl version or the full-stats version
473   | dopt Opt_D_dump_simpl_stats dflags
474   = SimplCount {ticks = 0, details = emptyFM,
475                 n_log = 0, log1 = [], log2 = []}
476   | otherwise
477   = VerySimplZero
478
479 isZeroSimplCount VerySimplZero              = True
480 isZeroSimplCount (SimplCount { ticks = 0 }) = True
481 isZeroSimplCount _                          = False
482
483 doFreeSimplTick tick sc@SimplCount { details = dts } 
484   = sc { details = dts `addTick` tick }
485 doFreeSimplTick _ sc = sc 
486
487 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
488   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
489   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
490   where
491     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
492
493 doSimplTick _ _ = VerySimplNonZero -- The very simple case
494
495
496 -- Don't use plusFM_C because that's lazy, and we want to 
497 -- be pretty strict here!
498 addTick :: TickCounts -> Tick -> TickCounts
499 addTick fm tick = case lookupFM fm tick of
500                         Nothing -> addToFM fm tick 1
501                         Just n  -> n1 `seq` addToFM fm tick n1
502                                 where
503                                    n1 = n+1
504
505
506 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
507                sc2@(SimplCount { ticks = tks2, details = dts2 })
508   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
509   where
510         -- A hackish way of getting recent log info
511     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
512              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
513              | otherwise       = sc2
514
515 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
516 plusSimplCount _             _             = VerySimplNonZero
517
518 pprSimplCount VerySimplZero    = ptext (sLit "Total ticks: ZERO!")
519 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
520 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
521   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
522           blankLine,
523           pprTickCounts (fmToList dts),
524           if verboseSimplStats then
525                 vcat [blankLine,
526                       ptext (sLit "Log (most recent first)"),
527                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
528           else empty
529     ]
530
531 pprTickCounts :: [(Tick,Int)] -> SDoc
532 pprTickCounts [] = empty
533 pprTickCounts ((tick1,n1):ticks)
534   = vcat [int tot_n <+> text (tickString tick1),
535           pprTCDetails real_these,
536           pprTickCounts others
537     ]
538   where
539     tick1_tag           = tickToTag tick1
540     (these, others)     = span same_tick ticks
541     real_these          = (tick1,n1):these
542     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
543     tot_n               = sum [n | (_,n) <- real_these]
544
545 pprTCDetails :: [(Tick, Int)] -> SDoc
546 pprTCDetails ticks
547   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
548 \end{code}
549
550
551 \begin{code}
552 data Tick
553   = PreInlineUnconditionally    Id
554   | PostInlineUnconditionally   Id
555
556   | UnfoldingDone               Id
557   | RuleFired                   FastString      -- Rule name
558
559   | LetFloatFromLet
560   | EtaExpansion                Id      -- LHS binder
561   | EtaReduction                Id      -- Binder on outer lambda
562   | BetaReduction               Id      -- Lambda binder
563
564
565   | CaseOfCase                  Id      -- Bndr on *inner* case
566   | KnownBranch                 Id      -- Case binder
567   | CaseMerge                   Id      -- Binder on outer case
568   | AltMerge                    Id      -- Case binder
569   | CaseElim                    Id      -- Case binder
570   | CaseIdentity                Id      -- Case binder
571   | FillInCaseDefault           Id      -- Case binder
572
573   | BottomFound         
574   | SimplifierDone              -- Ticked at each iteration of the simplifier
575
576 instance Outputable Tick where
577   ppr tick = text (tickString tick) <+> pprTickCts tick
578
579 instance Eq Tick where
580   a == b = case a `cmpTick` b of
581            EQ -> True
582            _ -> False
583
584 instance Ord Tick where
585   compare = cmpTick
586
587 tickToTag :: Tick -> Int
588 tickToTag (PreInlineUnconditionally _)  = 0
589 tickToTag (PostInlineUnconditionally _) = 1
590 tickToTag (UnfoldingDone _)             = 2
591 tickToTag (RuleFired _)                 = 3
592 tickToTag LetFloatFromLet               = 4
593 tickToTag (EtaExpansion _)              = 5
594 tickToTag (EtaReduction _)              = 6
595 tickToTag (BetaReduction _)             = 7
596 tickToTag (CaseOfCase _)                = 8
597 tickToTag (KnownBranch _)               = 9
598 tickToTag (CaseMerge _)                 = 10
599 tickToTag (CaseElim _)                  = 11
600 tickToTag (CaseIdentity _)              = 12
601 tickToTag (FillInCaseDefault _)         = 13
602 tickToTag BottomFound                   = 14
603 tickToTag SimplifierDone                = 16
604 tickToTag (AltMerge _)                  = 17
605
606 tickString :: Tick -> String
607 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
608 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
609 tickString (UnfoldingDone _)            = "UnfoldingDone"
610 tickString (RuleFired _)                = "RuleFired"
611 tickString LetFloatFromLet              = "LetFloatFromLet"
612 tickString (EtaExpansion _)             = "EtaExpansion"
613 tickString (EtaReduction _)             = "EtaReduction"
614 tickString (BetaReduction _)            = "BetaReduction"
615 tickString (CaseOfCase _)               = "CaseOfCase"
616 tickString (KnownBranch _)              = "KnownBranch"
617 tickString (CaseMerge _)                = "CaseMerge"
618 tickString (AltMerge _)                 = "AltMerge"
619 tickString (CaseElim _)                 = "CaseElim"
620 tickString (CaseIdentity _)             = "CaseIdentity"
621 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
622 tickString BottomFound                  = "BottomFound"
623 tickString SimplifierDone               = "SimplifierDone"
624
625 pprTickCts :: Tick -> SDoc
626 pprTickCts (PreInlineUnconditionally v) = ppr v
627 pprTickCts (PostInlineUnconditionally v)= ppr v
628 pprTickCts (UnfoldingDone v)            = ppr v
629 pprTickCts (RuleFired v)                = ppr v
630 pprTickCts LetFloatFromLet              = empty
631 pprTickCts (EtaExpansion v)             = ppr v
632 pprTickCts (EtaReduction v)             = ppr v
633 pprTickCts (BetaReduction v)            = ppr v
634 pprTickCts (CaseOfCase v)               = ppr v
635 pprTickCts (KnownBranch v)              = ppr v
636 pprTickCts (CaseMerge v)                = ppr v
637 pprTickCts (AltMerge v)                 = ppr v
638 pprTickCts (CaseElim v)                 = ppr v
639 pprTickCts (CaseIdentity v)             = ppr v
640 pprTickCts (FillInCaseDefault v)        = ppr v
641 pprTickCts _                            = empty
642
643 cmpTick :: Tick -> Tick -> Ordering
644 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
645                 GT -> GT
646                 EQ -> cmpEqTick a b
647                 LT -> LT
648
649 cmpEqTick :: Tick -> Tick -> Ordering
650 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
651 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
652 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
653 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
654 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
655 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
656 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
657 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
658 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
659 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
660 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
661 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
662 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
663 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
664 cmpEqTick _                             _                               = EQ
665 \end{code}
666
667
668 %************************************************************************
669 %*                                                                      *
670              Monad and carried data structure definitions
671 %*                                                                      *
672 %************************************************************************
673
674 \begin{code}
675 newtype CoreState = CoreState {
676         cs_uniq_supply :: UniqSupply
677 }
678
679 data CoreReader = CoreReader {
680         cr_hsc_env :: HscEnv,
681         cr_rule_base :: RuleBase,
682         cr_module :: Module
683 }
684
685 data CoreWriter = CoreWriter {
686         cw_simpl_count :: SimplCount
687 }
688
689 emptyWriter :: DynFlags -> CoreWriter
690 emptyWriter dflags = CoreWriter {
691         cw_simpl_count = zeroSimplCount dflags
692     }
693
694 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
695 plusWriter w1 w2 = CoreWriter {
696         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
697     }
698
699 type CoreIOEnv = IOEnv CoreReader
700
701 -- | The monad used by Core-to-Core passes to access common state, register simplification
702 -- statistics and so on
703 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
704
705 instance Functor CoreM where
706     fmap f ma = do
707         a <- ma
708         return (f a)
709
710 instance Monad CoreM where
711     return x = CoreM (\s -> nop s x)
712     mx >>= f = CoreM $ \s -> do
713             (x, s', w1) <- unCoreM mx s
714             (y, s'', w2) <- unCoreM (f x) s'
715             return (y, s'', w1 `plusWriter` w2)
716
717 instance Applicative CoreM where
718     pure = return
719     (<*>) = ap
720
721 -- For use if the user has imported Control.Monad.Error from MTL
722 -- Requires UndecidableInstances
723 instance MonadPlus IO => MonadPlus CoreM where
724     mzero = CoreM (const mzero)
725     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
726
727 instance MonadUnique CoreM where
728     getUniqueSupplyM = do
729         us <- getS cs_uniq_supply
730         let (us1, us2) = splitUniqSupply us
731         modifyS (\s -> s { cs_uniq_supply = us2 })
732         return us1
733
734 runCoreM :: HscEnv
735          -> RuleBase
736          -> UniqSupply
737          -> Module
738          -> CoreM a
739          -> IO (a, SimplCount)
740 runCoreM hsc_env rule_base us mod m =
741         liftM extract $ runIOEnv reader $ unCoreM m state
742   where
743     reader = CoreReader {
744             cr_hsc_env = hsc_env,
745             cr_rule_base = rule_base,
746             cr_module = mod
747         }
748     state = CoreState { 
749             cs_uniq_supply = us
750         }
751
752     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
753     extract (value, _, writer) = (value, cw_simpl_count writer)
754
755 \end{code}
756
757
758 %************************************************************************
759 %*                                                                      *
760              Core combinators, not exported
761 %*                                                                      *
762 %************************************************************************
763
764 \begin{code}
765
766 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
767 nop s x = do
768     r <- getEnv
769     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
770
771 read :: (CoreReader -> a) -> CoreM a
772 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
773
774 getS :: (CoreState -> a) -> CoreM a
775 getS f = CoreM (\s -> nop s (f s))
776
777 modifyS :: (CoreState -> CoreState) -> CoreM ()
778 modifyS f = CoreM (\s -> nop (f s) ())
779
780 write :: CoreWriter -> CoreM ()
781 write w = CoreM (\s -> return ((), s, w))
782
783 \end{code}
784
785 \subsection{Lifting IO into the monad}
786
787 \begin{code}
788
789 -- | Lift an 'IOEnv' operation into 'CoreM'
790 liftIOEnv :: CoreIOEnv a -> CoreM a
791 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
792
793 instance MonadIO CoreM where
794     liftIO = liftIOEnv . IOEnv.liftIO
795
796 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
797 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
798 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
799
800 \end{code}
801
802
803 %************************************************************************
804 %*                                                                      *
805              Reader, writer and state accessors
806 %*                                                                      *
807 %************************************************************************
808
809 \begin{code}
810
811 getHscEnv :: CoreM HscEnv
812 getHscEnv = read cr_hsc_env
813
814 getRuleBase :: CoreM RuleBase
815 getRuleBase = read cr_rule_base
816
817 getModule :: CoreM Module
818 getModule = read cr_module
819
820 addSimplCount :: SimplCount -> CoreM ()
821 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
822
823 -- Convenience accessors for useful fields of HscEnv
824
825 getDynFlags :: CoreM DynFlags
826 getDynFlags = fmap hsc_dflags getHscEnv
827
828 -- | The original name cache is the current mapping from 'Module' and
829 -- 'OccName' to a compiler-wide unique 'Name'
830 getOrigNameCache :: CoreM OrigNameCache
831 getOrigNameCache = do
832     nameCacheRef <- fmap hsc_NC getHscEnv
833     liftIO $ fmap nsNames $ readIORef nameCacheRef
834
835 \end{code}
836
837
838 %************************************************************************
839 %*                                                                      *
840              Dealing with annotations
841 %*                                                                      *
842 %************************************************************************
843
844 \begin{code}
845 -- | Get all annotations of a given type. This happens lazily, that is
846 -- no deserialization will take place until the [a] is actually demanded and
847 -- the [a] can also be empty (the UniqFM is not filtered).
848 --
849 -- This should be done once at the start of a Core-to-Core pass that uses
850 -- annotations.
851 --
852 -- See Note [Annotations]
853 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
854 getAnnotations deserialize guts = do
855      hsc_env <- getHscEnv
856      ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
857      return (deserializeAnns deserialize ann_env)
858
859 -- | Get at most one annotation of a given type per Unique.
860 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
861 getFirstAnnotations deserialize guts
862   = liftM (mapUFM head . filterUFM (not . null))
863   $ getAnnotations deserialize guts
864   
865 \end{code}
866
867 Note [Annotations]
868 ~~~~~~~~~~~~~~~~~~
869 A Core-to-Core pass that wants to make use of annotations calls
870 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
871 annotations of a specific type. This produces all annotations from interface
872 files read so far. However, annotations from interface files read during the
873 pass will not be visible until getAnnotations is called again. This is similar
874 to how rules work and probably isn't too bad.
875
876 The current implementation could be optimised a bit: when looking up
877 annotations for a thing from the HomePackageTable, we could search directly in
878 the module where the thing is defined rather than building one UniqFM which
879 contains all annotations we know of. This would work because annotations can
880 only be given to things defined in the same module. However, since we would
881 only want to deserialise every annotation once, we would have to build a cache
882 for every module in the HTP. In the end, it's probably not worth it as long as
883 we aren't using annotations heavily.
884
885 %************************************************************************
886 %*                                                                      *
887                 Direct screen output
888 %*                                                                      *
889 %************************************************************************
890
891 \begin{code}
892
893 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
894 msg how doc = do
895         dflags <- getDynFlags
896         liftIO $ how dflags doc
897
898 -- | Output a String message to the screen
899 putMsgS :: String -> CoreM ()
900 putMsgS = putMsg . text
901
902 -- | Output a message to the screen
903 putMsg :: SDoc -> CoreM ()
904 putMsg = msg Err.putMsg
905
906 -- | Output a string error to the screen
907 errorMsgS :: String -> CoreM ()
908 errorMsgS = errorMsg . text
909
910 -- | Output an error to the screen
911 errorMsg :: SDoc -> CoreM ()
912 errorMsg = msg Err.errorMsg
913
914 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
915 fatalErrorMsgS :: String -> CoreM ()
916 fatalErrorMsgS = fatalErrorMsg . text
917
918 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
919 fatalErrorMsg :: SDoc -> CoreM ()
920 fatalErrorMsg = msg Err.fatalErrorMsg
921
922 -- | Output a string debugging message at verbosity level of @-v@ or higher
923 debugTraceMsgS :: String -> CoreM ()
924 debugTraceMsgS = debugTraceMsg . text
925
926 -- | Outputs a debugging message at verbosity level of @-v@ or higher
927 debugTraceMsg :: SDoc -> CoreM ()
928 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
929
930 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
931 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
932 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
933 \end{code}
934
935 \begin{code}
936
937 initTcForLookup :: HscEnv -> TcM a -> IO a
938 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
939
940 \end{code}
941
942
943 %************************************************************************
944 %*                                                                      *
945                Finding TyThings
946 %*                                                                      *
947 %************************************************************************
948
949 \begin{code}
950 instance MonadThings CoreM where
951     lookupThing name = do
952         hsc_env <- getHscEnv
953         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
954 \end{code}
955
956 %************************************************************************
957 %*                                                                      *
958                Template Haskell interoperability
959 %*                                                                      *
960 %************************************************************************
961
962 \begin{code}
963 #ifdef GHCI
964 -- | Attempt to convert a Template Haskell name to one that GHC can
965 -- understand. Original TH names such as those you get when you use
966 -- the @'foo@ syntax will be translated to their equivalent GHC name
967 -- exactly. Qualified or unqualifed TH names will be dynamically bound
968 -- to names in the module being compiled, if possible. Exact TH names
969 -- will be bound to the name they represent, exactly.
970 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
971 thNameToGhcName th_name = do
972     hsc_env <- getHscEnv
973     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
974 #endif
975 \end{code}