b5479ec8d28c191ab799d73ccba9fb861a5a12c5
[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 CPP, UndecidableInstances #-}
8
9 module CoreMonad (
10     -- * Configuration of the core-to-core passes
11     CoreToDo(..), runWhen, runMaybe,
12     SimplifierMode(..),
13     FloatOutSwitches(..),
14     pprPassDetails,
15
16     -- * Plugins
17     PluginPass, Plugin(..), CommandLineOption,
18     defaultPlugin, bindsOnlyPass,
19
20     -- * Counting
21     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
22     pprSimplCount, plusSimplCount, zeroSimplCount,
23     isZeroSimplCount, hasDetailedCounts, Tick(..),
24
25     -- * The monad
26     CoreM, runCoreM,
27
28     -- ** Reading from the monad
29     getHscEnv, getRuleBase, getModule,
30     getDynFlags, getOrigNameCache, getPackageFamInstEnv,
31     getPrintUnqualified,
32
33     -- ** Writing to the monad
34     addSimplCount,
35
36     -- ** Lifting into the monad
37     liftIO, liftIOWithCount,
38     liftIO1, liftIO2, liftIO3, liftIO4,
39
40     -- ** Global initialization
41     reinitializeGlobals,
42
43     -- ** Dealing with annotations
44     getAnnotations, getFirstAnnotations,
45
46     -- ** Debug output
47     showPass, showPassIO, endPass, endPassIO, dumpPassResult, lintPassResult,
48     lintInteractiveExpr, dumpIfSet,
49
50     -- ** Screen output
51     putMsg, putMsgS, errorMsg, errorMsgS,
52     fatalErrorMsg, fatalErrorMsgS,
53     debugTraceMsg, debugTraceMsgS,
54     dumpIfSet_dyn,
55
56 #ifdef GHCI
57     -- * Getting 'Name's
58     thNameToGhcName
59 #endif
60   ) where
61
62 #ifdef GHCI
63 import Name( Name )
64 #endif
65 import CoreSyn
66 import PprCore
67 import CoreUtils
68 import CoreLint         ( lintCoreBindings, lintExpr )
69 import HscTypes
70 import Module
71 import DynFlags
72 import StaticFlags
73 import Rules            ( RuleBase )
74 import BasicTypes       ( CompilerPhase(..) )
75 import Annotations
76
77 import IOEnv hiding     ( liftIO, failM, failWithM )
78 import qualified IOEnv  ( liftIO )
79 import TcEnv            ( tcLookupGlobal )
80 import TcRnMonad        ( initTcForLookup )
81 import InstEnv          ( instanceDFunId )
82 import Type             ( tyVarsOfType )
83 import Id               ( idType )
84 import Var
85 import VarSet
86
87 import Outputable
88 import FastString
89 import qualified ErrUtils as Err
90 import Bag
91 import Maybes
92 import SrcLoc
93 import UniqSupply
94 import UniqFM       ( UniqFM, mapUFM, filterUFM )
95 import MonadUtils
96
97 import ListSetOps       ( runs )
98 import Data.List
99 import Data.Ord
100 import Data.Dynamic
101 import Data.IORef
102 import Data.Map (Map)
103 import qualified Data.Map as Map
104 import Data.Word
105 import qualified Control.Applicative as A
106 import Control.Monad
107
108 import Prelude hiding   ( read )
109
110 #ifdef GHCI
111 import Control.Concurrent.MVar (MVar)
112 import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
113 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
114 import qualified Language.Haskell.TH as TH
115 #else
116 saveLinkerGlobals :: IO ()
117 saveLinkerGlobals = return ()
118
119 restoreLinkerGlobals :: () -> IO ()
120 restoreLinkerGlobals () = return ()
121 #endif
122 \end{code}
123
124 %************************************************************************
125 %*                                                                      *
126                        Debug output
127 %*                                                                      *
128 %************************************************************************
129
130 These functions are not CoreM monad stuff, but they probably ought to
131 be, and it makes a conveneint place.  place for them.  They print out
132 stuff before and after core passes, and do Core Lint when necessary.
133
134 \begin{code}
135 showPass :: CoreToDo -> CoreM ()
136 showPass pass = do { dflags <- getDynFlags
137                    ; liftIO $ showPassIO dflags pass }
138
139 showPassIO :: DynFlags -> CoreToDo -> IO ()
140 showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass)
141
142 endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
143 endPass pass binds rules
144   = do { hsc_env <- getHscEnv
145        ; print_unqual <- getPrintUnqualified
146        ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
147
148 endPassIO :: HscEnv -> PrintUnqualified
149           -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
150 -- Used by the IO-is CorePrep too
151 endPassIO hsc_env print_unqual pass binds rules
152   = do { dumpPassResult dflags print_unqual mb_flag
153                         (ppr pass) (pprPassDetails pass) binds rules
154        ; lintPassResult hsc_env pass binds }
155   where
156     dflags  = hsc_dflags hsc_env
157     mb_flag = case coreDumpFlag pass of
158                 Just flag | dopt flag dflags                    -> Just flag
159                           | dopt Opt_D_verbose_core2core dflags -> Just flag
160                 _ -> Nothing
161
162 dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
163 dumpIfSet dflags dump_me pass extra_info doc
164   = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
165
166 dumpPassResult :: DynFlags
167                -> PrintUnqualified
168                -> Maybe DumpFlag        -- Just df => show details in a file whose
169                                         --            name is specified by df
170                -> SDoc                  -- Header
171                -> SDoc                  -- Extra info to appear after header
172                -> CoreProgram -> [CoreRule]
173                -> IO ()
174 dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
175   | Just flag <- mb_flag
176   = Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
177
178   | otherwise
179   = Err.debugTraceMsg dflags 2 size_doc
180           -- Report result size
181           -- This has the side effect of forcing the intermediate to be evaluated
182
183   where
184     size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
185
186     dump_doc  = vcat [ nest 2 extra_info
187                      , size_doc
188                      , blankLine
189                      , pprCoreBindings binds
190                      , ppUnless (null rules) pp_rules ]
191     pp_rules = vcat [ blankLine
192                     , ptext (sLit "------ Local rules for imported ids --------")
193                     , pprRules rules ]
194
195 lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
196 lintPassResult hsc_env pass binds
197   | not (gopt Opt_DoCoreLinting dflags)
198   = return ()
199   | otherwise
200   = do { let (warns, errs) = lintCoreBindings (interactiveInScope hsc_env) binds
201        ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
202        ; displayLintResults dflags pass warns errs binds  }
203   where
204     dflags = hsc_dflags hsc_env
205
206 displayLintResults :: DynFlags -> CoreToDo
207                    -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
208                    -> IO ()
209 displayLintResults dflags pass warns errs binds
210   | not (isEmptyBag errs)
211   = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
212            (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
213                  , ptext (sLit "*** Offending Program ***")
214                  , pprCoreBindings binds
215                  , ptext (sLit "*** End of Offense ***") ])
216        ; Err.ghcExit dflags 1 }
217
218   | not (isEmptyBag warns)
219   , not (case pass of { CoreDesugar -> True; _ -> False })
220         -- Suppress warnings after desugaring pass because some
221         -- are legitimate. Notably, the desugarer generates instance
222         -- methods with INLINE pragmas that form a mutually recursive
223         -- group.  Only afer a round of simplification are they unravelled.
224   , not opt_NoDebugOutput
225   , showLintWarnings pass
226   = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
227         (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
228
229   | otherwise = return ()
230   where
231
232 lint_banner :: String -> SDoc -> SDoc
233 lint_banner string pass = ptext (sLit "*** Core Lint")      <+> text string
234                           <+> ptext (sLit ": in result of") <+> pass
235                           <+> ptext (sLit "***")
236
237 showLintWarnings :: CoreToDo -> Bool
238 -- Disable Lint warnings on the first simplifier pass, because
239 -- there may be some INLINE knots still tied, which is tiresomely noisy
240 showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
241 showLintWarnings _ = True
242
243 lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
244 lintInteractiveExpr what hsc_env expr
245   | not (gopt Opt_DoCoreLinting dflags)
246   = return ()
247   | Just err <- lintExpr (interactiveInScope hsc_env) expr
248   = do { display_lint_err err
249        ; Err.ghcExit dflags 1 }
250   | otherwise
251   = return ()
252   where
253     dflags = hsc_dflags hsc_env
254
255     display_lint_err err
256       = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
257                (vcat [ lint_banner "errors" (text what)
258                      , err
259                      , ptext (sLit "*** Offending Program ***")
260                      , pprCoreExpr expr
261                      , ptext (sLit "*** End of Offense ***") ])
262            ; Err.ghcExit dflags 1 }
263
264 interactiveInScope :: HscEnv -> [Var]
265 -- In GHCi we may lint expressions, or bindings arising from 'deriving'
266 -- clauses, that mention variables bound in the interactive context.
267 -- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).
268 -- So we have to tell Lint about them, lest it reports them as out of scope.
269 --
270 -- We do this by find local-named things that may appear free in interactive
271 -- context.  This function is pretty revolting and quite possibly not quite right.
272 -- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
273 -- so this is a (cheap) no-op.
274 --
275 -- See Trac #8215 for an example
276 interactiveInScope hsc_env
277   = varSetElems tyvars ++ ids
278   where
279     -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
280     ictxt                   = hsc_IC hsc_env
281     (cls_insts, _fam_insts) = ic_instances ictxt
282     te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)
283     te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
284     ids    = typeEnvIds te
285     tyvars = mapUnionVarSet (tyVarsOfType . idType) ids
286               -- Why the type variables?  How can the top level envt have free tyvars?
287               -- I think it's because of the GHCi debugger, which can bind variables
288               --   f :: [t] -> [t]
289               -- where t is a RuntimeUnk (see TcType)
290 \end{code}
291
292
293 %************************************************************************
294 %*                                                                      *
295               The CoreToDo type and related types
296           Abstraction of core-to-core passes to run.
297 %*                                                                      *
298 %************************************************************************
299
300 \begin{code}
301
302 data CoreToDo           -- These are diff core-to-core passes,
303                         -- which may be invoked in any order,
304                         -- as many times as you like.
305
306   = CoreDoSimplify      -- The core-to-core simplifier.
307         Int                    -- Max iterations
308         SimplifierMode
309   | CoreDoPluginPass String PluginPass
310   | CoreDoFloatInwards
311   | CoreDoFloatOutwards FloatOutSwitches
312   | CoreLiberateCase
313   | CoreDoPrintCore
314   | CoreDoStaticArgs
315   | CoreDoCallArity
316   | CoreDoStrictness
317   | CoreDoWorkerWrapper
318   | CoreDoSpecialising
319   | CoreDoSpecConstr
320   | CoreCSE
321   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
322                                            -- matching this string
323   | CoreDoVectorisation
324   | CoreDoNothing                -- Useful when building up
325   | CoreDoPasses [CoreToDo]      -- lists of these things
326
327   | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
328   | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
329                        --                 Core output, and hence useful to pass to endPass
330
331   | CoreTidy
332   | CorePrep
333
334 \end{code}
335
336 \begin{code}
337 coreDumpFlag :: CoreToDo -> Maybe DumpFlag
338 coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core
339 coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_dump_core_pipeline
340 coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
341 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
342 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
343 coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
344 coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity
345 coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
346 coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
347 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
348 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
349 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
350 coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
351 coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds
352 coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds
353 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
354 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
355
356 coreDumpFlag CoreDoPrintCore          = Nothing
357 coreDumpFlag (CoreDoRuleCheck {})     = Nothing
358 coreDumpFlag CoreDoNothing            = Nothing
359 coreDumpFlag (CoreDoPasses {})        = Nothing
360
361 instance Outputable CoreToDo where
362   ppr (CoreDoSimplify _ _)     = ptext (sLit "Simplifier")
363   ppr (CoreDoPluginPass s _)   = ptext (sLit "Core plugin: ") <+> text s
364   ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
365   ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
366   ppr CoreLiberateCase         = ptext (sLit "Liberate case")
367   ppr CoreDoStaticArgs         = ptext (sLit "Static argument")
368   ppr CoreDoCallArity          = ptext (sLit "Called arity analysis")
369   ppr CoreDoStrictness         = ptext (sLit "Demand analysis")
370   ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
371   ppr CoreDoSpecialising       = ptext (sLit "Specialise")
372   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
373   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
374   ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
375   ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
376   ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
377   ppr CoreTidy                 = ptext (sLit "Tidy Core")
378   ppr CorePrep                 = ptext (sLit "CorePrep")
379   ppr CoreDoPrintCore          = ptext (sLit "Print core")
380   ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
381   ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
382   ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
383
384 pprPassDetails :: CoreToDo -> SDoc
385 pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n
386                                             , ppr md ]
387 pprPassDetails _ = Outputable.empty
388 \end{code}
389
390 \begin{code}
391 data SimplifierMode             -- See comments in SimplMonad
392   = SimplMode
393         { sm_names      :: [String] -- Name(s) of the phase
394         , sm_phase      :: CompilerPhase
395         , sm_rules      :: Bool     -- Whether RULES are enabled
396         , sm_inline     :: Bool     -- Whether inlining is enabled
397         , sm_case_case  :: Bool     -- Whether case-of-case is enabled
398         , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
399         }
400
401 instance Outputable SimplifierMode where
402     ppr (SimplMode { sm_phase = p, sm_names = ss
403                    , sm_rules = r, sm_inline = i
404                    , sm_eta_expand = eta, sm_case_case = cc })
405        = ptext (sLit "SimplMode") <+> braces (
406          sep [ ptext (sLit "Phase =") <+> ppr p <+>
407                brackets (text (concat $ intersperse "," ss)) <> comma
408              , pp_flag i   (sLit "inline") <> comma
409              , pp_flag r   (sLit "rules") <> comma
410              , pp_flag eta (sLit "eta-expand") <> comma
411              , pp_flag cc  (sLit "case-of-case") ])
412          where
413            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
414 \end{code}
415
416
417 \begin{code}
418 data FloatOutSwitches = FloatOutSwitches {
419   floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
420                                    -- doing so will abstract over n or fewer
421                                    -- value variables
422                                    -- Nothing <=> float all lambdas to top level,
423                                    --             regardless of how many free variables
424                                    -- Just 0 is the vanilla case: float a lambda
425                                    --    iff it has no free vars
426
427   floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
428                                    --            even if they do not escape a lambda
429   floatOutOverSatApps :: Bool      -- ^ True <=> float out over-saturated applications
430                                    --            based on arity information.
431                                    -- See Note [Floating over-saturated applications]
432                                    -- in SetLevels
433   }
434 instance Outputable FloatOutSwitches where
435     ppr = pprFloatOutSwitches
436
437 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
438 pprFloatOutSwitches sw
439   = ptext (sLit "FOS") <+> (braces $
440      sep $ punctuate comma $
441      [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
442      , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
443      , ptext (sLit "OverSatApps =")   <+> ppr (floatOutOverSatApps sw) ])
444
445 -- The core-to-core pass ordering is derived from the DynFlags:
446 runWhen :: Bool -> CoreToDo -> CoreToDo
447 runWhen True  do_this = do_this
448 runWhen False _       = CoreDoNothing
449
450 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
451 runMaybe (Just x) f = f x
452 runMaybe Nothing  _ = CoreDoNothing
453
454 \end{code}
455
456
457 Note [RULEs enabled in SimplGently]
458 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
459 RULES are enabled when doing "gentle" simplification.  Two reasons:
460
461   * We really want the class-op cancellation to happen:
462         op (df d1 d2) --> $cop3 d1 d2
463     because this breaks the mutual recursion between 'op' and 'df'
464
465   * I wanted the RULE
466         lift String ===> ...
467     to work in Template Haskell when simplifying
468     splices, so we get simpler code for literal strings
469
470 But watch out: list fusion can prevent floating.  So use phase control
471 to switch off those rules until after floating.
472
473
474 %************************************************************************
475 %*                                                                      *
476              Types for Plugins
477 %*                                                                      *
478 %************************************************************************
479
480 \begin{code}
481 -- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type
482 type CommandLineOption = String
483
484 -- | 'Plugin' is the core compiler plugin data type. Try to avoid
485 -- constructing one of these directly, and just modify some fields of
486 -- 'defaultPlugin' instead: this is to try and preserve source-code
487 -- compatability when we add fields to this.
488 --
489 -- Nonetheless, this API is preliminary and highly likely to change in the future.
490 data Plugin = Plugin {
491         installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
492                 -- ^ Modify the Core pipeline that will be used for compilation.
493                 -- This is called as the Core pipeline is built for every module
494                 --  being compiled, and plugins get the opportunity to modify
495                 -- the pipeline in a nondeterministic order.
496      }
497
498 -- | Default plugin: does nothing at all! For compatability reasons you should base all your
499 -- plugin definitions on this default value.
500 defaultPlugin :: Plugin
501 defaultPlugin = Plugin {
502         installCoreToDos = const return
503     }
504
505 -- | A description of the plugin pass itself
506 type PluginPass = ModGuts -> CoreM ModGuts
507
508 bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
509 bindsOnlyPass pass guts
510   = do { binds' <- pass (mg_binds guts)
511        ; return (guts { mg_binds = binds' }) }
512 \end{code}
513
514
515 %************************************************************************
516 %*                                                                      *
517              Counting and logging
518 %*                                                                      *
519 %************************************************************************
520
521 \begin{code}
522 verboseSimplStats :: Bool
523 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
524
525 zeroSimplCount     :: DynFlags -> SimplCount
526 isZeroSimplCount   :: SimplCount -> Bool
527 hasDetailedCounts  :: SimplCount -> Bool
528 pprSimplCount      :: SimplCount -> SDoc
529 doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount
530 doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount
531 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
532 \end{code}
533
534 \begin{code}
535 data SimplCount
536    = VerySimplCount !Int        -- Used when don't want detailed stats
537
538    | SimplCount {
539         ticks   :: !Int,        -- Total ticks
540         details :: !TickCounts, -- How many of each type
541
542         n_log   :: !Int,        -- N
543         log1    :: [Tick],      -- Last N events; <= opt_HistorySize,
544                                 --   most recent first
545         log2    :: [Tick]       -- Last opt_HistorySize events before that
546                                 -- Having log1, log2 lets us accumulate the
547                                 -- recent history reasonably efficiently
548      }
549
550 type TickCounts = Map Tick Int
551
552 simplCountN :: SimplCount -> Int
553 simplCountN (VerySimplCount n)         = n
554 simplCountN (SimplCount { ticks = n }) = n
555
556 zeroSimplCount dflags
557                 -- This is where we decide whether to do
558                 -- the VerySimpl version or the full-stats version
559   | dopt Opt_D_dump_simpl_stats dflags
560   = SimplCount {ticks = 0, details = Map.empty,
561                 n_log = 0, log1 = [], log2 = []}
562   | otherwise
563   = VerySimplCount 0
564
565 isZeroSimplCount (VerySimplCount n)         = n==0
566 isZeroSimplCount (SimplCount { ticks = n }) = n==0
567
568 hasDetailedCounts (VerySimplCount {}) = False
569 hasDetailedCounts (SimplCount {})     = True
570
571 doFreeSimplTick tick sc@SimplCount { details = dts }
572   = sc { details = dts `addTick` tick }
573 doFreeSimplTick _ sc = sc
574
575 doSimplTick dflags tick
576     sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })
577   | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
578   | otherwise                = sc1 { n_log = nl+1, log1 = tick : l1 }
579   where
580     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
581
582 doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
583
584
585 -- Don't use Map.unionWith because that's lazy, and we want to
586 -- be pretty strict here!
587 addTick :: TickCounts -> Tick -> TickCounts
588 addTick fm tick = case Map.lookup tick fm of
589                         Nothing -> Map.insert tick 1 fm
590                         Just n  -> n1 `seq` Map.insert tick n1 fm
591                                 where
592                                    n1 = n+1
593
594
595 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
596                sc2@(SimplCount { ticks = tks2, details = dts2 })
597   = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
598   where
599         -- A hackish way of getting recent log info
600     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
601              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
602              | otherwise       = sc2
603
604 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
605 plusSimplCount _                  _                  = panic "plusSimplCount"
606        -- We use one or the other consistently
607
608 pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
609 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
610   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
611           blankLine,
612           pprTickCounts dts,
613           if verboseSimplStats then
614                 vcat [blankLine,
615                       ptext (sLit "Log (most recent first)"),
616                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
617           else Outputable.empty
618     ]
619
620 pprTickCounts :: Map Tick Int -> SDoc
621 pprTickCounts counts
622   = vcat (map pprTickGroup groups)
623   where
624     groups :: [[(Tick,Int)]]    -- Each group shares a comon tag
625                                 -- toList returns common tags adjacent
626     groups = runs same_tag (Map.toList counts)
627     same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
628
629 pprTickGroup :: [(Tick, Int)] -> SDoc
630 pprTickGroup group@((tick1,_):_)
631   = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
632        2 (vcat [ int n <+> pprTickCts tick
633                                     -- flip as we want largest first
634                | (tick,n) <- sortBy (flip (comparing snd)) group])
635 pprTickGroup [] = panic "pprTickGroup"
636 \end{code}
637
638
639 \begin{code}
640 data Tick
641   = PreInlineUnconditionally    Id
642   | PostInlineUnconditionally   Id
643
644   | UnfoldingDone               Id
645   | RuleFired                   FastString      -- Rule name
646
647   | LetFloatFromLet
648   | EtaExpansion                Id      -- LHS binder
649   | EtaReduction                Id      -- Binder on outer lambda
650   | BetaReduction               Id      -- Lambda binder
651
652
653   | CaseOfCase                  Id      -- Bndr on *inner* case
654   | KnownBranch                 Id      -- Case binder
655   | CaseMerge                   Id      -- Binder on outer case
656   | AltMerge                    Id      -- Case binder
657   | CaseElim                    Id      -- Case binder
658   | CaseIdentity                Id      -- Case binder
659   | FillInCaseDefault           Id      -- Case binder
660
661   | BottomFound
662   | SimplifierDone              -- Ticked at each iteration of the simplifier
663
664 instance Outputable Tick where
665   ppr tick = text (tickString tick) <+> pprTickCts tick
666
667 instance Eq Tick where
668   a == b = case a `cmpTick` b of
669            EQ -> True
670            _ -> False
671
672 instance Ord Tick where
673   compare = cmpTick
674
675 tickToTag :: Tick -> Int
676 tickToTag (PreInlineUnconditionally _)  = 0
677 tickToTag (PostInlineUnconditionally _) = 1
678 tickToTag (UnfoldingDone _)             = 2
679 tickToTag (RuleFired _)                 = 3
680 tickToTag LetFloatFromLet               = 4
681 tickToTag (EtaExpansion _)              = 5
682 tickToTag (EtaReduction _)              = 6
683 tickToTag (BetaReduction _)             = 7
684 tickToTag (CaseOfCase _)                = 8
685 tickToTag (KnownBranch _)               = 9
686 tickToTag (CaseMerge _)                 = 10
687 tickToTag (CaseElim _)                  = 11
688 tickToTag (CaseIdentity _)              = 12
689 tickToTag (FillInCaseDefault _)         = 13
690 tickToTag BottomFound                   = 14
691 tickToTag SimplifierDone                = 16
692 tickToTag (AltMerge _)                  = 17
693
694 tickString :: Tick -> String
695 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
696 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
697 tickString (UnfoldingDone _)            = "UnfoldingDone"
698 tickString (RuleFired _)                = "RuleFired"
699 tickString LetFloatFromLet              = "LetFloatFromLet"
700 tickString (EtaExpansion _)             = "EtaExpansion"
701 tickString (EtaReduction _)             = "EtaReduction"
702 tickString (BetaReduction _)            = "BetaReduction"
703 tickString (CaseOfCase _)               = "CaseOfCase"
704 tickString (KnownBranch _)              = "KnownBranch"
705 tickString (CaseMerge _)                = "CaseMerge"
706 tickString (AltMerge _)                 = "AltMerge"
707 tickString (CaseElim _)                 = "CaseElim"
708 tickString (CaseIdentity _)             = "CaseIdentity"
709 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
710 tickString BottomFound                  = "BottomFound"
711 tickString SimplifierDone               = "SimplifierDone"
712
713 pprTickCts :: Tick -> SDoc
714 pprTickCts (PreInlineUnconditionally v) = ppr v
715 pprTickCts (PostInlineUnconditionally v)= ppr v
716 pprTickCts (UnfoldingDone v)            = ppr v
717 pprTickCts (RuleFired v)                = ppr v
718 pprTickCts LetFloatFromLet              = Outputable.empty
719 pprTickCts (EtaExpansion v)             = ppr v
720 pprTickCts (EtaReduction v)             = ppr v
721 pprTickCts (BetaReduction v)            = ppr v
722 pprTickCts (CaseOfCase v)               = ppr v
723 pprTickCts (KnownBranch v)              = ppr v
724 pprTickCts (CaseMerge v)                = ppr v
725 pprTickCts (AltMerge v)                 = ppr v
726 pprTickCts (CaseElim v)                 = ppr v
727 pprTickCts (CaseIdentity v)             = ppr v
728 pprTickCts (FillInCaseDefault v)        = ppr v
729 pprTickCts _                            = Outputable.empty
730
731 cmpTick :: Tick -> Tick -> Ordering
732 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
733                 GT -> GT
734                 EQ -> cmpEqTick a b
735                 LT -> LT
736
737 cmpEqTick :: Tick -> Tick -> Ordering
738 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
739 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
740 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
741 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
742 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
743 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
744 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
745 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
746 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
747 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
748 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
749 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
750 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
751 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
752 cmpEqTick _                             _                               = EQ
753 \end{code}
754
755
756 %************************************************************************
757 %*                                                                      *
758              Monad and carried data structure definitions
759 %*                                                                      *
760 %************************************************************************
761
762 \begin{code}
763 newtype CoreState = CoreState {
764         cs_uniq_supply :: UniqSupply
765 }
766
767 data CoreReader = CoreReader {
768         cr_hsc_env :: HscEnv,
769         cr_rule_base :: RuleBase,
770         cr_module :: Module,
771         cr_print_unqual :: PrintUnqualified,
772 #ifdef GHCI
773         cr_globals :: (MVar PersistentLinkerState, Bool)
774 #else
775         cr_globals :: ()
776 #endif
777 }
778
779 data CoreWriter = CoreWriter {
780         cw_simpl_count :: !SimplCount
781         -- Making this strict fixes a nasty space leak
782         -- See Trac #7702
783 }
784
785 emptyWriter :: DynFlags -> CoreWriter
786 emptyWriter dflags = CoreWriter {
787         cw_simpl_count = zeroSimplCount dflags
788     }
789
790 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
791 plusWriter w1 w2 = CoreWriter {
792         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
793     }
794
795 type CoreIOEnv = IOEnv CoreReader
796
797 -- | The monad used by Core-to-Core passes to access common state, register simplification
798 -- statistics and so on
799 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
800
801 instance Functor CoreM where
802     fmap f ma = do
803         a <- ma
804         return (f a)
805
806 instance Monad CoreM where
807     return x = CoreM (\s -> nop s x)
808     mx >>= f = CoreM $ \s -> do
809             (x, s', w1) <- unCoreM mx s
810             (y, s'', w2) <- unCoreM (f x) s'
811             let w = w1 `plusWriter` w2 -- forcing w before returning avoids a space leak (Trac #7702)
812             return $ seq w (y, s'', w)
813
814 instance A.Applicative CoreM where
815     pure = return
816     (<*>) = ap
817
818 instance MonadPlus IO => A.Alternative CoreM where
819     empty = mzero
820     (<|>) = mplus
821
822 -- For use if the user has imported Control.Monad.Error from MTL
823 -- Requires UndecidableInstances
824 instance MonadPlus IO => MonadPlus CoreM where
825     mzero = CoreM (const mzero)
826     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
827
828 instance MonadUnique CoreM where
829     getUniqueSupplyM = do
830         us <- getS cs_uniq_supply
831         let (us1, us2) = splitUniqSupply us
832         modifyS (\s -> s { cs_uniq_supply = us2 })
833         return us1
834
835     getUniqueM = do
836         us <- getS cs_uniq_supply
837         let (u,us') = takeUniqFromSupply us
838         modifyS (\s -> s { cs_uniq_supply = us' })
839         return u
840
841 runCoreM :: HscEnv
842          -> RuleBase
843          -> UniqSupply
844          -> Module
845          -> PrintUnqualified
846          -> CoreM a
847          -> IO (a, SimplCount)
848 runCoreM hsc_env rule_base us mod print_unqual m = do
849         glbls <- saveLinkerGlobals
850         liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
851   where
852     reader glbls = CoreReader {
853             cr_hsc_env = hsc_env,
854             cr_rule_base = rule_base,
855             cr_module = mod,
856             cr_globals = glbls,
857             cr_print_unqual = print_unqual
858         }
859     state = CoreState {
860             cs_uniq_supply = us
861         }
862
863     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
864     extract (value, _, writer) = (value, cw_simpl_count writer)
865
866 \end{code}
867
868
869 %************************************************************************
870 %*                                                                      *
871              Core combinators, not exported
872 %*                                                                      *
873 %************************************************************************
874
875 \begin{code}
876
877 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
878 nop s x = do
879     r <- getEnv
880     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
881
882 read :: (CoreReader -> a) -> CoreM a
883 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
884
885 getS :: (CoreState -> a) -> CoreM a
886 getS f = CoreM (\s -> nop s (f s))
887
888 modifyS :: (CoreState -> CoreState) -> CoreM ()
889 modifyS f = CoreM (\s -> nop (f s) ())
890
891 write :: CoreWriter -> CoreM ()
892 write w = CoreM (\s -> return ((), s, w))
893
894 \end{code}
895
896 \subsection{Lifting IO into the monad}
897
898 \begin{code}
899
900 -- | Lift an 'IOEnv' operation into 'CoreM'
901 liftIOEnv :: CoreIOEnv a -> CoreM a
902 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
903
904 instance MonadIO CoreM where
905     liftIO = liftIOEnv . IOEnv.liftIO
906
907 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
908 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
909 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
910
911 \end{code}
912
913
914 %************************************************************************
915 %*                                                                      *
916              Reader, writer and state accessors
917 %*                                                                      *
918 %************************************************************************
919
920 \begin{code}
921 getHscEnv :: CoreM HscEnv
922 getHscEnv = read cr_hsc_env
923
924 getRuleBase :: CoreM RuleBase
925 getRuleBase = read cr_rule_base
926
927 getPrintUnqualified :: CoreM PrintUnqualified
928 getPrintUnqualified = read cr_print_unqual
929
930 addSimplCount :: SimplCount -> CoreM ()
931 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
932
933 -- Convenience accessors for useful fields of HscEnv
934
935 instance HasDynFlags CoreM where
936     getDynFlags = fmap hsc_dflags getHscEnv
937
938 instance HasModule CoreM where
939     getModule = read cr_module
940
941 -- | The original name cache is the current mapping from 'Module' and
942 -- 'OccName' to a compiler-wide unique 'Name'
943 getOrigNameCache :: CoreM OrigNameCache
944 getOrigNameCache = do
945     nameCacheRef <- fmap hsc_NC getHscEnv
946     liftIO $ fmap nsNames $ readIORef nameCacheRef
947
948 getPackageFamInstEnv :: CoreM PackageFamInstEnv
949 getPackageFamInstEnv = do
950     hsc_env <- getHscEnv
951     eps <- liftIO $ hscEPS hsc_env
952     return $ eps_fam_inst_env eps
953 \end{code}
954
955 %************************************************************************
956 %*                                                                      *
957              Initializing globals
958 %*                                                                      *
959 %************************************************************************
960
961 This is a rather annoying function. When a plugin is loaded, it currently
962 gets linked against a *newly loaded* copy of the GHC package. This would
963 not be a problem, except that the new copy has its own mutable state
964 that is not shared with that state that has already been initialized by
965 the original GHC package.
966
967 (NB This mechanism is sufficient for granting plugins read-only access to
968 globals that are guaranteed to be initialized before the plugin is loaded.  If
969 any further synchronization is necessary, I would suggest using the more
970 sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to
971 share a single instance of the global variable among the compiler and the
972 plugins.  Perhaps we should migrate all global variables to use that mechanism,
973 for robustness... -- NSF July 2013)
974
975 This leads to loaded plugins calling GHC code which pokes the static flags,
976 and then dying with a panic because the static flags *it* sees are uninitialized.
977
978 There are two possible solutions:
979   1. Export the symbols from the GHC executable from the GHC library and link
980      against this existing copy rather than a new copy of the GHC library
981   2. Carefully ensure that the global state in the two copies of the GHC
982      library matches
983
984 I tried 1. and it *almost* works (and speeds up plugin load times!) except
985 on Windows. On Windows the GHC library tends to export more than 65536 symbols
986 (see #5292) which overflows the limit of what we can export from the EXE and
987 causes breakage.
988
989 (Note that if the GHC exeecutable was dynamically linked this wouldn't be a problem,
990 because we could share the GHC library it links to.)
991
992 We are going to try 2. instead. Unfortunately, this means that every plugin
993 will have to say `reinitializeGlobals` before it does anything, but never mind.
994
995 I've threaded the cr_globals through CoreM rather than giving them as an
996 argument to the plugin function so that we can turn this function into
997 (return ()) without breaking any plugins when we eventually get 1. working.
998
999 \begin{code}
1000 reinitializeGlobals :: CoreM ()
1001 reinitializeGlobals = do
1002     linker_globals <- read cr_globals
1003     hsc_env <- getHscEnv
1004     let dflags = hsc_dflags hsc_env
1005     liftIO $ restoreLinkerGlobals linker_globals
1006     liftIO $ setUnsafeGlobalDynFlags dflags
1007 \end{code}
1008
1009 %************************************************************************
1010 %*                                                                      *
1011              Dealing with annotations
1012 %*                                                                      *
1013 %************************************************************************
1014
1015 \begin{code}
1016 -- | Get all annotations of a given type. This happens lazily, that is
1017 -- no deserialization will take place until the [a] is actually demanded and
1018 -- the [a] can also be empty (the UniqFM is not filtered).
1019 --
1020 -- This should be done once at the start of a Core-to-Core pass that uses
1021 -- annotations.
1022 --
1023 -- See Note [Annotations]
1024 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
1025 getAnnotations deserialize guts = do
1026      hsc_env <- getHscEnv
1027      ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
1028      return (deserializeAnns deserialize ann_env)
1029
1030 -- | Get at most one annotation of a given type per Unique.
1031 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
1032 getFirstAnnotations deserialize guts
1033   = liftM (mapUFM head . filterUFM (not . null))
1034   $ getAnnotations deserialize guts
1035
1036 \end{code}
1037
1038 Note [Annotations]
1039 ~~~~~~~~~~~~~~~~~~
1040 A Core-to-Core pass that wants to make use of annotations calls
1041 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
1042 annotations of a specific type. This produces all annotations from interface
1043 files read so far. However, annotations from interface files read during the
1044 pass will not be visible until getAnnotations is called again. This is similar
1045 to how rules work and probably isn't too bad.
1046
1047 The current implementation could be optimised a bit: when looking up
1048 annotations for a thing from the HomePackageTable, we could search directly in
1049 the module where the thing is defined rather than building one UniqFM which
1050 contains all annotations we know of. This would work because annotations can
1051 only be given to things defined in the same module. However, since we would
1052 only want to deserialise every annotation once, we would have to build a cache
1053 for every module in the HTP. In the end, it's probably not worth it as long as
1054 we aren't using annotations heavily.
1055
1056 %************************************************************************
1057 %*                                                                      *
1058                 Direct screen output
1059 %*                                                                      *
1060 %************************************************************************
1061
1062 \begin{code}
1063
1064 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
1065 msg how doc = do
1066         dflags <- getDynFlags
1067         liftIO $ how dflags doc
1068
1069 -- | Output a String message to the screen
1070 putMsgS :: String -> CoreM ()
1071 putMsgS = putMsg . text
1072
1073 -- | Output a message to the screen
1074 putMsg :: SDoc -> CoreM ()
1075 putMsg = msg Err.putMsg
1076
1077 -- | Output a string error to the screen
1078 errorMsgS :: String -> CoreM ()
1079 errorMsgS = errorMsg . text
1080
1081 -- | Output an error to the screen
1082 errorMsg :: SDoc -> CoreM ()
1083 errorMsg = msg Err.errorMsg
1084
1085 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1086 fatalErrorMsgS :: String -> CoreM ()
1087 fatalErrorMsgS = fatalErrorMsg . text
1088
1089 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1090 fatalErrorMsg :: SDoc -> CoreM ()
1091 fatalErrorMsg = msg Err.fatalErrorMsg
1092
1093 -- | Output a string debugging message at verbosity level of @-v@ or higher
1094 debugTraceMsgS :: String -> CoreM ()
1095 debugTraceMsgS = debugTraceMsg . text
1096
1097 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1098 debugTraceMsg :: SDoc -> CoreM ()
1099 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1100
1101 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1102 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
1103 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1104 \end{code}
1105
1106
1107 %************************************************************************
1108 %*                                                                      *
1109                Finding TyThings
1110 %*                                                                      *
1111 %************************************************************************
1112
1113 \begin{code}
1114 instance MonadThings CoreM where
1115     lookupThing name = do
1116         hsc_env <- getHscEnv
1117         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1118 \end{code}
1119
1120 %************************************************************************
1121 %*                                                                      *
1122                Template Haskell interoperability
1123 %*                                                                      *
1124 %************************************************************************
1125
1126 \begin{code}
1127 #ifdef GHCI
1128 -- | Attempt to convert a Template Haskell name to one that GHC can
1129 -- understand. Original TH names such as those you get when you use
1130 -- the @'foo@ syntax will be translated to their equivalent GHC name
1131 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1132 -- to names in the module being compiled, if possible. Exact TH names
1133 -- will be bound to the name they represent, exactly.
1134 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1135 thNameToGhcName th_name = do
1136     hsc_env <- getHscEnv
1137     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
1138 #endif
1139 \end{code}