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