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(..),
  12     SimplifierMode(..),
  13     SimplifierSwitch(..),
  14     FloatOutSwitches(..),
  15     getCoreToDo, dumpSimplPhase,
  16
  17     -- * Counting
  18     SimplCount, doSimplTick, doFreeSimplTick,
  19     pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
  20
  21     -- * The monad
  22     CoreM, runCoreM,
  23
  24     -- ** Reading from the monad
  25     getHscEnv, getRuleBase, getModule,
  26     getDynFlags, getOrigNameCache,
  27
  28     -- ** Writing to the monad
  29     addSimplCount,
  30
  31     -- ** Lifting into the monad
  32     liftIO, liftIOWithCount,
  33     liftIO1, liftIO2, liftIO3, liftIO4,
  34
  35     -- ** Dealing with annotations
  36     getAnnotations, getFirstAnnotations,
  37
  38     -- ** Debug output
  39     showPass, endPass, endIteration, dumpIfSet,
  40
  41     -- ** Screen output
  42     putMsg, putMsgS, errorMsg, errorMsgS,
  43     fatalErrorMsg, fatalErrorMsgS,
  44     debugTraceMsg, debugTraceMsgS,
  45     dumpIfSet_dyn,
  46
  47 #ifdef GHCI
  48     -- * Getting 'Name's
  49     thNameToGhcName
  50 #endif
  51   ) where
  52
  53 #ifdef GHCI
  54 import Name( Name )
  55 #endif
  56 import CoreSyn
  57 import PprCore
  58 import CoreUtils
  59 import CoreLint         ( lintCoreBindings )
  60 import PrelNames        ( iNTERACTIVE )
  61 import HscTypes
  62 import Module           ( PackageId, Module )
  63 import DynFlags
  64 import StaticFlags
  65 import Rules            ( RuleBase )
  66 import BasicTypes       ( CompilerPhase )
  67 import Annotations
  68 import Id               ( Id )
  69
  70 import IOEnv hiding     ( liftIO, failM, failWithM )
  71 import qualified IOEnv  ( liftIO )
  72 import TcEnv            ( tcLookupGlobal )
  73 import TcRnMonad        ( TcM, initTc )
  74
  75 import Outputable
  76 import FastString
  77 import qualified ErrUtils as Err
  78 import Bag
  79 import Maybes
  80 import UniqSupply
  81 import UniqFM       ( UniqFM, mapUFM, filterUFM )
  82 import FiniteMap
  83
  84 import Util             ( split )
  85 import Data.List        ( intersperse )
  86 import Data.Dynamic
  87 import Data.IORef
  88 import Data.Word
  89 import Control.Monad
  90
  91 import Prelude hiding   ( read )
  92
  93 #ifdef GHCI
  94 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
  95 import qualified Language.Haskell.TH as TH
  96 #endif
  97 \end{code}
  98
  99 %************************************************************************
 100 %*                                                                      *
 101                        Debug output
 102 %*                                                                      *
 103 %************************************************************************
 104
 105 These functions are not CoreM monad stuff, but they probably ought to
 106 be, and it makes a conveneint place.  place for them.  They print out
 107 stuff before and after core passes, and do Core Lint when necessary.
 108
 109 \begin{code}
 110 showPass :: DynFlags -> CoreToDo -> IO ()
 111 showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
 112
 113 endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
 114 endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
 115
 116 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
 117 endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
 118 endIteration dflags pass n
 119   = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
 120                 (Just Opt_D_dump_simpl_iterations)
 121
 122 dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
 123 dumpIfSet dump_me pass extra_info doc
 124   = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
 125
 126 dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
 127             -> [CoreBind] -> [CoreRule] -> IO ()
 128 -- The "show_all" parameter says to print dump if -dverbose-core2core is on
 129 dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
 130   = do {  -- Report result size if required
 131           -- This has the side effect of forcing the intermediate to be evaluated
 132        ; Err.debugTraceMsg dflags 2 $
 133                 (text "    Result size =" <+> int (coreBindsSize binds))
 134
 135         -- Report verbosely, if required
 136        ; let pass_name = showSDoc (ppr pass <+> extra_info)
 137              dump_doc  = pprCoreBindings binds
 138                          $$ ppUnless (null rules) pp_rules
 139
 140        ; case mb_dump_flag of
 141             Nothing        -> return ()
 142             Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
 143                where
 144                  dump_flags | show_all  = [dump_flag, Opt_D_verbose_core2core]
 145                             | otherwise = [dump_flag]
 146
 147         -- Type check
 148        ; when (dopt Opt_DoCoreLinting dflags) $
 149          do { let (warns, errs) = lintCoreBindings binds
 150             ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
 151             ; displayLintResults dflags pass warns errs binds  } }
 152   where
 153     pp_rules = vcat [ blankLine
 154                     , ptext (sLit "------ Local rules for imported ids --------")
 155                     , pprRules rules ]
 156
 157 displayLintResults :: DynFlags -> CoreToDo
 158                    -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
 159                    -> IO ()
 160 displayLintResults dflags pass warns errs binds
 161   | not (isEmptyBag errs)
 162   = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
 163                          , ptext (sLit "*** Offending Program ***")
 164                          , pprCoreBindings binds
 165                          , ptext (sLit "*** End of Offense ***") ])
 166        ; Err.ghcExit dflags 1 }
 167
 168   | not (isEmptyBag warns)
 169   , not opt_NoDebugOutput
 170   , showLintWarnings pass
 171   = printDump (banner "warnings" $$ Err.pprMessageBag warns)
 172
 173   | otherwise = return ()
 174   where
 175     banner string = ptext (sLit "*** Core Lint")      <+> text string
 176                     <+> ptext (sLit ": in result of") <+> ppr pass
 177                     <+> ptext (sLit "***")
 178
 179 showLintWarnings :: CoreToDo -> Bool
 180 -- Disable Lint warnings on the first simplifier pass, because
 181 -- there may be some INLINE knots still tied, which is tiresomely noisy
 182 showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
 183 showLintWarnings _                                     = True
 184 \end{code}
 185
 186
 187 %************************************************************************
 188 %*                                                                      *
 189               The CoreToDo type and related types
 190           Abstraction of core-to-core passes to run.
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 \begin{code}
 195 data CoreToDo           -- These are diff core-to-core passes,
 196                         -- which may be invoked in any order,
 197                         -- as many times as you like.
 198
 199   = CoreDoSimplify      -- The core-to-core simplifier.
 200         SimplifierMode
 201         Int                    -- Max iterations
 202         [SimplifierSwitch]     -- Each run of the simplifier can take a different
 203                                -- set of simplifier-specific flags.
 204   | CoreDoFloatInwards
 205   | CoreDoFloatOutwards FloatOutSwitches
 206   | CoreLiberateCase
 207   | CoreDoPrintCore
 208   | CoreDoStaticArgs
 209   | CoreDoStrictness
 210   | CoreDoWorkerWrapper
 211   | CoreDoSpecialising
 212   | CoreDoSpecConstr
 213   | CoreDoGlomBinds
 214   | CoreCSE
 215   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
 216                                            -- matching this string
 217   | CoreDoVectorisation PackageId
 218   | CoreDoNothing                -- Useful when building up
 219   | CoreDoPasses [CoreToDo]      -- lists of these things
 220
 221   | CoreDesugar  -- Not strictly a core-to-core pass, but produces
 222                  -- Core output, and hence useful to pass to endPass
 223
 224   | CoreTidy
 225   | CorePrep
 226
 227 coreDumpFlag :: CoreToDo -> Maybe DynFlag
 228 coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_dump_simpl_phases
 229 coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
 230 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 231 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
 232 coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
 233 coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
 234 coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 235 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 236 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 237 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
 238 coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
 239 coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds
 240 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 241 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 242
 243 coreDumpFlag CoreDoPrintCore         = Nothing
 244 coreDumpFlag (CoreDoRuleCheck {})    = Nothing
 245 coreDumpFlag CoreDoNothing           = Nothing
 246 coreDumpFlag CoreDoGlomBinds         = Nothing
 247 coreDumpFlag (CoreDoPasses {})       = Nothing
 248
 249 instance Outputable CoreToDo where
 250   ppr (CoreDoSimplify md n _)  = ptext (sLit "Simplifier")
 251                                  <+> ppr md
 252                                  <+> ptext (sLit "max-iterations=") <> int n
 253   ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
 254   ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
 255   ppr CoreLiberateCase         = ptext (sLit "Liberate case")
 256   ppr CoreDoStaticArgs         = ptext (sLit "Static argument")
 257   ppr CoreDoStrictness         = ptext (sLit "Demand analysis")
 258   ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
 259   ppr CoreDoSpecialising       = ptext (sLit "Specialise")
 260   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
 261   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
 262   ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
 263   ppr CoreDesugar              = ptext (sLit "Desugar")
 264   ppr CoreTidy                 = ptext (sLit "Tidy Core")
 265   ppr CorePrep                 = ptext (sLit "CorePrep")
 266   ppr CoreDoPrintCore          = ptext (sLit "Print core")
 267   ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
 268   ppr CoreDoGlomBinds          = ptext (sLit "Glom binds")
 269   ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
 270   ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
 271 \end{code}
 272
 273 \begin{code}
 274 data SimplifierMode             -- See comments in SimplMonad
 275   = SimplGently
 276         { sm_rules :: Bool      -- Whether RULES are enabled
 277         , sm_inline :: Bool }   -- Whether inlining is enabled
 278
 279   | SimplPhase
 280         { sm_num :: Int           -- Phase number; counts downward so 0 is last phase
 281         , sm_names :: [String] }  -- Name(s) of the phase
 282
 283 instance Outputable SimplifierMode where
 284     ppr (SimplPhase { sm_num = n, sm_names = ss })
 285        = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
 286     ppr (SimplGently { sm_rules = r, sm_inline = i })
 287        = ptext (sLit "gentle") <>
 288            brackets (pp_flag r (sLit "rules") <> comma <>
 289                      pp_flag i (sLit "inline"))
 290          where
 291            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
 292
 293 data SimplifierSwitch
 294   = NoCaseOfCase
 295 \end{code}
 296
 297
 298 \begin{code}
 299 data FloatOutSwitches = FloatOutSwitches {
 300         floatOutLambdas :: Bool,     -- ^ True <=> float lambdas to top level
 301         floatOutConstants :: Bool    -- ^ True <=> float constants to top level,
 302                                      --            even if they do not escape a lambda
 303     }
 304 instance Outputable FloatOutSwitches where
 305     ppr = pprFloatOutSwitches
 306
 307 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
 308 pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
 309                      <+> pp_not (floatOutConstants sw) <+> text "constants"
 310   where
 311     pp_not True  = empty
 312     pp_not False = text "not"
 313
 314 -- | Switches that specify the minimum amount of floating out
 315 -- gentleFloatOutSwitches :: FloatOutSwitches
 316 -- gentleFloatOutSwitches = FloatOutSwitches False False
 317
 318 -- | Switches that do not specify floating out of lambdas, just of constants
 319 constantsOnlyFloatOutSwitches :: FloatOutSwitches
 320 constantsOnlyFloatOutSwitches = FloatOutSwitches False True
 321 \end{code}
 322
 323
 324 %************************************************************************
 325 %*                                                                      *
 326            Generating the main optimisation pipeline
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 \begin{code}
 331 getCoreToDo :: DynFlags -> [CoreToDo]
 332 getCoreToDo dflags
 333   = core_todo
 334   where
 335     opt_level     = optLevel dflags
 336     phases        = simplPhases dflags
 337     max_iter      = maxSimplIterations dflags
 338     strictness    = dopt Opt_Strictness dflags
 339     full_laziness = dopt Opt_FullLaziness dflags
 340     do_specialise = dopt Opt_Specialise dflags
 341     do_float_in   = dopt Opt_FloatIn dflags
 342     cse           = dopt Opt_CSE dflags
 343     spec_constr   = dopt Opt_SpecConstr dflags
 344     liberate_case = dopt Opt_LiberateCase dflags
 345     rule_check    = ruleCheck dflags
 346     static_args   = dopt Opt_StaticArgumentTransformation dflags
 347
 348     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
 349
 350     maybe_strictness_before phase
 351       = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
 352
 353     simpl_phase phase names iter
 354       = CoreDoPasses
 355           [ maybe_strictness_before phase
 356           , CoreDoSimplify (SimplPhase phase names)
 357                            iter []
 358           , maybe_rule_check phase
 359           ]
 360
 361     vectorisation
 362       = runWhen (dopt Opt_Vectorise dflags)
 363         $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
 364
 365
 366                 -- By default, we have 2 phases before phase 0.
 367
 368                 -- Want to run with inline phase 2 after the specialiser to give
 369                 -- maximum chance for fusion to work before we inline build/augment
 370                 -- in phase 1.  This made a difference in 'ansi' where an
 371                 -- overloaded function wasn't inlined till too late.
 372
 373                 -- Need phase 1 so that build/augment get
 374                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 375                 -- strictness in the function sumcode' if augment is not inlined
 376                 -- before strictness analysis runs
 377     simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
 378                                   | phase <- [phases, phases-1 .. 1] ]
 379
 380
 381         -- initial simplify: mk specialiser happy: minimum effort please
 382     simpl_gently = CoreDoSimplify
 383                        (SimplGently { sm_rules = True, sm_inline = False })
 384                           -- See Note [Gentle mode] and
 385                           -- Note [RULEs enabled in SimplGently] in SimplUtils
 386                        max_iter
 387                        [
 388
 389
 390             NoCaseOfCase        -- Don't do case-of-case transformations.
 391                                 -- This makes full laziness work better
 392         ]
 393
 394     core_todo =
 395      if opt_level == 0 then
 396        [vectorisation,
 397         simpl_phase 0 ["final"] max_iter]
 398      else {- opt_level >= 1 -} [
 399
 400     -- We want to do the static argument transform before full laziness as it
 401     -- may expose extra opportunities to float things outwards. However, to fix
 402     -- up the output of the transformation we need at do at least one simplify
 403     -- after this before anything else
 404         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
 405
 406         -- We run vectorisation here for now, but we might also try to run
 407         -- it later
 408         vectorisation,
 409
 410         -- initial simplify: mk specialiser happy: minimum effort please
 411         simpl_gently,
 412
 413         -- Specialisation is best done before full laziness
 414         -- so that overloaded functions have all their dictionary lambdas manifest
 415         runWhen do_specialise CoreDoSpecialising,
 416
 417         runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
 418                 -- Was: gentleFloatOutSwitches
 419                 -- I have no idea why, but not floating constants to top level is
 420                 -- very bad in some cases.
 421                 -- Notably: p_ident in spectral/rewrite
 422                 --          Changing from "gentle" to "constantsOnly" improved
 423                 --          rewrite's allocation by 19%, and made  0.0% difference
 424                 --          to any other nofib benchmark
 425
 426         runWhen do_float_in CoreDoFloatInwards,
 427
 428         simpl_phases,
 429
 430                 -- Phase 0: allow all Ids to be inlined now
 431                 -- This gets foldr inlined before strictness analysis
 432
 433                 -- At least 3 iterations because otherwise we land up with
 434                 -- huge dead expressions because of an infelicity in the
 435                 -- simpifier.
 436                 --      let k = BIG in foldr k z xs
 437                 -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
 438                 -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
 439                 -- Don't stop now!
 440         simpl_phase 0 ["main"] (max max_iter 3),
 441
 442         runWhen strictness (CoreDoPasses [
 443                 CoreDoStrictness,
 444                 CoreDoWorkerWrapper,
 445                 CoreDoGlomBinds,
 446                 simpl_phase 0 ["post-worker-wrapper"] max_iter
 447                 ]),
 448
 449         runWhen full_laziness
 450           (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
 451                 -- nofib/spectral/hartel/wang doubles in speed if you
 452                 -- do full laziness late in the day.  It only happens
 453                 -- after fusion and other stuff, so the early pass doesn't
 454                 -- catch it.  For the record, the redex is
 455                 --        f_el22 (f_el21 r_midblock)
 456
 457
 458         runWhen cse CoreCSE,
 459                 -- We want CSE to follow the final full-laziness pass, because it may
 460                 -- succeed in commoning up things floated out by full laziness.
 461                 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
 462
 463         runWhen do_float_in CoreDoFloatInwards,
 464
 465         maybe_rule_check 0,
 466
 467                 -- Case-liberation for -O2.  This should be after
 468                 -- strictness analysis and the simplification which follows it.
 469         runWhen liberate_case (CoreDoPasses [
 470             CoreLiberateCase,
 471             simpl_phase 0 ["post-liberate-case"] max_iter
 472             ]),         -- Run the simplifier after LiberateCase to vastly
 473                         -- reduce the possiblility of shadowing
 474                         -- Reason: see Note [Shadowing] in SpecConstr.lhs
 475
 476         runWhen spec_constr CoreDoSpecConstr,
 477
 478         maybe_rule_check 0,
 479
 480         -- Final clean-up simplification:
 481         simpl_phase 0 ["final"] max_iter
 482      ]
 483
 484 -- The core-to-core pass ordering is derived from the DynFlags:
 485 runWhen :: Bool -> CoreToDo -> CoreToDo
 486 runWhen True  do_this = do_this
 487 runWhen False _       = CoreDoNothing
 488
 489 runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
 490 runMaybe (Just x) f = f x
 491 runMaybe Nothing  _ = CoreDoNothing
 492
 493 dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
 494 dumpSimplPhase dflags mode
 495    | Just spec_string <- shouldDumpSimplPhase dflags
 496    = match_spec spec_string
 497    | otherwise
 498    = dopt Opt_D_verbose_core2core dflags
 499
 500   where
 501     match_spec :: String -> Bool
 502     match_spec spec_string
 503       = or $ map (and . map match . split ':')
 504            $ split ',' spec_string
 505
 506     match :: String -> Bool
 507     match "" = True
 508     match s  = case reads s of
 509                 [(n,"")] -> phase_num  n
 510                 _        -> phase_name s
 511
 512     phase_num :: Int -> Bool
 513     phase_num n = case mode of
 514                     SimplPhase k _ -> n == k
 515                     _              -> False
 516
 517     phase_name :: String -> Bool
 518     phase_name s = case mode of
 519                      SimplGently {}               -> s == "gentle"
 520                      SimplPhase { sm_names = ss } -> s `elem` ss
 521 \end{code}
 522
 523
 524 %************************************************************************
 525 %*                                                                      *
 526              Counting and logging
 527 %*                                                                      *
 528 %************************************************************************
 529
 530 \begin{code}
 531 verboseSimplStats :: Bool
 532 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
 533
 534 zeroSimplCount     :: DynFlags -> SimplCount
 535 isZeroSimplCount   :: SimplCount -> Bool
 536 pprSimplCount      :: SimplCount -> SDoc
 537 doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
 538 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 539 \end{code}
 540
 541 \begin{code}
 542 data SimplCount
 543    = VerySimplZero              -- These two are used when
 544    | VerySimplNonZero   -- we are only interested in
 545                                 -- termination info
 546
 547    | SimplCount {
 548         ticks   :: !Int,        -- Total ticks
 549         details :: !TickCounts, -- How many of each type
 550
 551         n_log   :: !Int,        -- N
 552         log1    :: [Tick],      -- Last N events; <= opt_HistorySize,
 553                                 --   most recent first
 554         log2    :: [Tick]       -- Last opt_HistorySize events before that
 555                                 -- Having log1, log2 lets us accumulate the
 556                                 -- recent history reasonably efficiently
 557      }
 558
 559 type TickCounts = FiniteMap Tick Int
 560
 561 zeroSimplCount dflags
 562                 -- This is where we decide whether to do
 563                 -- the VerySimpl version or the full-stats version
 564   | dopt Opt_D_dump_simpl_stats dflags
 565   = SimplCount {ticks = 0, details = emptyFM,
 566                 n_log = 0, log1 = [], log2 = []}
 567   | otherwise
 568   = VerySimplZero
 569
 570 isZeroSimplCount VerySimplZero              = True
 571 isZeroSimplCount (SimplCount { ticks = 0 }) = True
 572 isZeroSimplCount _                          = False
 573
 574 doFreeSimplTick tick sc@SimplCount { details = dts }
 575   = sc { details = dts `addTick` tick }
 576 doFreeSimplTick _ sc = sc
 577
 578 doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
 579   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
 580   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
 581   where
 582     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 583
 584 doSimplTick _ _ = VerySimplNonZero -- The very simple case
 585
 586
 587 -- Don't use plusFM_C because that's lazy, and we want to
 588 -- be pretty strict here!
 589 addTick :: TickCounts -> Tick -> TickCounts
 590 addTick fm tick = case lookupFM fm tick of
 591                         Nothing -> addToFM fm tick 1
 592                         Just n  -> n1 `seq` addToFM fm tick n1
 593                                 where
 594                                    n1 = n+1
 595
 596
 597 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
 598                sc2@(SimplCount { ticks = tks2, details = dts2 })
 599   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
 600   where
 601         -- A hackish way of getting recent log info
 602     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
 603              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
 604              | otherwise       = sc2
 605
 606 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
 607 plusSimplCount _             _             = VerySimplNonZero
 608
 609 pprSimplCount VerySimplZero    = ptext (sLit "Total ticks: ZERO!")
 610 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
 611 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 612   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
 613           blankLine,
 614           pprTickCounts (fmToList dts),
 615           if verboseSimplStats then
 616                 vcat [blankLine,
 617                       ptext (sLit "Log (most recent first)"),
 618                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 619           else empty
 620     ]
 621
 622 pprTickCounts :: [(Tick,Int)] -> SDoc
 623 pprTickCounts [] = empty
 624 pprTickCounts ((tick1,n1):ticks)
 625   = vcat [int tot_n <+> text (tickString tick1),
 626           pprTCDetails real_these,
 627           pprTickCounts others
 628     ]
 629   where
 630     tick1_tag           = tickToTag tick1
 631     (these, others)     = span same_tick ticks
 632     real_these          = (tick1,n1):these
 633     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
 634     tot_n               = sum [n | (_,n) <- real_these]
 635
 636 pprTCDetails :: [(Tick, Int)] -> SDoc
 637 pprTCDetails ticks
 638   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 639 \end{code}
 640
 641
 642 \begin{code}
 643 data Tick
 644   = PreInlineUnconditionally    Id
 645   | PostInlineUnconditionally   Id
 646
 647   | UnfoldingDone               Id
 648   | RuleFired                   FastString      -- Rule name
 649
 650   | LetFloatFromLet
 651   | EtaExpansion                Id      -- LHS binder
 652   | EtaReduction                Id      -- Binder on outer lambda
 653   | BetaReduction               Id      -- Lambda binder
 654
 655
 656   | CaseOfCase                  Id      -- Bndr on *inner* case
 657   | KnownBranch                 Id      -- Case binder
 658   | CaseMerge                   Id      -- Binder on outer case
 659   | AltMerge                    Id      -- Case binder
 660   | CaseElim                    Id      -- Case binder
 661   | CaseIdentity                Id      -- Case binder
 662   | FillInCaseDefault           Id      -- Case binder
 663
 664   | BottomFound
 665   | SimplifierDone              -- Ticked at each iteration of the simplifier
 666
 667 instance Outputable Tick where
 668   ppr tick = text (tickString tick) <+> pprTickCts tick
 669
 670 instance Eq Tick where
 671   a == b = case a `cmpTick` b of
 672            EQ -> True
 673            _ -> False
 674
 675 instance Ord Tick where
 676   compare = cmpTick
 677
 678 tickToTag :: Tick -> Int
 679 tickToTag (PreInlineUnconditionally _)  = 0
 680 tickToTag (PostInlineUnconditionally _) = 1
 681 tickToTag (UnfoldingDone _)             = 2
 682 tickToTag (RuleFired _)                 = 3
 683 tickToTag LetFloatFromLet               = 4
 684 tickToTag (EtaExpansion _)              = 5
 685 tickToTag (EtaReduction _)              = 6
 686 tickToTag (BetaReduction _)             = 7
 687 tickToTag (CaseOfCase _)                = 8
 688 tickToTag (KnownBranch _)               = 9
 689 tickToTag (CaseMerge _)                 = 10
 690 tickToTag (CaseElim _)                  = 11
 691 tickToTag (CaseIdentity _)              = 12
 692 tickToTag (FillInCaseDefault _)         = 13
 693 tickToTag BottomFound                   = 14
 694 tickToTag SimplifierDone                = 16
 695 tickToTag (AltMerge _)                  = 17
 696
 697 tickString :: Tick -> String
 698 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
 699 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
 700 tickString (UnfoldingDone _)            = "UnfoldingDone"
 701 tickString (RuleFired _)                = "RuleFired"
 702 tickString LetFloatFromLet              = "LetFloatFromLet"
 703 tickString (EtaExpansion _)             = "EtaExpansion"
 704 tickString (EtaReduction _)             = "EtaReduction"
 705 tickString (BetaReduction _)            = "BetaReduction"
 706 tickString (CaseOfCase _)               = "CaseOfCase"
 707 tickString (KnownBranch _)              = "KnownBranch"
 708 tickString (CaseMerge _)                = "CaseMerge"
 709 tickString (AltMerge _)                 = "AltMerge"
 710 tickString (CaseElim _)                 = "CaseElim"
 711 tickString (CaseIdentity _)             = "CaseIdentity"
 712 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
 713 tickString BottomFound                  = "BottomFound"
 714 tickString SimplifierDone               = "SimplifierDone"
 715
 716 pprTickCts :: Tick -> SDoc
 717 pprTickCts (PreInlineUnconditionally v) = ppr v
 718 pprTickCts (PostInlineUnconditionally v)= ppr v
 719 pprTickCts (UnfoldingDone v)            = ppr v
 720 pprTickCts (RuleFired v)                = ppr v
 721 pprTickCts LetFloatFromLet              = empty
 722 pprTickCts (EtaExpansion v)             = ppr v
 723 pprTickCts (EtaReduction v)             = ppr v
 724 pprTickCts (BetaReduction v)            = ppr v
 725 pprTickCts (CaseOfCase v)               = ppr v
 726 pprTickCts (KnownBranch v)              = ppr v
 727 pprTickCts (CaseMerge v)                = ppr v
 728 pprTickCts (AltMerge v)                 = ppr v
 729 pprTickCts (CaseElim v)                 = ppr v
 730 pprTickCts (CaseIdentity v)             = ppr v
 731 pprTickCts (FillInCaseDefault v)        = ppr v
 732 pprTickCts _                            = empty
 733
 734 cmpTick :: Tick -> Tick -> Ordering
 735 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 736                 GT -> GT
 737                 EQ -> cmpEqTick a b
 738                 LT -> LT
 739
 740 cmpEqTick :: Tick -> Tick -> Ordering
 741 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
 742 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
 743 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
 744 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
 745 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
 746 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
 747 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
 748 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
 749 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
 750 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
 751 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
 752 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
 753 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
 754 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
 755 cmpEqTick _                             _                               = EQ
 756 \end{code}
 757
 758
 759 %************************************************************************
 760 %*                                                                      *
 761              Monad and carried data structure definitions
 762 %*                                                                      *
 763 %************************************************************************
 764
 765 \begin{code}
 766 newtype CoreState = CoreState {
 767         cs_uniq_supply :: UniqSupply
 768 }
 769
 770 data CoreReader = CoreReader {
 771         cr_hsc_env :: HscEnv,
 772         cr_rule_base :: RuleBase,
 773         cr_module :: Module
 774 }
 775
 776 data CoreWriter = CoreWriter {
 777         cw_simpl_count :: SimplCount
 778 }
 779
 780 emptyWriter :: DynFlags -> CoreWriter
 781 emptyWriter dflags = CoreWriter {
 782         cw_simpl_count = zeroSimplCount dflags
 783     }
 784
 785 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
 786 plusWriter w1 w2 = CoreWriter {
 787         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
 788     }
 789
 790 type CoreIOEnv = IOEnv CoreReader
 791
 792 -- | The monad used by Core-to-Core passes to access common state, register simplification
 793 -- statistics and so on
 794 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
 795
 796 instance Functor CoreM where
 797     fmap f ma = do
 798         a <- ma
 799         return (f a)
 800
 801 instance Monad CoreM where
 802     return x = CoreM (\s -> nop s x)
 803     mx >>= f = CoreM $ \s -> do
 804             (x, s', w1) <- unCoreM mx s
 805             (y, s'', w2) <- unCoreM (f x) s'
 806             return (y, s'', w1 `plusWriter` w2)
 807
 808 instance Applicative CoreM where
 809     pure = return
 810     (<*>) = ap
 811
 812 -- For use if the user has imported Control.Monad.Error from MTL
 813 -- Requires UndecidableInstances
 814 instance MonadPlus IO => MonadPlus CoreM where
 815     mzero = CoreM (const mzero)
 816     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
 817
 818 instance MonadUnique CoreM where
 819     getUniqueSupplyM = do
 820         us <- getS cs_uniq_supply
 821         let (us1, us2) = splitUniqSupply us
 822         modifyS (\s -> s { cs_uniq_supply = us2 })
 823         return us1
 824
 825 runCoreM :: HscEnv
 826          -> RuleBase
 827          -> UniqSupply
 828          -> Module
 829          -> CoreM a
 830          -> IO (a, SimplCount)
 831 runCoreM hsc_env rule_base us mod m =
 832         liftM extract $ runIOEnv reader $ unCoreM m state
 833   where
 834     reader = CoreReader {
 835             cr_hsc_env = hsc_env,
 836             cr_rule_base = rule_base,
 837             cr_module = mod
 838         }
 839     state = CoreState {
 840             cs_uniq_supply = us
 841         }
 842
 843     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
 844     extract (value, _, writer) = (value, cw_simpl_count writer)
 845
 846 \end{code}
 847
 848
 849 %************************************************************************
 850 %*                                                                      *
 851              Core combinators, not exported
 852 %*                                                                      *
 853 %************************************************************************
 854
 855 \begin{code}
 856
 857 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
 858 nop s x = do
 859     r <- getEnv
 860     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
 861
 862 read :: (CoreReader -> a) -> CoreM a
 863 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
 864
 865 getS :: (CoreState -> a) -> CoreM a
 866 getS f = CoreM (\s -> nop s (f s))
 867
 868 modifyS :: (CoreState -> CoreState) -> CoreM ()
 869 modifyS f = CoreM (\s -> nop (f s) ())
 870
 871 write :: CoreWriter -> CoreM ()
 872 write w = CoreM (\s -> return ((), s, w))
 873
 874 \end{code}
 875
 876 \subsection{Lifting IO into the monad}
 877
 878 \begin{code}
 879
 880 -- | Lift an 'IOEnv' operation into 'CoreM'
 881 liftIOEnv :: CoreIOEnv a -> CoreM a
 882 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
 883
 884 instance MonadIO CoreM where
 885     liftIO = liftIOEnv . IOEnv.liftIO
 886
 887 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
 888 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
 889 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
 890
 891 \end{code}
 892
 893
 894 %************************************************************************
 895 %*                                                                      *
 896              Reader, writer and state accessors
 897 %*                                                                      *
 898 %************************************************************************
 899
 900 \begin{code}
 901
 902 getHscEnv :: CoreM HscEnv
 903 getHscEnv = read cr_hsc_env
 904
 905 getRuleBase :: CoreM RuleBase
 906 getRuleBase = read cr_rule_base
 907
 908 getModule :: CoreM Module
 909 getModule = read cr_module
 910
 911 addSimplCount :: SimplCount -> CoreM ()
 912 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 913
 914 -- Convenience accessors for useful fields of HscEnv
 915
 916 getDynFlags :: CoreM DynFlags
 917 getDynFlags = fmap hsc_dflags getHscEnv
 918
 919 -- | The original name cache is the current mapping from 'Module' and
 920 -- 'OccName' to a compiler-wide unique 'Name'
 921 getOrigNameCache :: CoreM OrigNameCache
 922 getOrigNameCache = do
 923     nameCacheRef <- fmap hsc_NC getHscEnv
 924     liftIO $ fmap nsNames $ readIORef nameCacheRef
 925
 926 \end{code}
 927
 928
 929 %************************************************************************
 930 %*                                                                      *
 931              Dealing with annotations
 932 %*                                                                      *
 933 %************************************************************************
 934
 935 \begin{code}
 936 -- | Get all annotations of a given type. This happens lazily, that is
 937 -- no deserialization will take place until the [a] is actually demanded and
 938 -- the [a] can also be empty (the UniqFM is not filtered).
 939 --
 940 -- This should be done once at the start of a Core-to-Core pass that uses
 941 -- annotations.
 942 --
 943 -- See Note [Annotations]
 944 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
 945 getAnnotations deserialize guts = do
 946      hsc_env <- getHscEnv
 947      ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
 948      return (deserializeAnns deserialize ann_env)
 949
 950 -- | Get at most one annotation of a given type per Unique.
 951 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
 952 getFirstAnnotations deserialize guts
 953   = liftM (mapUFM head . filterUFM (not . null))
 954   $ getAnnotations deserialize guts
 955
 956 \end{code}
 957
 958 Note [Annotations]
 959 ~~~~~~~~~~~~~~~~~~
 960 A Core-to-Core pass that wants to make use of annotations calls
 961 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
 962 annotations of a specific type. This produces all annotations from interface
 963 files read so far. However, annotations from interface files read during the
 964 pass will not be visible until getAnnotations is called again. This is similar
 965 to how rules work and probably isn't too bad.
 966
 967 The current implementation could be optimised a bit: when looking up
 968 annotations for a thing from the HomePackageTable, we could search directly in
 969 the module where the thing is defined rather than building one UniqFM which
 970 contains all annotations we know of. This would work because annotations can
 971 only be given to things defined in the same module. However, since we would
 972 only want to deserialise every annotation once, we would have to build a cache
 973 for every module in the HTP. In the end, it's probably not worth it as long as
 974 we aren't using annotations heavily.
 975
 976 %************************************************************************
 977 %*                                                                      *
 978                 Direct screen output
 979 %*                                                                      *
 980 %************************************************************************
 981
 982 \begin{code}
 983
 984 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
 985 msg how doc = do
 986         dflags <- getDynFlags
 987         liftIO $ how dflags doc
 988
 989 -- | Output a String message to the screen
 990 putMsgS :: String -> CoreM ()
 991 putMsgS = putMsg . text
 992
 993 -- | Output a message to the screen
 994 putMsg :: SDoc -> CoreM ()
 995 putMsg = msg Err.putMsg
 996
 997 -- | Output a string error to the screen
 998 errorMsgS :: String -> CoreM ()
 999 errorMsgS = errorMsg . text
1000
1001 -- | Output an error to the screen
1002 errorMsg :: SDoc -> CoreM ()
1003 errorMsg = msg Err.errorMsg
1004
1005 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
1006 fatalErrorMsgS :: String -> CoreM ()
1007 fatalErrorMsgS = fatalErrorMsg . text
1008
1009 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
1010 fatalErrorMsg :: SDoc -> CoreM ()
1011 fatalErrorMsg = msg Err.fatalErrorMsg
1012
1013 -- | Output a string debugging message at verbosity level of @-v@ or higher
1014 debugTraceMsgS :: String -> CoreM ()
1015 debugTraceMsgS = debugTraceMsg . text
1016
1017 -- | Outputs a debugging message at verbosity level of @-v@ or higher
1018 debugTraceMsg :: SDoc -> CoreM ()
1019 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
1020
1021 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
1022 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
1023 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
1024 \end{code}
1025
1026 \begin{code}
1027
1028 initTcForLookup :: HscEnv -> TcM a -> IO a
1029 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
1030
1031 \end{code}
1032
1033
1034 %************************************************************************
1035 %*                                                                      *
1036                Finding TyThings
1037 %*                                                                      *
1038 %************************************************************************
1039
1040 \begin{code}
1041 instance MonadThings CoreM where
1042     lookupThing name = do
1043         hsc_env <- getHscEnv
1044         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
1045 \end{code}
1046
1047 %************************************************************************
1048 %*                                                                      *
1049                Template Haskell interoperability
1050 %*                                                                      *
1051 %************************************************************************
1052
1053 \begin{code}
1054 #ifdef GHCI
1055 -- | Attempt to convert a Template Haskell name to one that GHC can
1056 -- understand. Original TH names such as those you get when you use
1057 -- the @'foo@ syntax will be translated to their equivalent GHC name
1058 -- exactly. Qualified or unqualifed TH names will be dynamically bound
1059 -- to names in the module being compiled, if possible. Exact TH names
1060 -- will be bound to the name they represent, exactly.
1061 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
1062 thNameToGhcName th_name = do
1063     hsc_env <- getHscEnv
1064     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
1065 #endif
1066 \end{code}