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