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