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