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