summaryrefslogtreecommitdiff
path: root/compiler/GHC/Stg
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Stg')
-rw-r--r--compiler/GHC/Stg/DepAnal.hs7
-rw-r--r--compiler/GHC/Stg/Lift.hs2
-rw-r--r--compiler/GHC/Stg/Lint.hs86
-rw-r--r--compiler/GHC/Stg/Pipeline.hs5
-rw-r--r--compiler/GHC/Stg/Syntax.hs248
-rw-r--r--compiler/GHC/Stg/Unarise.hs20
6 files changed, 198 insertions, 170 deletions
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)
View Lorry Controller Status