Added a VECTORISE pragma
[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
381     vectorisation
382       = runWhen (dopt Opt_Vectorise dflags) $
383           CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
384
385                 -- By default, we have 2 phases before phase 0.
386
387                 -- Want to run with inline phase 2 after the specialiser to give
388                 -- maximum chance for fusion to work before we inline build/augment
389                 -- in phase 1.  This made a difference in 'ansi' where an
390                 -- overloaded function wasn't inlined till too late.
391
392                 -- Need phase 1 so that build/augment get
393                 -- inlined.  I found that spectral/hartel/genfft lost some useful
394                 -- strictness in the function sumcode' if augment is not inlined
395                 -- before strictness analysis runs
396     simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
397                                 | phase <- [phases, phases-1 .. 1] ]
398
399
400         -- initial simplify: mk specialiser happy: minimum effort please
401     simpl_gently = CoreDoSimplify max_iter
402                        (base_mode { sm_phase = InitialPhase
403                                   , sm_names = ["Gentle"]
404                                   , sm_rules = True     -- Note [RULEs enabled in SimplGently]
405                                   , sm_inline = False
406                                   , sm_case_case = False })
407                           -- Don't do case-of-case transformations.
408                           -- This makes full laziness work better
409
410     core_todo =
411      if opt_level == 0 then
412        [vectorisation,
413         simpl_phase 0 ["final"] max_iter]
414      else {- opt_level >= 1 -} [
415
416     -- We want to do the static argument transform before full laziness as it
417     -- may expose extra opportunities to float things outwards. However, to fix
418     -- up the output of the transformation we need at do at least one simplify
419     -- after this before anything else
420         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
421
422         -- We run vectorisation here for now, but we might also try to run
423         -- it later
424         vectorisation,
425
426         -- initial simplify: mk specialiser happy: minimum effort please
427         simpl_gently,
428
429         -- Specialisation is best done before full laziness
430         -- so that overloaded functions have all their dictionary lambdas manifest
431         runWhen do_specialise CoreDoSpecialising,
432
433         runWhen full_laziness $
434            CoreDoFloatOutwards FloatOutSwitches {
435                                  floatOutLambdas   = Just 0,
436                                  floatOutConstants = True,
437                                  floatOutPartialApplications = False },
438                 -- Was: gentleFloatOutSwitches  
439                 --
440                 -- I have no idea why, but not floating constants to
441                 -- top level is very bad in some cases.
442                 --
443                 -- Notably: p_ident in spectral/rewrite
444                 --          Changing from "gentle" to "constantsOnly"
445                 --          improved rewrite's allocation by 19%, and
446                 --          made 0.0% difference to any other nofib
447                 --          benchmark
448                 --
449                 -- Not doing floatOutPartialApplications yet, we'll do
450                 -- that later on when we've had a chance to get more
451                 -- accurate arity information.  In fact it makes no
452                 -- difference at all to performance if we do it here,
453                 -- but maybe we save some unnecessary to-and-fro in
454                 -- the simplifier.
455
456         runWhen do_float_in CoreDoFloatInwards,
457
458         simpl_phases,
459
460                 -- Phase 0: allow all Ids to be inlined now
461                 -- This gets foldr inlined before strictness analysis
462
463                 -- At least 3 iterations because otherwise we land up with
464                 -- huge dead expressions because of an infelicity in the
465                 -- simpifier.
466                 --      let k = BIG in foldr k z xs
467                 -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
468                 -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
469                 -- Don't stop now!
470         simpl_phase 0 ["main"] (max max_iter 3),
471
472         runWhen strictness (CoreDoPasses [
473                 CoreDoStrictness,
474                 CoreDoWorkerWrapper,
475                 CoreDoGlomBinds,
476                 simpl_phase 0 ["post-worker-wrapper"] max_iter
477                 ]),
478
479         runWhen full_laziness $
480            CoreDoFloatOutwards FloatOutSwitches {
481                                  floatOutLambdas   = floatLamArgs dflags,
482                                  floatOutConstants = True,
483                                  floatOutPartialApplications = True },
484                 -- nofib/spectral/hartel/wang doubles in speed if you
485                 -- do full laziness late in the day.  It only happens
486                 -- after fusion and other stuff, so the early pass doesn't
487                 -- catch it.  For the record, the redex is
488                 --        f_el22 (f_el21 r_midblock)
489
490
491         runWhen cse CoreCSE,
492                 -- We want CSE to follow the final full-laziness pass, because it may
493                 -- succeed in commoning up things floated out by full laziness.
494                 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
495
496         runWhen do_float_in CoreDoFloatInwards,
497
498         maybe_rule_check (Phase 0),
499
500                 -- Case-liberation for -O2.  This should be after
501                 -- strictness analysis and the simplification which follows it.
502         runWhen liberate_case (CoreDoPasses [
503             CoreLiberateCase,
504             simpl_phase 0 ["post-liberate-case"] max_iter
505             ]),         -- Run the simplifier after LiberateCase to vastly
506                         -- reduce the possiblility of shadowing
507                         -- Reason: see Note [Shadowing] in SpecConstr.lhs
508
509         runWhen spec_constr CoreDoSpecConstr,
510
511         maybe_rule_check (Phase 0),
512
513         -- Final clean-up simplification:
514         simpl_phase 0 ["final"] max_iter
515      ]
516
517 -- The core-to-core pass ordering is derived from the DynFlags:
518 runWhen :: Bool -> CoreToDo -> CoreToDo
519 runWhen True  do_this = do_this
520 runWhen False _       = CoreDoNothing
521
522 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
523 runMaybe (Just x) f = f x
524 runMaybe Nothing  _ = CoreDoNothing
525
526 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
527 dumpSimplPhase dflags mode
528    | Just spec_string <- shouldDumpSimplPhase dflags
529    = match_spec spec_string
530    | otherwise
531    = dopt Opt_D_verbose_core2core dflags
532
533   where
534     match_spec :: String -> Bool
535     match_spec spec_string 
536       = or $ map (and . map match . split ':') 
537            $ split ',' spec_string
538
539     match :: String -> Bool
540     match "" = True
541     match s  = case reads s of
542                 [(n,"")] -> phase_num  n
543                 _        -> phase_name s
544
545     phase_num :: Int -> Bool
546     phase_num n = case sm_phase mode of
547                     Phase k -> n == k
548                     _       -> False
549
550     phase_name :: String -> Bool
551     phase_name s = s `elem` sm_names mode
552 \end{code}
553
554
555 Note [RULEs enabled in SimplGently]
556 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
557 RULES are enabled when doing "gentle" simplification.  Two reasons:
558
559   * We really want the class-op cancellation to happen:
560         op (df d1 d2) --> $cop3 d1 d2
561     because this breaks the mutual recursion between 'op' and 'df'
562
563   * I wanted the RULE
564         lift String ===> ...
565     to work in Template Haskell when simplifying
566     splices, so we get simpler code for literal strings
567
568 But watch out: list fusion can prevent floating.  So use phase control
569 to switch off those rules until after floating.
570
571 Currently (Oct10) I think that sm_rules is always True, so we
572 could remove it.
573
574
575 %************************************************************************
576 %*                                                                      *
577              Counting and logging
578 %*                                                                      *
579 %************************************************************************
580
581 \begin{code}
582 verboseSimplStats :: Bool
583 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
584
585 zeroSimplCount     :: DynFlags -> SimplCount
586 isZeroSimplCount   :: SimplCount -> Bool
587 pprSimplCount      :: SimplCount -> SDoc
588 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
589 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
590 \end{code}
591
592 \begin{code}
593 data SimplCount 
594    = VerySimplCount !Int        -- Used when don't want detailed stats
595
596    | SimplCount {
597         ticks   :: !Int,        -- Total ticks
598         details :: !TickCounts, -- How many of each type
599
600         n_log   :: !Int,        -- N
601         log1    :: [Tick],      -- Last N events; <= opt_HistorySize, 
602                                 --   most recent first
603         log2    :: [Tick]       -- Last opt_HistorySize events before that
604                                 -- Having log1, log2 lets us accumulate the
605                                 -- recent history reasonably efficiently
606      }
607
608 type TickCounts = Map Tick Int
609
610 simplCountN :: SimplCount -> Int
611 simplCountN (VerySimplCount n)         = n
612 simplCountN (SimplCount { ticks = n }) = n
613
614 zeroSimplCount dflags
615                 -- This is where we decide whether to do
616                 -- the VerySimpl version or the full-stats version
617   | dopt Opt_D_dump_simpl_stats dflags
618   = SimplCount {ticks = 0, details = Map.empty,
619                 n_log = 0, log1 = [], log2 = []}
620   | otherwise
621   = VerySimplCount 0
622
623 isZeroSimplCount (VerySimplCount n)         = n==0
624 isZeroSimplCount (SimplCount { ticks = n }) = n==0
625
626 doFreeSimplTick tick sc@SimplCount { details = dts } 
627   = sc { details = dts `addTick` tick }
628 doFreeSimplTick _ sc = sc 
629
630 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
631   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
632   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
633   where
634     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
635
636 doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
637
638
639 -- Don't use Map.unionWith because that's lazy, and we want to 
640 -- be pretty strict here!
641 addTick :: TickCounts -> Tick -> TickCounts
642 addTick fm tick = case Map.lookup tick fm of
643                         Nothing -> Map.insert tick 1 fm
644                         Just n  -> n1 `seq` Map.insert tick n1 fm
645                                 where
646                                    n1 = n+1
647
648
649 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
650                sc2@(SimplCount { ticks = tks2, details = dts2 })
651   = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
652   where
653         -- A hackish way of getting recent log info
654     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
655              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
656              | otherwise       = sc2
657
658 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
659 plusSimplCount _                  _                  = panic "plusSimplCount"
660        -- We use one or the other consistently
661
662 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
663 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
664   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
665           blankLine,
666           pprTickCounts (Map.toList dts),
667           if verboseSimplStats then
668                 vcat [blankLine,
669                       ptext (sLit "Log (most recent first)"),
670                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
671           else empty
672     ]
673
674 pprTickCounts :: [(Tick,Int)] -> SDoc
675 pprTickCounts [] = empty
676 pprTickCounts ((tick1,n1):ticks)
677   = vcat [int tot_n <+> text (tickString tick1),
678           pprTCDetails real_these,
679           pprTickCounts others
680     ]
681   where
682     tick1_tag           = tickToTag tick1
683     (these, others)     = span same_tick ticks
684     real_these          = (tick1,n1):these
685     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
686     tot_n               = sum [n | (_,n) <- real_these]
687
688 pprTCDetails :: [(Tick, Int)] -> SDoc
689 pprTCDetails ticks
690   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
691 \end{code}
692
693
694 \begin{code}
695 data Tick
696   = PreInlineUnconditionally    Id
697   | PostInlineUnconditionally   Id
698
699   | UnfoldingDone               Id
700   | RuleFired                   FastString      -- Rule name
701
702   | LetFloatFromLet
703   | EtaExpansion                Id      -- LHS binder
704   | EtaReduction                Id      -- Binder on outer lambda
705   | BetaReduction               Id      -- Lambda binder
706
707
708   | CaseOfCase                  Id      -- Bndr on *inner* case
709   | KnownBranch                 Id      -- Case binder
710   | CaseMerge                   Id      -- Binder on outer case
711   | AltMerge                    Id      -- Case binder
712   | CaseElim                    Id      -- Case binder
713   | CaseIdentity                Id      -- Case binder
714   | FillInCaseDefault           Id      -- Case binder
715
716   | BottomFound         
717   | SimplifierDone              -- Ticked at each iteration of the simplifier
718
719 instance Outputable Tick where
720   ppr tick = text (tickString tick) <+> pprTickCts tick
721
722 instance Eq Tick where
723   a == b = case a `cmpTick` b of
724            EQ -> True
725            _ -> False
726
727 instance Ord Tick where
728   compare = cmpTick
729
730 tickToTag :: Tick -> Int
731 tickToTag (PreInlineUnconditionally _)  = 0
732 tickToTag (PostInlineUnconditionally _) = 1
733 tickToTag (UnfoldingDone _)             = 2
734 tickToTag (RuleFired _)                 = 3
735 tickToTag LetFloatFromLet               = 4
736 tickToTag (EtaExpansion _)              = 5
737 tickToTag (EtaReduction _)              = 6
738 tickToTag (BetaReduction _)             = 7
739 tickToTag (CaseOfCase _)                = 8
740 tickToTag (KnownBranch _)               = 9
741 tickToTag (CaseMerge _)                 = 10
742 tickToTag (CaseElim _)                  = 11
743 tickToTag (CaseIdentity _)              = 12
744 tickToTag (FillInCaseDefault _)         = 13
745 tickToTag BottomFound                   = 14
746 tickToTag SimplifierDone                = 16
747 tickToTag (AltMerge _)                  = 17
748
749 tickString :: Tick -> String
750 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
751 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
752 tickString (UnfoldingDone _)            = "UnfoldingDone"
753 tickString (RuleFired _)                = "RuleFired"
754 tickString LetFloatFromLet              = "LetFloatFromLet"
755 tickString (EtaExpansion _)             = "EtaExpansion"
756 tickString (EtaReduction _)             = "EtaReduction"
757 tickString (BetaReduction _)            = "BetaReduction"
758 tickString (CaseOfCase _)               = "CaseOfCase"
759 tickString (KnownBranch _)              = "KnownBranch"
760 tickString (CaseMerge _)                = "CaseMerge"
761 tickString (AltMerge _)                 = "AltMerge"
762 tickString (CaseElim _)                 = "CaseElim"
763 tickString (CaseIdentity _)             = "CaseIdentity"
764 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
765 tickString BottomFound                  = "BottomFound"
766 tickString SimplifierDone               = "SimplifierDone"
767
768 pprTickCts :: Tick -> SDoc
769 pprTickCts (PreInlineUnconditionally v) = ppr v
770 pprTickCts (PostInlineUnconditionally v)= ppr v
771 pprTickCts (UnfoldingDone v)            = ppr v
772 pprTickCts (RuleFired v)                = ppr v
773 pprTickCts LetFloatFromLet              = empty
774 pprTickCts (EtaExpansion v)             = ppr v
775 pprTickCts (EtaReduction v)             = ppr v
776 pprTickCts (BetaReduction v)            = ppr v
777 pprTickCts (CaseOfCase v)               = ppr v
778 pprTickCts (KnownBranch v)              = ppr v
779 pprTickCts (CaseMerge v)                = ppr v
780 pprTickCts (AltMerge v)                 = ppr v
781 pprTickCts (CaseElim v)                 = ppr v
782 pprTickCts (CaseIdentity v)             = ppr v
783 pprTickCts (FillInCaseDefault v)        = ppr v
784 pprTickCts _                            = empty
785
786 cmpTick :: Tick -> Tick -> Ordering
787 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
788                 GT -> GT
789                 EQ -> cmpEqTick a b
790                 LT -> LT
791
792 cmpEqTick :: Tick -> Tick -> Ordering
793 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
794 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
795 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
796 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
797 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
798 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
799 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
800 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
801 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
802 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
803 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
804 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
805 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
806 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
807 cmpEqTick _                             _                               = EQ
808 \end{code}
809
810
811 %************************************************************************
812 %*                                                                      *
813              Monad and carried data structure definitions
814 %*                                                                      *
815 %************************************************************************
816
817 \begin{code}
818 newtype CoreState = CoreState {
819         cs_uniq_supply :: UniqSupply
820 }
821
822 data CoreReader = CoreReader {
823         cr_hsc_env :: HscEnv,
824         cr_rule_base :: RuleBase,
825         cr_module :: Module
826 }
827
828 data CoreWriter = CoreWriter {
829         cw_simpl_count :: SimplCount
830 }
831
832 emptyWriter :: DynFlags -> CoreWriter
833 emptyWriter dflags = CoreWriter {
834         cw_simpl_count = zeroSimplCount dflags
835     }
836
837 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
838 plusWriter w1 w2 = CoreWriter {
839         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
840     }
841
842 type CoreIOEnv = IOEnv CoreReader
843
844 -- | The monad used by Core-to-Core passes to access common state, register simplification
845 -- statistics and so on
846 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
847
848 instance Functor CoreM where
849     fmap f ma = do
850         a <- ma
851         return (f a)
852
853 instance Monad CoreM where
854     return x = CoreM (\s -> nop s x)
855     mx >>= f = CoreM $ \s -> do
856             (x, s', w1) <- unCoreM mx s
857             (y, s'', w2) <- unCoreM (f x) s'
858             return (y, s'', w1 `plusWriter` w2)
859
860 instance Applicative CoreM where
861     pure = return
862     (<*>) = ap
863
864 -- For use if the user has imported Control.Monad.Error from MTL
865 -- Requires UndecidableInstances
866 instance MonadPlus IO => MonadPlus CoreM where
867     mzero = CoreM (const mzero)
868     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
869
870 instance MonadUnique CoreM where
871     getUniqueSupplyM = do
872         us <- getS cs_uniq_supply
873         let (us1, us2) = splitUniqSupply us
874         modifyS (\s -> s { cs_uniq_supply = us2 })
875         return us1
876
877 runCoreM :: HscEnv
878          -> RuleBase
879          -> UniqSupply
880          -> Module
881          -> CoreM a
882          -> IO (a, SimplCount)
883 runCoreM hsc_env rule_base us mod m =
884         liftM extract $ runIOEnv reader $ unCoreM m state
885   where
886     reader = CoreReader {
887             cr_hsc_env = hsc_env,
888             cr_rule_base = rule_base,
889             cr_module = mod
890         }
891     state = CoreState { 
892             cs_uniq_supply = us
893         }
894
895     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
896     extract (value, _, writer) = (value, cw_simpl_count writer)
897
898 \end{code}
899
900
901 %************************************************************************
902 %*                                                                      *
903              Core combinators, not exported
904 %*                                                                      *
905 %************************************************************************
906
907 \begin{code}
908
909 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
910 nop s x = do
911     r <- getEnv
912     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
913
914 read :: (CoreReader -> a) -> CoreM a
915 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
916
917 getS :: (CoreState -> a) -> CoreM a
918 getS f = CoreM (\s -> nop s (f s))
919
920 modifyS :: (CoreState -> CoreState) -> CoreM ()
921 modifyS f = CoreM (\s -> nop (f s) ())
922
923 write :: CoreWriter -> CoreM ()
924 write w = CoreM (\s -> return ((), s, w))
925
926 \end{code}
927
928 \subsection{Lifting IO into the monad}
929
930 \begin{code}
931
932 -- | Lift an 'IOEnv' operation into 'CoreM'
933 liftIOEnv :: CoreIOEnv a -> CoreM a
934 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
935
936 instance MonadIO CoreM where
937     liftIO = liftIOEnv . IOEnv.liftIO
938
939 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
940 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
941 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
942
943 \end{code}
944
945
946 %************************************************************************
947 %*                                                                      *
948              Reader, writer and state accessors
949 %*                                                                      *
950 %************************************************************************
951
952 \begin{code}
953
954 getHscEnv :: CoreM HscEnv
955 getHscEnv = read cr_hsc_env
956
957 getRuleBase :: CoreM RuleBase
958 getRuleBase = read cr_rule_base
959
960 getModule :: CoreM Module
961 getModule = read cr_module
962
963 addSimplCount :: SimplCount -> CoreM ()
964 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
965
966 -- Convenience accessors for useful fields of HscEnv
967
968 getDynFlags :: CoreM DynFlags
969 getDynFlags = fmap hsc_dflags getHscEnv
970
971 -- | The original name cache is the current mapping from 'Module' and
972 -- 'OccName' to a compiler-wide unique 'Name'
973 getOrigNameCache :: CoreM OrigNameCache
974 getOrigNameCache = do
975     nameCacheRef <- fmap hsc_NC getHscEnv
976     liftIO $ fmap nsNames $ readIORef nameCacheRef
977
978 \end{code}
979
980
981 %************************************************************************
982 %*                                                                      *
983              Dealing with annotations
984 %*                                                                      *
985 %************************************************************************
986
987 \begin{code}
988 -- | Get all annotations of a given type. This happens lazily, that is
989 -- no deserialization will take place until the [a] is actually demanded and
990 -- the [a] can also be empty (the UniqFM is not filtered).
991 --
992 -- This should be done once at the start of a Core-to-Core pass that uses
993 -- annotations.
994 --
995 -- See Note [Annotations]
996 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
997 getAnnotations deserialize guts = do
998      hsc_env <- getHscEnv
999      ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
1000      return (deserializeAnns deserialize ann_env)
1001
1002 -- | Get at most one annotation of a given type per Unique.
1003 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
1004 getFirstAnnotations deserialize guts
1005   = liftM (mapUFM head . filterUFM (not . null))
1006   $ getAnnotations deserialize guts
1007   
1008 \end{code}
1009
1010 Note [Annotations]
1011 ~~~~~~~~~~~~~~~~~~
1012 A Core-to-Core pass that wants to make use of annotations calls
1013 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
1014 annotations of a specific type. This produces all annotations from interface
1015 files read so far. However, annotations from interface files read during the
1016 pass will not be visible until getAnnotations is called again. This is similar
1017 to how rules work and probably isn't too bad.
1018
1019 The current implementation could be optimised a bit: when looking up
1020 annotations for a thing from the HomePackageTable, we could search directly in
1021 the module where the thing is defined rather than building one UniqFM which
1022 contains all annotations we know of. This would work because annotations can
1023 only be given to things defined in the same module. However, since we would
1024 only want to deserialise every annotation once, we would have to build a cache
1025 for every module in the HTP. In the end, it's probably not worth it as long as
1026 we aren't using annotations heavily.
1027
1028 %************************************************************************
1029 %*                                                                      *
1030                 Direct screen output
1031 %*                                                                      *
1032 %************************************************************************
1033
1034 \begin{code}
1035
1036 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
1037 msg how doc = do
1038         dflags <- getDynFlags
1039         liftIO $ how dflags doc
1040
1041 -- | Output a String message to the screen
1042 putMsgS :: String -> CoreM ()
1043 putMsgS = putMsg . text
1044
1045 -- | Output a message to the screen
1046 putMsg :: SDoc -> CoreM ()
1047 putMsg = msg Err.putMsg
1048
1049 -- | Output a string error to the screen
1050 errorMsgS :: String -> CoreM ()
1051 errorMsgS = errorMsg . text
1052
1053 -- | Output an error to the screen
1054 errorMsg :: SDoc -> CoreM ()
1055 errorMsg = msg Err.errorMsg
1056
1057 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1058 fatalErrorMsgS :: String -> CoreM ()
1059 fatalErrorMsgS = fatalErrorMsg . text
1060
1061 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1062 fatalErrorMsg :: SDoc -> CoreM ()
1063 fatalErrorMsg = msg Err.fatalErrorMsg
1064
1065 -- | Output a string debugging message at verbosity level of @-v@ or higher
1066 debugTraceMsgS :: String -> CoreM ()
1067 debugTraceMsgS = debugTraceMsg . text
1068
1069 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1070 debugTraceMsg :: SDoc -> CoreM ()
1071 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1072
1073 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1074 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1075 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1076 \end{code}
1077
1078 \begin{code}
1079
1080 initTcForLookup :: HscEnv -> TcM a -> IO a
1081 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1082
1083 \end{code}
1084
1085
1086 %************************************************************************
1087 %*                                                                      *
1088                Finding TyThings
1089 %*                                                                      *
1090 %************************************************************************
1091
1092 \begin{code}
1093 instance MonadThings CoreM where
1094     lookupThing name = do
1095         hsc_env <- getHscEnv
1096         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1097 \end{code}
1098
1099 %************************************************************************
1100 %*                                                                      *
1101                Template Haskell interoperability
1102 %*                                                                      *
1103 %************************************************************************
1104
1105 \begin{code}
1106 #ifdef GHCI
1107 -- | Attempt to convert a Template Haskell name to one that GHC can
1108 -- understand. Original TH names such as those you get when you use
1109 -- the @'foo@ syntax will be translated to their equivalent GHC name
1110 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1111 -- to names in the module being compiled, if possible. Exact TH names
1112 -- will be bound to the name they represent, exactly.
1113 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1114 thNameToGhcName th_name = do
1115     hsc_env <- getHscEnv
1116     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
1117 #endif
1118 \end{code}