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