diff options
Diffstat (limited to 'compiler/stgSyn/StgSyn.lhs')
| -rw-r--r-- | compiler/stgSyn/StgSyn.lhs | 34 |
1 files changed, 19 insertions, 15 deletions
diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index d87e4559a7..cb147ca488 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -109,6 +109,8 @@ isDllConApp dflags con args = isDllName this_pkg (dataConName con) || any is_dll_arg args | otherwise = False where + -- NB: typePrimRep is legit because any free variables won't have + -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) && isDllName this_pkg (idName v) @@ -512,7 +514,7 @@ type GenStgAlt bndr occ data AltType = PolyAlt -- Polymorphic (a type variable) - | UbxTupAlt TyCon -- Unboxed tuple + | UbxTupAlt Int -- Unboxed tuple of this arity | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts \end{code} @@ -628,11 +630,11 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he likes terminators instead... Ditto for case alternatives. \begin{code} -pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) +pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgBinding bndr bdee -> SDoc pprGenStgBinding (StgNonRec bndr rhs) - = hang (hsep [ppr bndr, equals]) + = hang (hsep [pprBndr LetBind bndr, equals]) 4 ((<>) (ppr rhs) semi) pprGenStgBinding (StgRec pairs) @@ -640,7 +642,7 @@ pprGenStgBinding (StgRec pairs) map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- StgRec (end) -}"] where ppr_bind (bndr, expr) - = hang (hsep [ppr bndr, equals]) + = hang (hsep [pprBndr LetBind bndr, equals]) 4 ((<>) (ppr expr) semi) pprStgBinding :: StgBinding -> SDoc @@ -649,7 +651,7 @@ pprStgBinding bind = pprGenStgBinding bind pprStgBindings :: [StgBinding] -> SDoc pprStgBindings binds = vcat (map pprGenStgBinding binds) -pprGenStgBindingWithSRT :: (Outputable bndr, Outputable bdee, Ord bdee) +pprGenStgBindingWithSRT :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc pprGenStgBindingWithSRT (bind,srts) = vcat $ pprGenStgBinding bind : map pprSRT srts @@ -662,15 +664,15 @@ pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) instance (Outputable bdee) => Outputable (GenStgArg bdee) where ppr = pprStgArg -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgBinding bndr bdee) where ppr = pprGenStgBinding -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgExpr bndr bdee) where ppr = pprStgExpr -instance (Outputable bndr, Outputable bdee, Ord bdee) +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgRhs bndr bdee) where ppr rhs = pprStgRhs rhs @@ -678,7 +680,7 @@ pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc pprStgArg (StgVarArg var) = ppr var pprStgArg (StgLitArg con) = ppr con -pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) +pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgExpr bndr bdee -> SDoc -- special case pprStgExpr (StgLit lit) = ppr lit @@ -694,8 +696,10 @@ pprStgExpr (StgOpApp op args _) = hsep [ pprStgOp op, brackets (interppSP args)] pprStgExpr (StgLam bndrs body) - =sep [ char '\\' <+> ppr bndrs <+> ptext (sLit "->"), + = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs) + <+> ptext (sLit "->"), pprStgExpr body ] + where ppr_list = brackets . fsep . punctuate comma -- special case: let v = <very specific thing> -- in @@ -758,7 +762,7 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) = sep [sep [ptext (sLit "case"), nest 4 (hsep [pprStgExpr expr, ifPprDebug (dcolon <+> ppr alt_type)]), - ptext (sLit "of"), ppr bndr, char '{'], + ptext (sLit "of"), pprBndr CaseBind bndr, char '{'], ifPprDebug ( nest 4 ( hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), @@ -768,10 +772,10 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) nest 2 (vcat (map pprStgAlt alts)), char '}'] -pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ) +pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ) => GenStgAlt bndr occ -> SDoc pprStgAlt (con, params, _use_mask, expr) - = hang (hsep [ppr con, interppSP params, ptext (sLit "->")]) + = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), ptext (sLit "->")]) 4 (ppr expr <> semi) pprStgOp :: StgOp -> SDoc @@ -781,7 +785,7 @@ pprStgOp (StgFCallOp op _) = ppr op instance Outputable AltType where ppr PolyAlt = ptext (sLit "Polymorphic") - ppr (UbxTupAlt tc) = ptext (sLit "UbxTup") <+> ppr tc + ppr (UbxTupAlt n) = ptext (sLit "UbxTup") <+> ppr n ppr (AlgAlt tc) = ptext (sLit "Alg") <+> ppr tc ppr (PrimAlt tc) = ptext (sLit "Prim") <+> ppr tc @@ -793,7 +797,7 @@ pprStgLVs lvs else hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] -pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) +pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgRhs bndr bdee -> SDoc -- special case |