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