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