never executed always true always false
    1 {-# LANGUAGE DeriveFunctor #-}
    2 {-# LANGUAGE FlexibleContexts #-}
    3 {-# LANGUAGE FlexibleInstances #-}
    4 {-# LANGUAGE LambdaCase #-}
    5 
    6 {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
    7 
    8 {-
    9 (c) The University of Glasgow 2006
   10 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   11 
   12 
   13 Monadery used in desugaring
   14 -}
   15 
   16 module GHC.HsToCore.Monad (
   17         DsM, mapM, mapAndUnzipM,
   18         initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
   19         foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
   20         Applicative(..),(<$>),
   21 
   22         duplicateLocalDs, newSysLocalDs,
   23         newSysLocalsDs, newUniqueId,
   24         newFailLocalDs, newPredVarDs,
   25         getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
   26         mkPrintUnqualifiedDs,
   27         newUnique,
   28         UniqSupply, newUniqueSupply,
   29         getGhcModeDs, dsGetFamInstEnvs,
   30         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
   31         dsLookupDataCon, dsLookupConLike,
   32         getCCIndexDsM,
   33 
   34         DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
   35 
   36         -- Getting and setting pattern match oracle states
   37         getPmNablas, updPmNablas,
   38 
   39         -- Get COMPLETE sets of a TyCon
   40         dsGetCompleteMatches,
   41 
   42         -- Warnings and errors
   43         DsWarning, diagnosticDs, errDsCoreExpr,
   44         failWithDs, failDs, discardWarningsDs,
   45 
   46         -- Data types
   47         DsMatchContext(..),
   48         EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
   49 
   50         -- Trace injection
   51         pprRuntimeTrace
   52     ) where
   53 
   54 import GHC.Prelude
   55 
   56 import GHC.Driver.Env
   57 import GHC.Driver.Session
   58 import GHC.Driver.Ppr
   59 import GHC.Driver.Config.Diagnostic
   60 
   61 import GHC.Hs
   62 
   63 import GHC.HsToCore.Types
   64 import GHC.HsToCore.Errors.Types
   65 import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)
   66 
   67 import GHC.Core.FamInstEnv
   68 import GHC.Core
   69 import GHC.Core.Make  ( unitExpr )
   70 import GHC.Core.Utils ( exprType )
   71 import GHC.Core.DataCon
   72 import GHC.Core.ConLike
   73 import GHC.Core.TyCon
   74 import GHC.Core.Type
   75 import GHC.Core.Multiplicity
   76 
   77 import GHC.IfaceToCore
   78 
   79 import GHC.Tc.Utils.Monad
   80 
   81 import GHC.Builtin.Names
   82 
   83 import GHC.Data.FastString
   84 
   85 import GHC.Unit.Env
   86 import GHC.Unit.External
   87 import GHC.Unit.Module
   88 import GHC.Unit.Module.ModGuts
   89 
   90 import GHC.Types.Name.Reader
   91 import GHC.Types.Basic ( Origin )
   92 import GHC.Types.SourceFile
   93 import GHC.Types.Id
   94 import GHC.Types.SrcLoc
   95 import GHC.Types.TypeEnv
   96 import GHC.Types.Unique.Supply
   97 import GHC.Types.Name
   98 import GHC.Types.Name.Env
   99 import GHC.Types.Name.Ppr
  100 import GHC.Types.Literal ( mkLitString )
  101 import GHC.Types.CostCentre.State
  102 import GHC.Types.TyThing
  103 import GHC.Types.Error
  104 
  105 import GHC.Utils.Error
  106 import GHC.Utils.Outputable
  107 import GHC.Utils.Panic
  108 import qualified GHC.Data.Strict as Strict
  109 
  110 import Data.IORef
  111 import GHC.Driver.Env.KnotVars
  112 
  113 {-
  114 ************************************************************************
  115 *                                                                      *
  116                 Data types for the desugarer
  117 *                                                                      *
  118 ************************************************************************
  119 -}
  120 
  121 data DsMatchContext
  122   = DsMatchContext (HsMatchContext GhcRn) SrcSpan
  123   deriving ()
  124 
  125 instance Outputable DsMatchContext where
  126   ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
  127 
  128 data EquationInfo
  129   = EqnInfo { eqn_pats :: [Pat GhcTc]
  130               -- ^ The patterns for an equation
  131               --
  132               -- NB: We have /already/ applied 'decideBangHood' to
  133               -- these patterns.  See Note [decideBangHood] in "GHC.HsToCore.Utils"
  134 
  135             , eqn_orig :: Origin
  136               -- ^ Was this equation present in the user source?
  137               --
  138               -- This helps us avoid warnings on patterns that GHC elaborated.
  139               --
  140               -- For instance, the pattern @-1 :: Word@ gets desugared into
  141               -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
  142               -- literal for /both/ of these cases.
  143 
  144             , eqn_rhs  :: MatchResult CoreExpr
  145               -- ^ What to do after match
  146             }
  147 
  148 instance Outputable EquationInfo where
  149     ppr (EqnInfo pats _ _) = ppr pats
  150 
  151 type DsWrapper = CoreExpr -> CoreExpr
  152 idDsWrapper :: DsWrapper
  153 idDsWrapper e = e
  154 
  155 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr
  156 --      \fail. wrap (case vs of { pats -> rhs fail })
  157 -- where vs are not bound by wrap
  158 
  159 -- | This is a value of type a with potentially a CoreExpr-shaped hole in it.
  160 -- This is used to deal with cases where we are potentially handling pattern
  161 -- match failure, and want to later specify how failure is handled.
  162 data MatchResult a
  163   -- | We represent the case where there is no hole without a function from
  164   -- 'CoreExpr', like this, because sometimes we have nothing to put in the
  165   -- hole and so want to be sure there is in fact no hole.
  166   = MR_Infallible (DsM a)
  167   | MR_Fallible (CoreExpr -> DsM a)
  168   deriving (Functor)
  169 
  170 -- | Product is an "or" on falliblity---the combined match result is infallible
  171 -- only if the left and right argument match results both were.
  172 --
  173 -- This is useful for combining a bunch of alternatives together and then
  174 -- getting the overall falliblity of the entire group. See 'mkDataConCase' for
  175 -- an example.
  176 instance Applicative MatchResult where
  177   pure v = MR_Infallible (pure v)
  178   MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x)
  179   f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x
  180 
  181 -- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether
  182 -- the MatchResult CoreExpr was failable or not.
  183 runMatchResult :: CoreExpr -> MatchResult a -> DsM a
  184 runMatchResult fail = \case
  185   MR_Infallible body -> body
  186   MR_Fallible body_fn -> body_fn fail
  187 
  188 {-
  189 ************************************************************************
  190 *                                                                      *
  191                 Monad functions
  192 *                                                                      *
  193 ************************************************************************
  194 -}
  195 
  196 -- Compatibility functions
  197 fixDs :: (a -> DsM a) -> DsM a
  198 fixDs    = fixM
  199 
  200 type DsWarning = (SrcSpan, SDoc)
  201         -- Not quite the same as a WarnMsg, we have an SDoc here
  202         -- and we'll do the print_unqual stuff later on to turn it
  203         -- into a Doc.
  204 
  205 -- | Run a 'DsM' action inside the 'TcM' monad.
  206 initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a)
  207 initDsTc thing_inside
  208   = do { tcg_env  <- getGblEnv
  209        ; msg_var  <- liftIO $ newIORef emptyMessages
  210        ; hsc_env  <- getTopEnv
  211        ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
  212        ; e_result <- tryM $  -- need to tryM so that we don't discard
  213                              -- DsMessages
  214                      setEnvs envs thing_inside
  215        ; msgs     <- liftIO $ readIORef msg_var
  216        ; return (msgs, case e_result of Left _  -> Nothing
  217                                         Right x -> Just x)
  218        }
  219 
  220 -- | Run a 'DsM' action inside the 'IO' monad.
  221 initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
  222 initDs hsc_env tcg_env thing_inside
  223   = do { msg_var <- newIORef emptyMessages
  224        ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
  225        ; runDs hsc_env envs thing_inside
  226        }
  227 
  228 -- | Build a set of desugarer environments derived from a 'TcGblEnv'.
  229 mkDsEnvsFromTcGbl :: MonadIO m
  230                   => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv
  231                   -> m (DsGblEnv, DsLclEnv)
  232 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
  233   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState
  234        ; eps <- liftIO $ hscEPS hsc_env
  235        ; let unit_env = hsc_unit_env hsc_env
  236              this_mod = tcg_mod tcg_env
  237              type_env = tcg_type_env tcg_env
  238              rdr_env  = tcg_rdr_env tcg_env
  239              fam_inst_env = tcg_fam_inst_env tcg_env
  240              complete_matches = hptCompleteSigs hsc_env         -- from the home package
  241                                 ++ tcg_complete_matches tcg_env -- from the current module
  242                                 ++ eps_complete_matches eps     -- from imports
  243              -- re-use existing next_wrapper_num to ensure uniqueness
  244              next_wrapper_num_var = tcg_next_wrapper_num tcg_env
  245        ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env
  246                            msg_var cc_st_var next_wrapper_num_var complete_matches
  247        }
  248 
  249 runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a)
  250 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
  251   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
  252                               (tryM thing_inside)
  253        ; msgs   <- readIORef (ds_msgs ds_gbl)
  254        ; let final_res
  255                | errorsFound msgs = Nothing
  256                | Right r <- res   = Just r
  257                | otherwise        = panic "initDs"
  258        ; return (msgs, final_res)
  259        }
  260 
  261 -- | Run a 'DsM' action in the context of an existing 'ModGuts'
  262 initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a)
  263 initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
  264                                    , mg_tcs = tycons, mg_fam_insts = fam_insts
  265                                    , mg_patsyns = patsyns, mg_rdr_env = rdr_env
  266                                    , mg_fam_inst_env = fam_inst_env
  267                                    , mg_complete_matches = local_complete_matches
  268                           }) thing_inside
  269   = do { cc_st_var   <- newIORef newCostCentreState
  270        ; next_wrapper_num <- newIORef emptyModuleEnv
  271        ; msg_var <- newIORef emptyMessages
  272        ; eps <- liftIO $ hscEPS hsc_env
  273        ; let unit_env = hsc_unit_env hsc_env
  274              type_env = typeEnvFromEntities ids tycons patsyns fam_insts
  275              complete_matches = hptCompleteSigs hsc_env     -- from the home package
  276                                 ++ local_complete_matches  -- from the current module
  277                                 ++ eps_complete_matches eps -- from imports
  278 
  279              bindsToIds (NonRec v _)   = [v]
  280              bindsToIds (Rec    binds) = map fst binds
  281              ids = concatMap bindsToIds binds
  282 
  283              envs  = mkDsEnvs unit_env this_mod rdr_env type_env
  284                               fam_inst_env msg_var cc_st_var
  285                               next_wrapper_num complete_matches
  286        ; runDs hsc_env envs thing_inside
  287        }
  288 
  289 initTcDsForSolver :: TcM a -> DsM a
  290 -- Spin up a TcM context so that we can run the constraint solver
  291 -- Returns any error messages generated by the constraint solver
  292 -- and (Just res) if no error happened; Nothing if an error happened
  293 --
  294 -- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
  295 --             only to immediately refine it to a TcS monad.
  296 -- Better perhaps to make TcS into its own monad, rather than building on TcS
  297 -- But that may in turn interact with plugins
  298 
  299 initTcDsForSolver thing_inside
  300   = do { (gbl, lcl) <- getEnvs
  301        ; hsc_env    <- getTopEnv
  302 
  303        ; let DsGblEnv { ds_mod = mod
  304                       , ds_fam_inst_env = fam_inst_env
  305                       , ds_gbl_rdr_env  = rdr_env }      = gbl
  306        -- This is *the* use of ds_gbl_rdr_env:
  307        -- Make sure the solver (used by the pattern-match overlap checker) has
  308        -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
  309        -- knows how to reduce type families, and which newtypes it can unwrap.
  310 
  311 
  312              DsLclEnv { dsl_loc = loc }                  = lcl
  313 
  314        ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
  315          updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env
  316                                       , tcg_rdr_env      = rdr_env }) $
  317          thing_inside
  318        ; case mb_ret of
  319            Just ret -> pure ret
  320            Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }
  321 
  322 mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
  323          -> IORef (Messages DsMessage) -> IORef CostCentreState
  324          -> IORef (ModuleEnv Int) -> CompleteMatches
  325          -> (DsGblEnv, DsLclEnv)
  326 mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
  327          next_wrapper_num complete_matches
  328   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs"
  329   -- Failing tests here are `ghci` and `T11985` if you get this wrong.
  330   -- this is very very "at a distance" because the reason for this check is that the type_env in interactive
  331   -- mode is the smushed together of all the interactive modules.
  332   -- See Note [Why is KnotVars not a ModuleEnv]
  333                              , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod
  334                                                           then Just (return type_env)
  335                                                           else Nothing) }
  336         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
  337                              NotBoot
  338         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
  339         gbl_env = DsGblEnv { ds_mod     = mod
  340                            , ds_fam_inst_env = fam_inst_env
  341                            , ds_gbl_rdr_env  = rdr_env
  342                            , ds_if_env  = (if_genv, if_lenv)
  343                            , ds_unqual  = mkPrintUnqualified unit_env rdr_env
  344                            , ds_msgs    = msg_var
  345                            , ds_complete_matches = complete_matches
  346                            , ds_cc_st   = cc_st_var
  347                            , ds_next_wrapper_num = next_wrapper_num
  348                            }
  349         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
  350                            , dsl_loc     = real_span
  351                            , dsl_nablas  = initNablas
  352                            }
  353     in (gbl_env, lcl_env)
  354 
  355 
  356 {-
  357 ************************************************************************
  358 *                                                                      *
  359                 Operations in the monad
  360 *                                                                      *
  361 ************************************************************************
  362 
  363 And all this mysterious stuff is so we can occasionally reach out and
  364 grab one or more names.  @newLocalDs@ isn't exported---exported
  365 functions are defined with it.  The difference in name-strings makes
  366 it easier to read debugging output.
  367 
  368 -}
  369 
  370 -- Make a new Id with the same print name, but different type, and new unique
  371 newUniqueId :: Id -> Mult -> Type -> DsM Id
  372 newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))
  373 
  374 duplicateLocalDs :: Id -> DsM Id
  375 duplicateLocalDs old_local
  376   = do  { uniq <- newUnique
  377         ; return (setIdUnique old_local uniq) }
  378 
  379 newPredVarDs :: PredType -> DsM Var
  380 newPredVarDs
  381  = mkSysLocalOrCoVarM (fsLit "ds") Many  -- like newSysLocalDs, but we allow covars
  382 
  383 newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
  384 newSysLocalDs = mkSysLocalM (fsLit "ds")
  385 newFailLocalDs = mkSysLocalM (fsLit "fail")
  386 
  387 newSysLocalsDs :: [Scaled Type] -> DsM [Id]
  388 newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t)
  389 
  390 {-
  391 We can also reach out and either set/grab location information from
  392 the @SrcSpan@ being carried around.
  393 -}
  394 
  395 getGhcModeDs :: DsM GhcMode
  396 getGhcModeDs =  getDynFlags >>= return . ghcMode
  397 
  398 -- | Get the current pattern match oracle state. See 'dsl_nablas'.
  399 getPmNablas :: DsM Nablas
  400 getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }
  401 
  402 -- | Set the pattern match oracle state within the scope of the given action.
  403 -- See 'dsl_nablas'.
  404 updPmNablas :: Nablas -> DsM a -> DsM a
  405 updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
  406 
  407 getSrcSpanDs :: DsM SrcSpan
  408 getSrcSpanDs = do { env <- getLclEnv
  409                   ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
  410 
  411 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
  412 putSrcSpanDs (UnhelpfulSpan {}) thing_inside
  413   = thing_inside
  414 putSrcSpanDs (RealSrcSpan real_span _) thing_inside
  415   = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
  416 
  417 putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a
  418 putSrcSpanDsA loc = putSrcSpanDs (locA loc)
  419 
  420 -- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,
  421 -- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.
  422 -- See Note [Discarding Messages] in 'GHC.Types.Error'.
  423 diagnosticDs :: DsMessage -> DsM ()
  424 diagnosticDs dsMessage
  425   = do { env <- getGblEnv
  426        ; loc <- getSrcSpanDs
  427        ; !diag_opts <- initDiagOpts <$> getDynFlags
  428        ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage
  429        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
  430 
  431 -- | Issue an error, but return the expression for (), so that we can continue
  432 -- reporting errors.
  433 errDsCoreExpr :: DsMessage -> DsM CoreExpr
  434 errDsCoreExpr msg
  435   = do { diagnosticDs msg
  436        ; return unitExpr }
  437 
  438 failWithDs :: DsMessage -> DsM a
  439 failWithDs msg
  440   = do  { diagnosticDs msg
  441         ; failM }
  442 
  443 failDs :: DsM a
  444 failDs = failM
  445 
  446 mkPrintUnqualifiedDs :: DsM PrintUnqualified
  447 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
  448 
  449 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
  450     lookupThing = dsLookupGlobal
  451 
  452 dsLookupGlobal :: Name -> DsM TyThing
  453 -- Very like GHC.Tc.Utils.Env.tcLookupGlobal
  454 dsLookupGlobal name
  455   = do  { env <- getGblEnv
  456         ; setEnvs (ds_if_env env)
  457                   (tcIfaceGlobal name) }
  458 
  459 dsLookupGlobalId :: Name -> DsM Id
  460 dsLookupGlobalId name
  461   = tyThingId <$> dsLookupGlobal name
  462 
  463 dsLookupTyCon :: Name -> DsM TyCon
  464 dsLookupTyCon name
  465   = tyThingTyCon <$> dsLookupGlobal name
  466 
  467 dsLookupDataCon :: Name -> DsM DataCon
  468 dsLookupDataCon name
  469   = tyThingDataCon <$> dsLookupGlobal name
  470 
  471 dsLookupConLike :: Name -> DsM ConLike
  472 dsLookupConLike name
  473   = tyThingConLike <$> dsLookupGlobal name
  474 
  475 
  476 dsGetFamInstEnvs :: DsM FamInstEnvs
  477 -- Gets both the external-package inst-env
  478 -- and the home-pkg inst env (includes module being compiled)
  479 dsGetFamInstEnvs
  480   = do { eps <- getEps; env <- getGblEnv
  481        ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
  482 
  483 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
  484 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
  485 
  486 -- | The @COMPLETE@ pragmas that are in scope.
  487 dsGetCompleteMatches :: DsM CompleteMatches
  488 dsGetCompleteMatches = ds_complete_matches <$> getGblEnv
  489 
  490 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
  491 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
  492 
  493 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
  494 dsExtendMetaEnv menv thing_inside
  495   = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
  496 
  497 discardWarningsDs :: DsM a -> DsM a
  498 -- Ignore warnings inside the thing inside;
  499 -- used to ignore inaccessible cases etc. inside generated code
  500 discardWarningsDs thing_inside
  501   = do  { env <- getGblEnv
  502         ; old_msgs <- readTcRef (ds_msgs env)
  503 
  504         ; result <- thing_inside
  505 
  506         -- Revert messages to old_msgs
  507         ; writeTcRef (ds_msgs env) old_msgs
  508 
  509         ; return result }
  510 
  511 -- | Inject a trace message into the compiled program. Whereas
  512 -- pprTrace prints out information *while compiling*, pprRuntimeTrace
  513 -- captures that information and causes it to be printed *at runtime*
  514 -- using Debug.Trace.trace.
  515 --
  516 --   pprRuntimeTrace hdr doc expr
  517 --
  518 -- will produce an expression that looks like
  519 --
  520 --   trace (hdr + doc) expr
  521 --
  522 -- When using this to debug a module that Debug.Trace depends on,
  523 -- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
  524 -- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
  525 -- but that doesn't seem worth the effort and maintenance cost.
  526 pprRuntimeTrace :: String   -- ^ header
  527                 -> SDoc     -- ^ information to output
  528                 -> CoreExpr -- ^ expression
  529                 -> DsM CoreExpr
  530 pprRuntimeTrace str doc expr = do
  531   traceId <- dsLookupGlobalId traceName
  532   unpackCStringId <- dsLookupGlobalId unpackCStringName
  533   dflags <- getDynFlags
  534   let message :: CoreExpr
  535       message = App (Var unpackCStringId) $
  536                 Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
  537   return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
  538 
  539 -- | See 'getCCIndexM'.
  540 getCCIndexDsM :: FastString -> DsM CostCentreIndex
  541 getCCIndexDsM = getCCIndexM ds_cc_st