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