CoreMonad.lhs 43.9 KB
Newer Older
1 2 3 4 5 6
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[CoreMonad]{The core pipeline monad}

\begin{code}
7
{-# LANGUAGE CPP, UndecidableInstances #-}
Ian Lynagh's avatar
Ian Lynagh committed
8

9
module CoreMonad (
10
    -- * Configuration of the core-to-core passes
11
    CoreToDo(..), runWhen, runMaybe,
12 13
    SimplifierMode(..),
    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,
23
    isZeroSimplCount, hasDetailedCounts, Tick(..),
24

25 26
    -- * The monad
    CoreM, runCoreM,
27

28
    -- ** Reading from the monad
29
    getHscEnv, getRuleBase, getModule,
30
    getDynFlags, getOrigNameCache, getPackageFamInstEnv,
31
    getPrintUnqualified,
32

33 34
    -- ** Writing to the monad
    addSimplCount,
35

36 37 38
    -- ** Lifting into the monad
    liftIO, liftIOWithCount,
    liftIO1, liftIO2, liftIO3, liftIO4,
39

40
    -- ** Global initialization
41
    reinitializeGlobals,
42

43
    -- ** Dealing with annotations
44
    getAnnotations, getFirstAnnotations,
45

46
    -- ** Debug output
47
    showPass, showPassIO, endPass, endPassIO, dumpPassResult, lintPassResult,
48
    lintInteractiveExpr, dumpIfSet,
49

50
    -- ** Screen output
51 52
    putMsg, putMsgS, errorMsg, errorMsgS,
    fatalErrorMsg, fatalErrorMsgS,
53
    debugTraceMsg, debugTraceMsgS,
54
    dumpIfSet_dyn,
55 56 57 58 59 60 61

#ifdef GHCI
    -- * Getting 'Name's
    thNameToGhcName
#endif
  ) where

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
62 63 64
#ifdef GHCI
import Name( Name )
#endif
65 66 67
import CoreSyn
import PprCore
import CoreUtils
68
import CoreLint         ( lintCoreBindings, lintExpr )
69
import HscTypes
70
import Module
71
import DynFlags
72
import StaticFlags
73
import Rules            ( RuleBase )
74
import BasicTypes       ( CompilerPhase(..) )
75 76 77 78 79
import Annotations

import IOEnv hiding     ( liftIO, failM, failWithM )
import qualified IOEnv  ( liftIO )
import TcEnv            ( tcLookupGlobal )
80
import TcRnMonad        ( initTcForLookup )
81 82 83
import InstEnv          ( instanceDFunId )
import Type             ( tyVarsOfType )
import Id               ( idType )
84 85
import Var
import VarSet
86 87

import Outputable
88
import FastString
89
import qualified ErrUtils as Err
90
import Bag
91
import Maybes
92
import SrcLoc
93
import UniqSupply
94
import UniqFM       ( UniqFM, mapUFM, filterUFM )
95
import MonadUtils
96

Ian Lynagh's avatar
Ian Lynagh committed
97
import Util ( split )
98
import ListSetOps       ( runs )
Ian Lynagh's avatar
Ian Lynagh committed
99 100
import Data.List
import Data.Ord
101 102
import Data.Dynamic
import Data.IORef
103 104
import Data.Map (Map)
import qualified Data.Map as Map
105
import Data.Word
Austin Seipp's avatar
Austin Seipp committed
106
import qualified Control.Applicative as A
107 108 109 110 111
import Control.Monad

import Prelude hiding   ( read )

#ifdef GHCI
112 113
import Control.Concurrent.MVar (MVar)
import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
114 115
import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
import qualified Language.Haskell.TH as TH
116 117 118 119 120 121
#else
saveLinkerGlobals :: IO ()
saveLinkerGlobals = return ()

restoreLinkerGlobals :: () -> IO ()
restoreLinkerGlobals () = return ()
122 123 124
#endif
\end{code}

125
%************************************************************************
126
%*                                                                      *
127
                       Debug output
128
%*                                                                      *
129 130 131 132 133 134 135
%************************************************************************

These functions are not CoreM monad stuff, but they probably ought to
be, and it makes a conveneint place.  place for them.  They print out
stuff before and after core passes, and do Core Lint when necessary.

\begin{code}
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
showPass :: CoreToDo -> CoreM ()
showPass pass = do { dflags <- getDynFlags
                   ; liftIO $ showPassIO dflags pass }

showPassIO :: DynFlags -> CoreToDo -> IO ()
showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass)

endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass pass binds rules
  = do { hsc_env <- getHscEnv
       ; print_unqual <- getPrintUnqualified
       ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }

endPassIO :: HscEnv -> PrintUnqualified
          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
-- Used by the IO-is CorePrep too
endPassIO hsc_env print_unqual pass binds rules
  = do { dumpPassResult dflags print_unqual mb_flag
                        (ppr pass) (pprPassDetails pass) binds rules
155
       ; lintPassResult hsc_env pass binds }
156
  where
157
    dflags  = hsc_dflags hsc_env
158
    mb_flag = case coreDumpFlag pass of
159 160
                Just flag | dopt flag dflags                    -> Just flag
                          | dopt Opt_D_verbose_core2core dflags -> Just flag
161
                _ -> Nothing
162

163 164
dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet dflags dump_me pass extra_info doc
Ian Lynagh's avatar
Ian Lynagh committed
165
  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
166

167
dumpPassResult :: DynFlags
168 169
               -> PrintUnqualified
               -> Maybe DumpFlag        -- Just df => show details in a file whose
170 171 172 173
                                        --            name is specified by df
               -> SDoc                  -- Header
               -> SDoc                  -- Extra info to appear after header
               -> CoreProgram -> [CoreRule]
174
               -> IO ()
175
dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
176
  | Just flag <- mb_flag
177
  = Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
178 179

  | otherwise
180
  = Err.debugTraceMsg dflags 2 size_doc
181 182
          -- Report result size
          -- This has the side effect of forcing the intermediate to be evaluated
183

184
  where
185 186
    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]

187
    dump_doc  = vcat [ nest 2 extra_info
188
                     , size_doc
189
                     , blankLine
190
                     , pprCoreBindings binds
191
                     , ppUnless (null rules) pp_rules ]
192 193 194
    pp_rules = vcat [ blankLine
                    , ptext (sLit "------ Local rules for imported ids --------")
                    , pprRules rules ]
195

196 197 198 199 200 201
lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
lintPassResult hsc_env pass binds
  | not (gopt Opt_DoCoreLinting dflags)
  = return ()
  | otherwise
  = do { let (warns, errs) = lintCoreBindings (interactiveInScope hsc_env) binds
Ian Lynagh's avatar
Ian Lynagh committed
202
       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
203
       ; displayLintResults dflags pass warns errs binds  }
204
  where
205
    dflags = hsc_dflags hsc_env
206

207
displayLintResults :: DynFlags -> CoreToDo
208
                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
209 210 211
                   -> IO ()
displayLintResults dflags pass warns errs binds
  | not (isEmptyBag errs)
Ian Lynagh's avatar
Ian Lynagh committed
212
  = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
213
           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
214 215 216
                 , ptext (sLit "*** Offending Program ***")
                 , pprCoreBindings binds
                 , ptext (sLit "*** End of Offense ***") ])
217 218 219
       ; Err.ghcExit dflags 1 }

  | not (isEmptyBag warns)
220
  , not (case pass of { CoreDesugar -> True; _ -> False })
221 222 223 224
        -- Suppress warnings after desugaring pass because some
        -- are legitimate. Notably, the desugarer generates instance
        -- methods with INLINE pragmas that form a mutually recursive
        -- group.  Only afer a round of simplification are they unravelled.
225 226
  , not opt_NoDebugOutput
  , showLintWarnings pass
Ian Lynagh's avatar
Ian Lynagh committed
227
  = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
228
        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
229 230 231

  | otherwise = return ()
  where
232 233

lint_banner :: String -> SDoc -> SDoc
234
lint_banner string pass = ptext (sLit "*** Core Lint")      <+> text string
235 236
                          <+> ptext (sLit ": in result of") <+> pass
                          <+> ptext (sLit "***")
237 238 239 240

showLintWarnings :: CoreToDo -> Bool
-- Disable Lint warnings on the first simplifier pass, because
-- there may be some INLINE knots still tied, which is tiresomely noisy
241 242
showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
showLintWarnings _ = True
243 244 245 246 247

lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr what hsc_env expr
  | not (gopt Opt_DoCoreLinting dflags)
  = return ()
248
  | Just err <- lintExpr (interactiveInScope hsc_env) expr
249 250 251 252 253 254 255 256 257
  = do { display_lint_err err
       ; Err.ghcExit dflags 1 }
  | otherwise
  = return ()
  where
    dflags = hsc_dflags hsc_env

    display_lint_err err
      = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
258
               (vcat [ lint_banner "errors" (text what)
259 260 261 262 263 264 265 266 267
                     , err
                     , ptext (sLit "*** Offending Program ***")
                     , pprCoreExpr expr
                     , ptext (sLit "*** End of Offense ***") ])
           ; Err.ghcExit dflags 1 }

interactiveInScope :: HscEnv -> [Var]
-- In GHCi we may lint expressions, or bindings arising from 'deriving'
-- clauses, that mention variables bound in the interactive context.
268
-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).
269
-- So we have to tell Lint about them, lest it reports them as out of scope.
270
--
271 272 273 274
-- We do this by find local-named things that may appear free in interactive
-- context.  This function is pretty revolting and quite possibly not quite right.
-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
-- so this is a (cheap) no-op.
275
--
276
-- See Trac #8215 for an example
277
interactiveInScope hsc_env
278
  = varSetElems tyvars ++ ids
279
  where
280 281 282 283 284 285
    -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
    ictxt                   = hsc_IC hsc_env
    (cls_insts, _fam_insts) = ic_instances ictxt
    te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)
    te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
    ids    = typeEnvIds te
286
    tyvars = mapUnionVarSet (tyVarsOfType . idType) ids
287
              -- Why the type variables?  How can the top level envt have free tyvars?
288
              -- I think it's because of the GHCi debugger, which can bind variables
289 290
              --   f :: [t] -> [t]
              -- where t is a RuntimeUnk (see TcType)
291 292 293
\end{code}


294
%************************************************************************
295
%*                                                                      *
296
              The CoreToDo type and related types
297 298
          Abstraction of core-to-core passes to run.
%*                                                                      *
299 300 301
%************************************************************************

\begin{code}
302

303 304 305 306 307
data CoreToDo           -- These are diff core-to-core passes,
                        -- which may be invoked in any order,
                        -- as many times as you like.

  = CoreDoSimplify      -- The core-to-core simplifier.
308
        Int                    -- Max iterations
309
        SimplifierMode
310
  | CoreDoPluginPass String PluginPass
311 312 313 314 315
  | CoreDoFloatInwards
  | CoreDoFloatOutwards FloatOutSwitches
  | CoreLiberateCase
  | CoreDoPrintCore
  | CoreDoStaticArgs
316
  | CoreDoCallArity
317 318 319 320 321 322 323
  | CoreDoStrictness
  | CoreDoWorkerWrapper
  | CoreDoSpecialising
  | CoreDoSpecConstr
  | CoreCSE
  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                           -- matching this string
324
  | CoreDoVectorisation
325 326 327
  | CoreDoNothing                -- Useful when building up
  | CoreDoPasses [CoreToDo]      -- lists of these things

328 329 330
  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
                       --                 Core output, and hence useful to pass to endPass
331 332 333 334

  | CoreTidy
  | CorePrep

335 336 337
\end{code}

\begin{code}
338
coreDumpFlag :: CoreToDo -> Maybe DumpFlag
339
coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
340
coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_dump_core_pipeline
341 342 343
coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
344 345 346
coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity
coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
347 348 349
coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
350
coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
351
coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
352 353
coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds
coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds
354 355
coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
356 357 358 359 360 361 362

coreDumpFlag CoreDoPrintCore         = Nothing
coreDumpFlag (CoreDoRuleCheck {})    = Nothing
coreDumpFlag CoreDoNothing           = Nothing
coreDumpFlag (CoreDoPasses {})       = Nothing

instance Outputable CoreToDo where
363
  ppr (CoreDoSimplify _ _)     = ptext (sLit "Simplifier")
364
  ppr (CoreDoPluginPass s _)   = ptext (sLit "Core plugin: ") <+> text s
365 366 367
  ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
  ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
  ppr CoreLiberateCase         = ptext (sLit "Liberate case")
368 369 370
  ppr CoreDoStaticArgs         = ptext (sLit "Static argument")
  ppr CoreDoCallArity          = ptext (sLit "Called arity analysis")
  ppr CoreDoStrictness         = ptext (sLit "Demand analysis")
371 372 373 374
  ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
  ppr CoreDoSpecialising       = ptext (sLit "Specialise")
  ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
  ppr CoreCSE                  = ptext (sLit "Common sub-expression")
375
  ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
376 377
  ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
  ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
378
  ppr CoreTidy                 = ptext (sLit "Tidy Core")
379
  ppr CorePrep                 = ptext (sLit "CorePrep")
380 381 382 383
  ppr CoreDoPrintCore          = ptext (sLit "Print core")
  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
384 385

pprPassDetails :: CoreToDo -> SDoc
386
pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n
387
                                            , ppr md ]
388
pprPassDetails _ = Outputable.empty
389
\end{code}
390

391
\begin{code}
392
data SimplifierMode             -- See comments in SimplMonad
393 394 395 396 397 398 399 400
  = SimplMode
        { sm_names      :: [String] -- Name(s) of the phase
        , sm_phase      :: CompilerPhase
        , sm_rules      :: Bool     -- Whether RULES are enabled
        , sm_inline     :: Bool     -- Whether inlining is enabled
        , sm_case_case  :: Bool     -- Whether case-of-case is enabled
        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
        }
401 402

instance Outputable SimplifierMode where
403 404 405 406 407 408 409 410 411 412
    ppr (SimplMode { sm_phase = p, sm_names = ss
                   , sm_rules = r, sm_inline = i
                   , sm_eta_expand = eta, sm_case_case = cc })
       = ptext (sLit "SimplMode") <+> braces (
         sep [ ptext (sLit "Phase =") <+> ppr p <+>
               brackets (text (concat $ intersperse "," ss)) <> comma
             , pp_flag i   (sLit "inline") <> comma
             , pp_flag r   (sLit "rules") <> comma
             , pp_flag eta (sLit "eta-expand") <> comma
             , pp_flag cc  (sLit "case-of-case") ])
413
         where
414
           pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
415 416
\end{code}

417

418
\begin{code}
419
data FloatOutSwitches = FloatOutSwitches {
420
  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
421
                                   -- doing so will abstract over n or fewer
422
                                   -- value variables
423
                                   -- Nothing <=> float all lambdas to top level,
424 425 426 427 428 429
                                   --             regardless of how many free variables
                                   -- Just 0 is the vanilla case: float a lambda
                                   --    iff it has no free vars

  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
                                   --            even if they do not escape a lambda
430 431 432 433
  floatOutOverSatApps :: Bool      -- ^ True <=> float out over-saturated applications
                                   --            based on arity information.
                                   -- See Note [Floating over-saturated applications]
                                   -- in SetLevels
434
  }
435 436 437 438
instance Outputable FloatOutSwitches where
    ppr = pprFloatOutSwitches

pprFloatOutSwitches :: FloatOutSwitches -> SDoc
439
pprFloatOutSwitches sw
440
  = ptext (sLit "FOS") <+> (braces $
441
     sep $ punctuate comma $
442 443
     [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
     , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
444
     , ptext (sLit "OverSatApps =")   <+> ppr (floatOutOverSatApps sw) ])
445 446 447 448 449 450 451 452 453 454

-- The core-to-core pass ordering is derived from the DynFlags:
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen True  do_this = do_this
runWhen False _       = CoreDoNothing

runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe (Just x) f = f x
runMaybe Nothing  _ = CoreDoNothing

455

456 457 458 459 460
dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
dumpSimplPhase dflags mode
   | Just spec_string <- shouldDumpSimplPhase dflags
   = match_spec spec_string
   | otherwise
461
   = dopt Opt_D_verbose_core2core dflags
462 463 464

  where
    match_spec :: String -> Bool
465 466
    match_spec spec_string
      = or $ map (and . map match . split ':')
467 468 469 470 471 472 473 474 475
           $ split ',' spec_string

    match :: String -> Bool
    match "" = True
    match s  = case reads s of
                [(n,"")] -> phase_num  n
                _        -> phase_name s

    phase_num :: Int -> Bool
476 477 478
    phase_num n = case sm_phase mode of
                    Phase k -> n == k
                    _       -> False
479 480

    phase_name :: String -> Bool
481
    phase_name s = s `elem` sm_names mode
482 483 484
\end{code}


485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501
Note [RULEs enabled in SimplGently]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
RULES are enabled when doing "gentle" simplification.  Two reasons:

  * We really want the class-op cancellation to happen:
        op (df d1 d2) --> $cop3 d1 d2
    because this breaks the mutual recursion between 'op' and 'df'

  * I wanted the RULE
        lift String ===> ...
    to work in Template Haskell when simplifying
    splices, so we get simpler code for literal strings

But watch out: list fusion can prevent floating.  So use phase control
to switch off those rules until after floating.


502
%************************************************************************
503
%*                                                                      *
504
             Types for Plugins
505
%*                                                                      *
506 507 508 509 510 511 512 513 514 515 516 517
%************************************************************************

\begin{code}
-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type
type CommandLineOption = String

-- | 'Plugin' is the core compiler plugin data type. Try to avoid
-- constructing one of these directly, and just modify some fields of
-- 'defaultPlugin' instead: this is to try and preserve source-code
-- compatability when we add fields to this.
--
-- Nonetheless, this API is preliminary and highly likely to change in the future.
518
data Plugin = Plugin {
519
        installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
520
                -- ^ Modify the Core pipeline that will be used for compilation.
521
                -- This is called as the Core pipeline is built for every module
522
                --  being compiled, and plugins get the opportunity to modify
523 524 525 526 527 528 529 530 531 532 533 534 535
                -- the pipeline in a nondeterministic order.
     }

-- | Default plugin: does nothing at all! For compatability reasons you should base all your
-- plugin definitions on this default value.
defaultPlugin :: Plugin
defaultPlugin = Plugin {
        installCoreToDos = const return
    }

-- | A description of the plugin pass itself
type PluginPass = ModGuts -> CoreM ModGuts

536
bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
537 538 539 540 541 542
bindsOnlyPass pass guts
  = do { binds' <- pass (mg_binds guts)
       ; return (guts { mg_binds = binds' }) }
\end{code}


543
%************************************************************************
544
%*                                                                      *
545
             Counting and logging
546
%*                                                                      *
547 548 549 550
%************************************************************************

\begin{code}
verboseSimplStats :: Bool
551
verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
552

553
zeroSimplCount     :: DynFlags -> SimplCount
554
isZeroSimplCount   :: SimplCount -> Bool
555
hasDetailedCounts  :: SimplCount -> Bool
556
pprSimplCount      :: SimplCount -> SDoc
557 558
doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount
doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount
559 560 561 562
plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
\end{code}

\begin{code}
563 564 565 566 567 568 569 570 571 572 573 574 575
data SimplCount
   = VerySimplCount !Int        -- Used when don't want detailed stats

   | SimplCount {
        ticks   :: !Int,        -- Total ticks
        details :: !TickCounts, -- How many of each type

        n_log   :: !Int,        -- N
        log1    :: [Tick],      -- Last N events; <= opt_HistorySize,
                                --   most recent first
        log2    :: [Tick]       -- Last opt_HistorySize events before that
                                -- Having log1, log2 lets us accumulate the
                                -- recent history reasonably efficiently
576 577
     }

578
type TickCounts = Map Tick Int
579

580 581 582 583
simplCountN :: SimplCount -> Int
simplCountN (VerySimplCount n)         = n
simplCountN (SimplCount { ticks = n }) = n

584
zeroSimplCount dflags
585 586
                -- This is where we decide whether to do
                -- the VerySimpl version or the full-stats version
587
  | dopt Opt_D_dump_simpl_stats dflags
588
  = SimplCount {ticks = 0, details = Map.empty,
589 590
                n_log = 0, log1 = [], log2 = []}
  | otherwise
591
  = VerySimplCount 0
592

593
isZeroSimplCount (VerySimplCount n)         = n==0
594
isZeroSimplCount (SimplCount { ticks = n }) = n==0
595

596 597 598
hasDetailedCounts (VerySimplCount {}) = False
hasDetailedCounts (SimplCount {})     = True

599
doFreeSimplTick tick sc@SimplCount { details = dts }
600
  = sc { details = dts `addTick` tick }
601
doFreeSimplTick _ sc = sc
602

603 604 605 606
doSimplTick dflags tick
    sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })
  | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
  | otherwise                = sc1 { n_log = nl+1, log1 = tick : l1 }
607 608 609
  where
    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }

610
doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
611 612


613
-- Don't use Map.unionWith because that's lazy, and we want to
614 615
-- be pretty strict here!
addTick :: TickCounts -> Tick -> TickCounts
616
addTick fm tick = case Map.lookup tick fm of
617 618 619 620
                        Nothing -> Map.insert tick 1 fm
                        Just n  -> n1 `seq` Map.insert tick n1 fm
                                where
                                   n1 = n+1
621 622 623


plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
624
               sc2@(SimplCount { ticks = tks2, details = dts2 })
625
  = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
626
  where
627 628 629 630
        -- A hackish way of getting recent log info
    log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
             | null (log2 sc2) = sc2 { log2 = log1 sc1 }
             | otherwise       = sc2
631

632 633 634
plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
plusSimplCount _                  _                  = panic "plusSimplCount"
       -- We use one or the other consistently
635

636
pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
637 638
pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
  = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
639 640 641 642 643 644 645
          blankLine,
          pprTickCounts dts,
          if verboseSimplStats then
                vcat [blankLine,
                      ptext (sLit "Log (most recent first)"),
                      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
          else Outputable.empty
646 647
    ]

648 649 650 651
pprTickCounts :: Map Tick Int -> SDoc
pprTickCounts counts
  = vcat (map pprTickGroup groups)
  where
652 653
    groups :: [[(Tick,Int)]]    -- Each group shares a comon tag
                                -- toList returns common tags adjacent
654 655 656 657 658 659
    groups = runs same_tag (Map.toList counts)
    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2

pprTickGroup :: [(Tick, Int)] -> SDoc
pprTickGroup group@((tick1,_):_)
  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
660
       2 (vcat [ int n <+> pprTickCts tick
Ian Lynagh's avatar
Ian Lynagh committed
661 662
                                    -- flip as we want largest first
               | (tick,n) <- sortBy (flip (comparing snd)) group])
663
pprTickGroup [] = panic "pprTickGroup"
664 665 666 667 668
\end{code}


\begin{code}
data Tick
669 670
  = PreInlineUnconditionally    Id
  | PostInlineUnconditionally   Id
671

672 673
  | UnfoldingDone               Id
  | RuleFired                   FastString      -- Rule name
674 675

  | LetFloatFromLet
676 677 678
  | EtaExpansion                Id      -- LHS binder
  | EtaReduction                Id      -- Binder on outer lambda
  | BetaReduction               Id      -- Lambda binder
679 680


681 682 683 684 685 686 687
  | CaseOfCase                  Id      -- Bndr on *inner* case
  | KnownBranch                 Id      -- Case binder
  | CaseMerge                   Id      -- Binder on outer case
  | AltMerge                    Id      -- Case binder
  | CaseElim                    Id      -- Case binder
  | CaseIdentity                Id      -- Case binder
  | FillInCaseDefault           Id      -- Case binder
688

689 690
  | BottomFound
  | SimplifierDone              -- Ticked at each iteration of the simplifier
691 692 693 694 695 696 697 698 699 700 701 702 703

instance Outputable Tick where
  ppr tick = text (tickString tick) <+> pprTickCts tick

instance Eq Tick where
  a == b = case a `cmpTick` b of
           EQ -> True
           _ -> False

instance Ord Tick where
  compare = cmpTick

tickToTag :: Tick -> Int
704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720
tickToTag (PreInlineUnconditionally _)  = 0
tickToTag (PostInlineUnconditionally _) = 1
tickToTag (UnfoldingDone _)             = 2
tickToTag (RuleFired _)                 = 3
tickToTag LetFloatFromLet               = 4
tickToTag (EtaExpansion _)              = 5
tickToTag (EtaReduction _)              = 6
tickToTag (BetaReduction _)             = 7
tickToTag (CaseOfCase _)                = 8
tickToTag (KnownBranch _)               = 9
tickToTag (CaseMerge _)                 = 10
tickToTag (CaseElim _)                  = 11
tickToTag (CaseIdentity _)              = 12
tickToTag (FillInCaseDefault _)         = 13
tickToTag BottomFound                   = 14
tickToTag SimplifierDone                = 16
tickToTag (AltMerge _)                  = 17
721 722

tickString :: Tick -> String
723
tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
724
tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
725 726 727 728 729 730 731 732 733 734 735 736 737 738 739
tickString (UnfoldingDone _)            = "UnfoldingDone"
tickString (RuleFired _)                = "RuleFired"
tickString LetFloatFromLet              = "LetFloatFromLet"
tickString (EtaExpansion _)             = "EtaExpansion"
tickString (EtaReduction _)             = "EtaReduction"
tickString (BetaReduction _)            = "BetaReduction"
tickString (CaseOfCase _)               = "CaseOfCase"
tickString (KnownBranch _)              = "KnownBranch"
tickString (CaseMerge _)                = "CaseMerge"
tickString (AltMerge _)                 = "AltMerge"
tickString (CaseElim _)                 = "CaseElim"
tickString (CaseIdentity _)             = "CaseIdentity"
tickString (FillInCaseDefault _)        = "FillInCaseDefault"
tickString BottomFound                  = "BottomFound"
tickString SimplifierDone               = "SimplifierDone"
740 741

pprTickCts :: Tick -> SDoc
742
pprTickCts (PreInlineUnconditionally v) = ppr v
743
pprTickCts (PostInlineUnconditionally v)= ppr v
744 745 746 747 748 749 750 751 752 753 754 755 756 757
pprTickCts (UnfoldingDone v)            = ppr v
pprTickCts (RuleFired v)                = ppr v
pprTickCts LetFloatFromLet              = Outputable.empty
pprTickCts (EtaExpansion v)             = ppr v
pprTickCts (EtaReduction v)             = ppr v
pprTickCts (BetaReduction v)            = ppr v
pprTickCts (CaseOfCase v)               = ppr v
pprTickCts (KnownBranch v)              = ppr v
pprTickCts (CaseMerge v)                = ppr v
pprTickCts (AltMerge v)                 = ppr v
pprTickCts (CaseElim v)                 = ppr v
pprTickCts (CaseIdentity v)             = ppr v
pprTickCts (FillInCaseDefault v)        = ppr v
pprTickCts _                            = Outputable.empty
758 759 760

cmpTick :: Tick -> Tick -> Ordering
cmpTick a b = case (tickToTag a `compare` tickToTag b) of
761 762 763
                GT -> GT
                EQ -> cmpEqTick a b
                LT -> LT
764 765

cmpEqTick :: Tick -> Tick -> Ordering
766 767 768 769 770 771 772 773 774 775 776 777 778 779 780
cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
cmpEqTick _                             _                               = EQ
781 782 783
\end{code}


784
%************************************************************************
785
%*                                                                      *
786
             Monad and carried data structure definitions
787
%*                                                                      *
788
%************************************************************************
789 790

\begin{code}
791 792
newtype CoreState = CoreState {
        cs_uniq_supply :: UniqSupply
793 794 795 796 797
}

data CoreReader = CoreReader {
        cr_hsc_env :: HscEnv,
        cr_rule_base :: RuleBase,
798
        cr_module :: Module,
799
        cr_print_unqual :: PrintUnqualified,
800
#ifdef GHCI
801
        cr_globals :: (MVar PersistentLinkerState, Bool)
802
#else
803
        cr_globals :: ()
804
#endif
805 806 807
}

data CoreWriter = CoreWriter {
808
        cw_simpl_count :: !SimplCount
809 810
        -- Making this strict fixes a nasty space leak
        -- See Trac #7702
811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838
}

emptyWriter :: DynFlags -> CoreWriter
emptyWriter dflags = CoreWriter {
        cw_simpl_count = zeroSimplCount dflags
    }

plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
plusWriter w1 w2 = CoreWriter {
        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
    }

type CoreIOEnv = IOEnv CoreReader

-- | The monad used by Core-to-Core passes to access common state, register simplification
-- statistics and so on
newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }

instance Functor CoreM where
    fmap f ma = do
        a <- ma
        return (f a)

instance Monad CoreM where
    return x = CoreM (\s -> nop s x)
    mx >>= f = CoreM $ \s -> do
            (x, s', w1) <- unCoreM mx s
            (y, s'', w2) <- unCoreM (f x) s'
839 840
            let w = w1 `plusWriter` w2 -- forcing w before returning avoids a space leak (Trac #7702)
            return $ seq w (y, s'', w)
841

Austin Seipp's avatar
Austin Seipp committed
842
instance A.Applicative CoreM where
843 844 845
    pure = return
    (<*>) = ap

Austin Seipp's avatar
Austin Seipp committed
846 847 848 849
instance MonadPlus IO => A.Alternative CoreM where
    empty = mzero
    (<|>) = mplus

850 851 852 853 854 855 856 857 858 859 860 861 862
-- For use if the user has imported Control.Monad.Error from MTL
-- Requires UndecidableInstances
instance MonadPlus IO => MonadPlus CoreM where
    mzero = CoreM (const mzero)
    m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)

instance MonadUnique CoreM where
    getUniqueSupplyM = do
        us <- getS cs_uniq_supply
        let (us1, us2) = splitUniqSupply us
        modifyS (\s -> s { cs_uniq_supply = us2 })
        return us1

863 864 865 866 867 868
    getUniqueM = do
        us <- getS cs_uniq_supply
        let (u,us') = takeUniqFromSupply us
        modifyS (\s -> s { cs_uniq_supply = us' })
        return u

869 870 871 872
runCoreM :: HscEnv
         -> RuleBase
         -> UniqSupply
         -> Module
873
         -> PrintUnqualified
874 875
         -> CoreM a
         -> IO (a, SimplCount)
876
runCoreM hsc_env rule_base us mod print_unqual m = do
877
        glbls <- saveLinkerGlobals
878
        liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
879
  where
880
    reader glbls = CoreReader {
881 882
            cr_hsc_env = hsc_env,
            cr_rule_base = rule_base,
883
            cr_module = mod,
884 885
            cr_globals = glbls,
            cr_print_unqual = print_unqual
886
        }
887
    state = CoreState {
888
            cs_uniq_supply = us
889 890 891 892 893 894 895
        }

    extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
    extract (value, _, writer) = (value, cw_simpl_count writer)

\end{code}

896 897

%************************************************************************
898
%*                                                                      *
899
             Core combinators, not exported
900
%*                                                                      *
901
%************************************************************************
902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940

\begin{code}

nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
nop s x = do
    r <- getEnv
    return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)

read :: (CoreReader -> a) -> CoreM a
read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))

getS :: (CoreState -> a) -> CoreM a
getS f = CoreM (\s -> nop s (f s))

modifyS :: (CoreState -> CoreState) -> CoreM ()
modifyS f = CoreM (\s -> nop (f s) ())

write :: CoreWriter -> CoreM ()
write w = CoreM (\s -> return ((), s, w))

\end{code}

\subsection{Lifting IO into the monad}

\begin{code}

-- | Lift an 'IOEnv' operation into 'CoreM'
liftIOEnv :: CoreIOEnv a -> CoreM a
liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))

instance MonadIO CoreM where
    liftIO = liftIOEnv . IOEnv.liftIO

-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
liftIOWithCount :: IO (SimplCount, a) -> CoreM a
liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)

\end{code}

941 942

%************************************************************************
943
%*                                                                      *
944
             Reader, writer and state accessors
945
%*                                                                      *
946
%************************************************************************
947 948 949 950 951 952 953 954

\begin{code}
getHscEnv :: CoreM HscEnv
getHscEnv = read cr_hsc_env

getRuleBase :: CoreM RuleBase
getRuleBase = read cr_rule_base

955 956 957
getPrintUnqualified :: CoreM PrintUnqualified
getPrintUnqualified = read cr_print_unqual

958 959 960 961 962
addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count })

-- Convenience accessors for useful fields of HscEnv

963 964
instance HasDynFlags CoreM where
    getDynFlags = fmap hsc_dflags getHscEnv
965

966 967 968
instance HasModule CoreM where
    getModule = read cr_module

969 970 971 972 973 974
-- | The original name cache is the current mapping from 'Module' and
-- 'OccName' to a compiler-wide unique 'Name'
getOrigNameCache :: CoreM OrigNameCache
getOrigNameCache = do
    nameCacheRef <- fmap hsc_NC getHscEnv
    liftIO $ fmap nsNames $ readIORef nameCacheRef
975 976 977 978 979 980

getPackageFamInstEnv :: CoreM PackageFamInstEnv
getPackageFamInstEnv = do
    hsc_env <- getHscEnv
    eps <- liftIO $ hscEPS hsc_env
    return $ eps_fam_inst_env eps
981 982
\end{code}

983
%************************************************************************
984
%*                                                                      *
985
             Initializing globals
986
%*                                                                      *