DynFlags: remove use of sdocWithDynFlags from GHC.Stg.* (#17957)

* add StgPprOpts datatype
* remove Outputable instances for types that need `StgPprOpts` to be
  pretty-printed and explicitly call type specific ppr functions
* add default `panicStgPprOpts` for panic messages (when it's not
  convenient to thread StgPprOpts or DynFlags down to the ppr function
  call)

8 files changed, 200 insertions, 172 deletions

diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 795a3d8b08..a7456d335b 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -445,7 +445,7 @@ coreToStgExpr e0@(Case scrut bndr _ alts) = do
           _ ->
             pprPanic "coreToStgExpr" $
               text "Unexpected unsafe equality case expression:" $$ ppr e0 $$
-              text "STG:" $$ ppr stg
+              text "STG:" $$ pprStgExpr panicStgPprOpts stg
       _ -> return stg
   where
     vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 62f7467b11..a743e0f1ba 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1551,7 +1551,7 @@ doCodeGen hsc_env this_mod data_tycons
 
     let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
 
-    dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_binds_w_fvs)
+    dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)
 
     let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
         -- See Note [Forcing of stg_binds]
diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs
index d0d1b76322..2325cbab09 100644
--- a/compiler/GHC/Stg/DepAnal.hs
+++ b/compiler/GHC/Stg/DepAnal.hs
@@ -14,6 +14,7 @@ import GHC.Types.Var.Set
 import GHC.Unit.Module (Module)
 
 import Data.Graph (SCC (..))
+import Data.Bifunctor (first)
 
 --------------------------------------------------------------------------------
 -- * Dependency analysis
@@ -90,7 +91,7 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)
     expr bounds (StgOpApp _ as _) =
       args bounds as
     expr _ lam@StgLam{} =
-      pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ ppr lam)
+      pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ pprStgExpr panicStgPprOpts lam)
     expr bounds (StgCase scrut scrut_bndr _ as) =
       expr bounds scrut `unionVarSet`
         alts (extendVarSet bounds scrut_bndr) as
@@ -141,4 +142,6 @@ depSort = concatMap get_binds . depAnal defs uses
     get_binds (AcyclicSCC bind) =
       [bind]
     get_binds (CyclicSCC binds) =
-      pprPanic "depSortStgBinds" (text "Found cyclic SCC:" $$ ppr binds)
+      pprPanic "depSortStgBinds"
+               (text "Found cyclic SCC:"
+               $$ ppr (map (first (pprStgTopBinding panicStgPprOpts)) binds))
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
index 8044584321..6a75d20dd0 100644
--- a/compiler/GHC/Stg/Lift.hs
+++ b/compiler/GHC/Stg/Lift.hs
@@ -199,7 +199,7 @@ liftRhs
   -> LlStgRhs
   -> LiftM OutStgRhs
 liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)
-  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)
+  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)
     StgRhsCon ccs con <$> traverse liftArgs args
 liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do
   -- This RHS wasn't lifted.
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 34fc1a141e..206dd39187 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -70,7 +70,7 @@ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
 
 lintStgTopBindings dflags this_mod unarised whodunnit binds
   = {-# SCC "StgLint" #-}
-    case initL this_mod unarised top_level_binds (lint_binds binds) of
+    case initL this_mod unarised opts top_level_binds (lint_binds binds) of
       Nothing  ->
         return ()
       Just msg -> do
@@ -80,10 +80,11 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds
                         text whodunnit <+> text "***",
                   msg,
                   text "*** Offending Program ***",
-                  pprGenStgTopBindings binds,
+                  pprGenStgTopBindings opts binds,
                   text "*** End of Offense ***"])
         Err.ghcExit dflags 1
   where
+    opts = initStgPprOpts dflags
     -- Bring all top-level binds into scope because CoreToStg does not generate
     -- bindings in dependency order (so we may see a use before its definition).
     top_level_binds = mkVarSet (bindersOfTopBinds binds)
@@ -129,9 +130,10 @@ lint_binds_help top_lvl (binder, rhs)
   = addLoc (RhsOf binder) $ do
         when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
         lintStgRhs rhs
+        opts <- getStgPprOpts
         -- Check binder doesn't have unlifted type or it's a join point
         checkL (isJoinId binder || not (isUnliftedType (idType binder)))
-               (mkUnliftedTyMsg binder rhs)
+               (mkUnliftedTyMsg opts binder rhs)
 
 -- | Top-level bindings can't inherit the cost centre stack from their
 -- (static) allocation site.
@@ -139,14 +141,17 @@ checkNoCurrentCCS
     :: (OutputablePass a, BinderP a ~ Id)
     => GenStgRhs a
     -> LintM ()
-checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)
-  | isCurrentCCS ccs
-  = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)
-checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)
-  | isCurrentCCS ccs
-  = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)
-checkNoCurrentCCS _
-  = return ()
+checkNoCurrentCCS rhs = do
+   opts <- getStgPprOpts
+   let rhs' = pprStgRhs opts rhs
+   case rhs of
+      StgRhsClosure _ ccs _ _ _
+         | isCurrentCCS ccs
+         -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')
+      StgRhsCon ccs _ _
+         | isCurrentCCS ccs
+         -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')
+      _ -> return ()
 
 lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
 
@@ -159,9 +164,10 @@ lintStgRhs (StgRhsClosure _ _ _ binders expr)
         lintStgExpr expr
 
 lintStgRhs rhs@(StgRhsCon _ con args) = do
-    when (isUnboxedTupleCon con || isUnboxedSumCon con) $
+    when (isUnboxedTupleCon con || isUnboxedSumCon con) $ do
+      opts <- getStgPprOpts
       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
-               ppr rhs)
+               pprStgRhs opts rhs)
     mapM_ lintStgArg args
     mapM_ checkPostUnariseConArg args
 
@@ -176,17 +182,19 @@ lintStgExpr (StgApp fun args) = do
 lintStgExpr app@(StgConApp con args _arg_tys) = do
     -- unboxed sums should vanish during unarise
     lf <- getLintFlags
-    when (lf_unarised lf && isUnboxedSumCon con) $
+    when (lf_unarised lf && isUnboxedSumCon con) $ do
+      opts <- getStgPprOpts
       addErrL (text "Unboxed sum after unarise:" $$
-               ppr app)
+               pprStgExpr opts app)
     mapM_ lintStgArg args
     mapM_ checkPostUnariseConArg args
 
 lintStgExpr (StgOpApp _ args _) =
     mapM_ lintStgArg args
 
-lintStgExpr lam@(StgLam _ _) =
-    addErrL (text "Unexpected StgLam" <+> ppr lam)
+lintStgExpr lam@(StgLam _ _) = do
+    opts <- getStgPprOpts
+    addErrL (text "Unexpected StgLam" <+> pprStgExpr opts lam)
 
 lintStgExpr (StgLet _ binds body) = do
     binders <- lintStgBinds NotTopLevel binds
@@ -235,6 +243,7 @@ The Lint monad
 newtype LintM a = LintM
     { unLintM :: Module
               -> LintFlags
+              -> StgPprOpts        -- Pretty-printing options
               -> [LintLocInfo]     -- Locations
               -> IdSet             -- Local vars in scope
               -> Bag MsgDoc        -- Error messages so far
@@ -268,16 +277,16 @@ pp_binders bs
     pp_binder b
       = hsep [ppr b, dcolon, ppr (idType b)]
 
-initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
-initL this_mod unarised locals (LintM m) = do
-  let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag
+initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe MsgDoc
+initL this_mod unarised opts locals (LintM m) = do
+  let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag
   if isEmptyBag errs then
       Nothing
   else
       Just (vcat (punctuate blankLine (bagToList errs)))
 
 instance Applicative LintM where
-      pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
+      pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs)
       (<*>) = ap
       (*>)  = thenL_
 
@@ -286,14 +295,14 @@ instance Monad LintM where
     (>>)  = (*>)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \mod lf loc scope errs
-  -> case unLintM m mod lf loc scope errs of
-      (r, errs') -> unLintM (k r) mod lf loc scope errs'
+thenL m k = LintM $ \mod lf opts loc scope errs
+  -> case unLintM m mod lf opts loc scope errs of
+      (r, errs') -> unLintM (k r) mod lf opts loc scope errs'
 
 thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \mod lf loc scope errs
-  -> case unLintM m mod lf loc scope errs of
-      (_, errs') -> unLintM k mod lf loc scope errs'
+thenL_ m k = LintM $ \mod lf opts loc scope errs
+  -> case unLintM m mod lf opts loc scope errs of
+      (_, errs') -> unLintM k mod lf opts loc scope errs'
 
 checkL :: Bool -> MsgDoc -> LintM ()
 checkL True  _   = return ()
@@ -338,7 +347,7 @@ checkPostUnariseId id =
       is_sum <|> is_tuple <|> is_void
 
 addErrL :: MsgDoc -> LintM ()
-addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)
+addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc)
 
 addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
 addErr errs_so_far msg locs
@@ -349,29 +358,32 @@ addErr errs_so_far msg locs
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \mod lf loc scope errs
-   -> unLintM m mod lf (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \mod lf opts loc scope errs
+   -> unLintM m mod lf opts (extra_loc:loc) scope errs
 
 addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \mod lf loc scope errs
+addInScopeVars ids m = LintM $ \mod lf opts loc scope errs
  -> let
         new_set = mkVarSet ids
-    in unLintM m mod lf loc (scope `unionVarSet` new_set) errs
+    in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs
 
 getLintFlags :: LintM LintFlags
-getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)
+getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs)
+
+getStgPprOpts :: LintM StgPprOpts
+getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs)
 
 checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \mod _lf loc scope errs
+checkInScope id = LintM $ \mod _lf _opts loc scope errs
  -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
         ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
                                 text "is out of scope"]) loc)
     else
         ((), errs)
 
-mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
-mkUnliftedTyMsg binder rhs
+mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
+mkUnliftedTyMsg opts binder rhs
   = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
      text "has unlifted type" <+> quotes (ppr (idType binder)))
     $$
-    (text "RHS:" <+> ppr rhs)
+    (text "RHS:" <+> pprStgRhs opts rhs)
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index 8359788b92..64c7e74979 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -103,13 +103,14 @@ stg2stg dflags this_mod binds
             liftIO (stg_linter True "Unarise" binds')
             return binds'
 
+    opts = initStgPprOpts dflags
     dump_when flag header binds
-      = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings binds)
+      = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings opts binds)
 
     end_pass what binds2
       = liftIO $ do -- report verbosely, if required
           dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
-            FormatSTG (vcat (map ppr binds2))
+            FormatSTG (vcat (map (pprStgTopBinding opts) binds2))
           stg_linter False what binds2
           return binds2
 
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index ea6eef7d22..6d5baf7173 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -56,7 +56,11 @@ module GHC.Stg.Syntax (
         stgCaseBndrInScope,
         bindersOf, bindersOfTop, bindersOfTopBinds,
 
-        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
+        -- ppr
+        StgPprOpts(..), initStgPprOpts, panicStgPprOpts,
+        pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding,
+        pprGenStgTopBinding, pprStgTopBinding,
+        pprGenStgTopBindings, pprStgTopBindings
     ) where
 
 #include "HsVersions.h"
@@ -643,79 +647,73 @@ type OutputablePass pass =
   , OutputableBndr (BinderP pass)
   )
 
-pprGenStgTopBinding
-  :: OutputablePass pass => GenStgTopBinding pass -> SDoc
-pprGenStgTopBinding (StgTopStringLit bndr str)
-  = hang (hsep [pprBndr LetBind bndr, equals])
-        4 (pprHsBytes str <> semi)
-pprGenStgTopBinding (StgTopLifted bind)
-  = pprGenStgBinding bind
-
-pprGenStgBinding
-  :: OutputablePass pass => GenStgBinding pass -> SDoc
-
-pprGenStgBinding (StgNonRec bndr rhs)
-  = hang (hsep [pprBndr LetBind bndr, equals])
-        4 (ppr rhs <> semi)
-
-pprGenStgBinding (StgRec pairs)
-  = vcat [ text "Rec {"
-         , vcat (intersperse blankLine (map ppr_bind pairs))
-         , text "end Rec }" ]
-  where
-    ppr_bind (bndr, expr)
-      = hang (hsep [pprBndr LetBind bndr, equals])
-             4 (ppr expr <> semi)
+-- | STG pretty-printing options
+data StgPprOpts = StgPprOpts
+   { stgSccEnabled :: !Bool -- ^ Enable cost-centres
+   }
+
+-- | Initialize STG pretty-printing options from DynFlags
+initStgPprOpts :: DynFlags -> StgPprOpts
+initStgPprOpts dflags = StgPprOpts
+   { stgSccEnabled = sccProfilingEnabled dflags
+   }
 
-pprGenStgTopBindings
-  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc
-pprGenStgTopBindings binds
-  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
+-- | STG pretty-printing options used for panic messages
+panicStgPprOpts :: StgPprOpts
+panicStgPprOpts = StgPprOpts
+   { stgSccEnabled = True
+   }
 
-pprStgBinding :: StgBinding -> SDoc
+pprGenStgTopBinding
+  :: OutputablePass pass => StgPprOpts -> GenStgTopBinding pass -> SDoc
+pprGenStgTopBinding opts b = case b of
+   StgTopStringLit bndr str -> hang (hsep [pprBndr LetBind bndr, equals]) 4 (pprHsBytes str <> semi)
+   StgTopLifted bind        -> pprGenStgBinding opts bind
+
+pprGenStgBinding :: OutputablePass pass => StgPprOpts -> GenStgBinding pass -> SDoc
+pprGenStgBinding opts b = case b of
+   StgNonRec bndr rhs -> hang (hsep [pprBndr LetBind bndr, equals]) 4 (pprStgRhs opts rhs <> semi)
+   StgRec pairs       -> vcat [ text "Rec {"
+                              , vcat (intersperse blankLine (map ppr_bind pairs))
+                              , text "end Rec }" ]
+                         where
+                           ppr_bind (bndr, expr)
+                             = hang (hsep [pprBndr LetBind bndr, equals])
+                                    4 (pprStgRhs opts expr <> semi)
+
+pprGenStgTopBindings :: (OutputablePass pass) => StgPprOpts -> [GenStgTopBinding pass] -> SDoc
+pprGenStgTopBindings opts binds
+  = vcat $ intersperse blankLine (map (pprGenStgTopBinding opts) binds)
+
+pprStgBinding :: StgPprOpts -> StgBinding -> SDoc
 pprStgBinding = pprGenStgBinding
 
-pprStgTopBindings :: [StgTopBinding] -> SDoc
+pprStgTopBinding :: StgPprOpts -> StgTopBinding -> SDoc
+pprStgTopBinding = pprGenStgTopBinding
+
+pprStgTopBindings :: StgPprOpts -> [StgTopBinding] -> SDoc
 pprStgTopBindings = pprGenStgTopBindings
 
 instance Outputable StgArg where
-    ppr = pprStgArg
-
-instance OutputablePass pass => Outputable (GenStgTopBinding pass) where
-    ppr = pprGenStgTopBinding
-
-instance OutputablePass pass => Outputable (GenStgBinding pass) where
-    ppr = pprGenStgBinding
-
-instance OutputablePass pass => Outputable (GenStgExpr pass) where
-    ppr = pprStgExpr
-
-instance OutputablePass pass => Outputable (GenStgRhs pass) where
-    ppr rhs = pprStgRhs rhs
+  ppr = pprStgArg
 
 pprStgArg :: StgArg -> SDoc
 pprStgArg (StgVarArg var) = ppr var
 pprStgArg (StgLitArg con) = ppr con
 
-pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc
--- special case
-pprStgExpr (StgLit lit)     = ppr lit
-
--- general case
-pprStgExpr (StgApp func args)
-  = hang (ppr func) 4 (sep (map (ppr) args))
-
-pprStgExpr (StgConApp con args _)
-  = hsep [ ppr con, brackets (interppSP args) ]
-
-pprStgExpr (StgOpApp op args _)
-  = hsep [ pprStgOp op, brackets (interppSP args)]
-
-pprStgExpr (StgLam bndrs body)
-  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
-            <+> text "->",
-         pprStgExpr body ]
-  where ppr_list = brackets . fsep . punctuate comma
+pprStgExpr :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc
+pprStgExpr opts e = case e of
+                           -- special case
+   StgLit lit           -> ppr lit
+                           -- general case
+   StgApp func args     -> hang (ppr func) 4 (interppSP args)
+   StgConApp con args _ -> hsep [ ppr con, brackets (interppSP args) ]
+   StgOpApp op args _   -> hsep [ pprStgOp op, brackets (interppSP args)]
+   StgLam bndrs body    -> let ppr_list = brackets . fsep . punctuate comma
+                           in sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
+                                      <+> text "->"
+                                  , pprStgExpr opts body
+                                  ]
 
 -- special case: let v = <very specific thing>
 --               in
@@ -726,9 +724,9 @@ pprStgExpr (StgLam bndrs body)
 -- Very special!  Suspicious! (SLPJ)
 
 {-
-pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+   StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
                         expr@(StgLet _ _))
-  = ($$)
+   -> ($$)
       (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),
                           ppr cc,
                           pp_binder_info bi,
@@ -739,53 +737,60 @@ pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a
       (ppr expr)
 -}
 
--- special case: let ... in let ...
-
-pprStgExpr (StgLet ext bind expr@StgLet{})
-  = ($$)
+   -- special case: let ... in let ...
+   StgLet ext bind expr@StgLet{} -> ($$)
       (sep [hang (text "let" <+> ppr ext <+> text "{")
-                2 (hsep [pprGenStgBinding bind, text "} in"])])
-      (ppr expr)
-
--- general case
-pprStgExpr (StgLet ext bind expr)
-  = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind),
-           hang (text "} in ") 2 (ppr expr)]
-
-pprStgExpr (StgLetNoEscape ext bind expr)
-  = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{")
-                2 (pprGenStgBinding bind),
-           hang (text "} in ")
-                2 (ppr expr)]
-
-pprStgExpr (StgTick tickish expr)
-  = sdocOption sdocSuppressTicks $ \case
-      True  -> pprStgExpr expr
-      False -> sep [ ppr tickish, pprStgExpr expr ]
-
-
--- Don't indent for a single case alternative.
-pprStgExpr (StgCase expr bndr alt_type [alt])
-  = sep [sep [text "case",
-           nest 4 (hsep [pprStgExpr expr,
-             whenPprDebug (dcolon <+> ppr alt_type)]),
-           text "of", pprBndr CaseBind bndr, char '{'],
-           pprStgAlt False alt,
-           char '}']
-
-pprStgExpr (StgCase expr bndr alt_type alts)
-  = sep [sep [text "case",
-           nest 4 (hsep [pprStgExpr expr,
-             whenPprDebug (dcolon <+> ppr alt_type)]),
-           text "of", pprBndr CaseBind bndr, char '{'],
-           nest 2 (vcat (map (pprStgAlt True) alts)),
-           char '}']
-
-
-pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc
-pprStgAlt indent (con, params, expr)
-  | indent    = hang altPattern 4 (ppr expr <> semi)
-  | otherwise = sep [altPattern, ppr expr <> semi]
+                2 (hsep [pprGenStgBinding opts bind, text "} in"])])
+      (pprStgExpr opts expr)
+
+   -- general case
+   StgLet ext bind expr
+      -> sep [ hang (text "let" <+> ppr ext <+> text "{")
+                    2 (pprGenStgBinding opts bind)
+             , hang (text "} in ") 2 (pprStgExpr opts expr)
+             ]
+
+   StgLetNoEscape ext bind expr
+      -> sep [ hang (text "let-no-escape" <+> ppr ext <+> text "{")
+                    2 (pprGenStgBinding opts bind)
+             , hang (text "} in ") 2 (pprStgExpr opts expr)
+             ]
+
+   StgTick tickish expr -> sdocOption sdocSuppressTicks $ \case
+      True  -> pprStgExpr opts expr
+      False -> sep [ ppr tickish, pprStgExpr opts expr ]
+
+   -- Don't indent for a single case alternative.
+   StgCase expr bndr alt_type [alt]
+      -> sep [ sep [ text "case"
+                   , nest 4 (hsep [ pprStgExpr opts expr
+                                  , whenPprDebug (dcolon <+> ppr alt_type)
+                                  ])
+                   , text "of"
+                   , pprBndr CaseBind bndr
+                   , char '{'
+                   ]
+             , pprStgAlt opts False alt
+             , char '}'
+             ]
+
+   StgCase expr bndr alt_type alts
+      -> sep [ sep [ text "case"
+                   , nest 4 (hsep [ pprStgExpr opts expr
+                                  , whenPprDebug (dcolon <+> ppr alt_type)
+                                  ])
+                   , text "of"
+                   , pprBndr CaseBind bndr, char '{'
+                   ]
+             , nest 2 (vcat (map (pprStgAlt opts True) alts))
+             , char '}'
+             ]
+
+
+pprStgAlt :: OutputablePass pass => StgPprOpts -> Bool -> GenStgAlt pass -> SDoc
+pprStgAlt opts indent (con, params, expr)
+  | indent    = hang altPattern 4 (pprStgExpr opts expr <> semi)
+  | otherwise = sep [altPattern, pprStgExpr opts expr <> semi]
     where
       altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
 
@@ -801,15 +806,14 @@ instance Outputable AltType where
   ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc
   ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc
 
-pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc
-
-pprStgRhs (StgRhsClosure ext cc upd_flag args body)
-  = sdocWithDynFlags $ \dflags ->
-    hang (hsep [if sccProfilingEnabled dflags then ppr cc else empty,
-                ppUnlessOption sdocSuppressStgExts (ppr ext),
-                char '\\' <> ppr upd_flag, brackets (interppSP args)])
-         4 (ppr body)
-
-pprStgRhs (StgRhsCon cc con args)
-  = hcat [ ppr cc,
-           space, ppr con, text "! ", brackets (interppSP args)]
+pprStgRhs :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc
+pprStgRhs opts rhs = case rhs of
+   StgRhsClosure ext cc upd_flag args body
+      -> hang (hsep [ if stgSccEnabled opts then ppr cc else empty
+                    , ppUnlessOption sdocSuppressStgExts (ppr ext)
+                    , char '\\' <> ppr upd_flag, brackets (interppSP args)
+                    ])
+              4 (pprStgExpr opts body)
+
+   StgRhsCon cc con args
+      -> hcat [ ppr cc, space, ppr con, text "! ", brackets (sep (map pprStgArg args))]
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index 3f417ae586..cea52d6cc3 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 {-
 (c) The GRASP/AQUA Project, Glasgow University, 1992-2012
 
@@ -315,7 +317,7 @@ unariseExpr rho e@(StgApp f args)
     f' = case lookupVarEnv rho f of
            Just (UnaryVal (StgVarArg f')) -> f'
            Nothing -> f
-           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)
+           err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err)
                -- Can't happen because 'args' is non-empty, and
                -- a tuple or sum cannot be applied to anything
 
@@ -334,7 +336,7 @@ unariseExpr rho (StgOpApp op args ty)
   = return (StgOpApp op (unariseFunArgs rho args) ty)
 
 unariseExpr _ e@StgLam{}
-  = pprPanic "unariseExpr: found lambda" (ppr e)
+  = pprPanic "unariseExpr: found lambda" (pprStgExpr panicStgPprOpts e)
 
 unariseExpr rho (StgCase scrut bndr alt_ty alts)
   -- tuple/sum binders in the scrutinee can always be eliminated
@@ -412,7 +414,7 @@ elimCase rho args bndr (MultiValAlt _) alts
 
 elimCase _ args bndr alt_ty alts
   = pprPanic "elimCase - unhandled case"
-      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)
+      (ppr args <+> ppr bndr <+> ppr alt_ty $$ pprPanicAlts alts)
 
 --------------------------------------------------------------------------------
 
@@ -433,7 +435,7 @@ unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
 
 unariseAlts _ (MultiValAlt _) bndr alts
   | isUnboxedTupleBndr bndr
-  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)
+  = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts)
 
 -- In this case we don't need to scrutinize the tag bit
 unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
@@ -484,7 +486,7 @@ unariseSumAlt rho args (DataAlt sumCon, bs, e)
        return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' )
 
 unariseSumAlt _ scrt alt
-  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
+  = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt)
 
 --------------------------------------------------------------------------------
 
@@ -776,4 +778,10 @@ mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
 mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
 mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
 mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
-mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)
+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts)
+
+pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc
+pprPanicAlts alts = ppr (map pprPanicAlt alts)
+
+pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc
+pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e)