diff options
Diffstat (limited to 'compiler/stgSyn/StgSyn.hs')
| -rw-r--r-- | compiler/stgSyn/StgSyn.hs | 39 |
1 files changed, 30 insertions, 9 deletions
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 15181f3e5d..eb905f7456 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -39,12 +39,15 @@ module StgSyn ( isDllConApp, stgArgType, stripStgTicksTop, + stgCaseBndrInScope, pprStgBinding, pprStgTopBindings ) where #include "HsVersions.h" +import GhcPrelude + import CoreSyn ( AltCon, Tickish ) import CostCentre ( CostCentreStack ) import Data.ByteString ( ByteString ) @@ -68,6 +71,8 @@ import RepType ( typePrimRep1 ) import Unique ( Unique ) import Util +import Data.List.NonEmpty ( NonEmpty, toList ) + {- ************************************************************************ * * @@ -151,6 +156,18 @@ stripStgTicksTop p = go [] where go ts (StgTick t e) | p t = go (t:ts) e go ts other = (reverse ts, other) +-- | Given an alt type and whether the program is unarised, return whether the +-- case binder is in scope. +-- +-- Case binders of unboxed tuple or unboxed sum type always dead after the +-- unariser has run. See Note [Post-unarisation invariants]. +stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool +stgCaseBndrInScope alt_ty unarised = + case alt_ty of + AlgAlt _ -> True + PrimAlt _ -> True + MultiValAlt _ -> not unarised + PolyAlt -> True {- ************************************************************************ @@ -219,7 +236,7 @@ finished it encodes (\x -> e) as (let f = \x -> e in f) -} | StgLam - [bndr] + (NonEmpty bndr) StgExpr -- Body of lambda {- @@ -547,6 +564,7 @@ data AltType = PolyAlt -- Polymorphic (a lifted type variable) | MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum) -- the arity could indeed be 1 for unary unboxed tuple + -- or enum-like unboxed sums | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts | PrimAlt PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts @@ -665,8 +683,8 @@ pprGenStgBinding (StgNonRec bndr rhs) 4 (ppr rhs <> semi) pprGenStgBinding (StgRec pairs) - = vcat $ ifPprDebug (text "{- StgRec (begin) -}") : - map (ppr_bind) pairs ++ [ifPprDebug (text "{- StgRec (end) -}")] + = vcat $ whenPprDebug (text "{- StgRec (begin) -}") : + map (ppr_bind) pairs ++ [whenPprDebug (text "{- StgRec (end) -}")] where ppr_bind (bndr, expr) = hang (hsep [pprBndr LetBind bndr, equals]) @@ -718,7 +736,7 @@ pprStgExpr (StgOpApp op args _) = hsep [ pprStgOp op, brackets (interppSP args)] pprStgExpr (StgLam bndrs body) - = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs) + = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs)) <+> text "->", pprStgExpr body ] where ppr_list = brackets . fsep . punctuate comma @@ -738,7 +756,7 @@ pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "), ppr cc, pp_binder_info bi, - text " [", ifPprDebug (interppSP free_vars), ptext (sLit "] \\"), + text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"), ppr upd_flag, text " [", interppSP args, char ']']) 8 (sep [hsep [ppr rhs, text "} in"]])) @@ -774,7 +792,7 @@ pprStgExpr (StgTick tickish expr) pprStgExpr (StgCase expr bndr alt_type alts) = sep [sep [text "case", nest 4 (hsep [pprStgExpr expr, - ifPprDebug (dcolon <+> ppr alt_type)]), + whenPprDebug (dcolon <+> ppr alt_type)]), text "of", pprBndr CaseBind bndr, char '{'], nest 2 (vcat (map pprStgAlt alts)), char '}'] @@ -801,9 +819,11 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) -- special case pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [])) - = hsep [ ppr cc, + = sdocWithDynFlags $ \dflags -> + hsep [ ppr cc, pp_binder_info bi, - brackets (ifPprDebug (ppr free_var)), + if not $ gopt Opt_SuppressStgFreeVars dflags + then brackets (ppr free_var) else empty, text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ] -- general case @@ -811,7 +831,8 @@ pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) = sdocWithDynFlags $ \dflags -> hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty, pp_binder_info bi, - ifPprDebug (brackets (interppSP free_vars)), + if not $ gopt Opt_SuppressStgFreeVars dflags + then brackets (interppSP free_vars) else empty, char '\\' <> ppr upd_flag, brackets (interppSP args)]) 4 (ppr body) |