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