Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/baa57678a7c034ff7d03339ba2e2693c105806e2 >--------------------------------------------------------------- commit baa57678a7c034ff7d03339ba2e2693c105806e2 Author: Simon Marlow <[email protected]> Date: Wed Nov 2 08:39:13 2011 +0000 Improve pretty-printing of BCOs (-ddump-bcos) >--------------------------------------------------------------- compiler/ghci/ByteCodeInstr.lhs | 45 +++++++++++++++++++++++++++++++------- 1 files changed, 36 insertions(+), 9 deletions(-) diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index c7ff1a4..84a9af2 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -15,12 +15,13 @@ module ByteCodeInstr ( import ByteCodeItbls ( ItblPtr ) +import PprCore import Type import Outputable +import FastString import Name import Id import CoreSyn -import PprCore import Literal import DataCon import VarSet @@ -166,11 +167,37 @@ instance Outputable a => Outputable (ProtoBCO a) where ppr (ProtoBCO name instrs bitmap bsize arity origin malloced) = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity <+> text (show malloced) <> colon) - $$ nest 6 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap)) - $$ nest 6 (vcat (map ppr instrs)) - $$ case origin of - Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts) - Right rhs -> pprCoreExpr (deAnnotate rhs) + $$ nest 3 (case origin of + Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) + (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' + Right rhs -> pprCoreExprShort (deAnnotate rhs)) + $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap)) + $$ nest 3 (vcat (map ppr instrs)) + +-- Print enough of the Core expression to enable the reader to find +-- the expression in the -ddump-prep output. That is, we need to +-- include at least a binder. + +pprCoreExprShort :: CoreExpr -> SDoc +pprCoreExprShort expr@(Lam _ _) + = let + (bndrs, _) = collectBinders expr + in + char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> ptext (sLit "...") + +pprCoreExprShort (Case _expr var _ty _alts) + = ptext (sLit "case of") <+> ppr var + +pprCoreExprShort (Let (NonRec x _) _) = ptext (sLit "let") <+> ppr x <+> ptext (sLit ("= ... in ...")) +pprCoreExprShort (Let (Rec bs) _) = ptext (sLit "let {") <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) + +pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e +pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> ptext (sLit "`cast` T") + +pprCoreExprShort e = pprCoreExpr e + +pprCoreAltShort :: CoreAlt -> SDoc +pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> ptext (sLit "->") <+> pprCoreExprShort expr instance Outputable BCInstr where ppr (STKCHECK n) = text "STKCHECK" <+> ppr n @@ -180,9 +207,9 @@ instance Outputable BCInstr where ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." <> ppr op - ppr (PUSH_BCO bco) = text "PUSH_BCO" <+> nest 3 (ppr bco) - ppr (PUSH_ALTS bco) = text "PUSH_ALTS " <+> ppr bco - ppr (PUSH_ALTS_UNLIFTED bco pk) = text "PUSH_ALTS_UNLIFTED " <+> ppr pk <+> ppr bco + ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) + ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) + ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco) ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
