X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=dbfd20e424b678e11a5608f4e030154d23485332;hb=d502cd03812e1c6452927d40e31e81c0594e899e;hp=2755312a5a81cc0d6366ab04e4097953dd16d79a;hpb=cd11f455bb11647eaf1b533ce775111c74d569b6;p=ghc-hetmet.git diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 2755312..dbfd20e 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -1,10 +1,3 @@ -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - ---------------------------------------------------------------------------- -- -- Pretty-printing of Cmm as (a superset of) C-- @@ -44,8 +37,8 @@ module PprCmm ) where +import BlockId import Cmm -import CmmExpr import CmmUtils import MachOp import CLabel @@ -92,9 +85,15 @@ instance Outputable CmmExpr where instance Outputable CmmReg where ppr e = pprReg e +instance Outputable CmmLit where + ppr l = pprLit l + instance Outputable LocalReg where ppr e = pprLocalReg e +instance Outputable Area where + ppr e = pprArea e + instance Outputable GlobalReg where ppr e = pprGlobalReg e @@ -145,12 +144,13 @@ instance Outputable CmmSafety where -- For ideas on how to refine it, they used to be printed in the -- style of C--'s 'stackdata' declaration, just inside the proc body, -- and were labelled with the procedure name ++ "_info". -pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) = +pprInfo :: CmmInfo -> SDoc +pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) = vcat [{-ptext (sLit "gc_target: ") <> maybe (ptext (sLit "")) pprBlockId gc_target,-} ptext (sLit "update_frame: ") <> maybe (ptext (sLit "")) pprUpdateFrame update_frame] -pprInfo (CmmInfo gc_target update_frame +pprInfo (CmmInfo _gc_target update_frame (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) = vcat [{-ptext (sLit "gc_target: ") <> maybe (ptext (sLit "")) pprBlockId gc_target,-} @@ -161,12 +161,13 @@ pprInfo (CmmInfo gc_target update_frame ptext (sLit "tag: ") <> integer (toInteger tag), pprTypeInfo info] +pprTypeInfo :: ClosureTypeInfo -> SDoc pprTypeInfo (ConstrInfo layout constr descr) = vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), ptext (sLit "constructor: ") <> integer (toInteger constr), pprLit descr] -pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) = +pprTypeInfo (FunInfo layout srt fun_type arity _args slow_entry) = vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), ptext (sLit "srt: ") <> ppr srt, @@ -241,8 +242,22 @@ pprStmt stmt = case stmt of CmmNeverReturns -> ptext (sLit " never returns"), semi ] where - target (CmmLit lit) = pprLit lit - target fn' = parens (ppr fn') + ---- With the following three functions, I was going somewhere + ---- useful, but I don't remember where. Probably making + ---- emitted Cmm output look better. ---NR, 2 May 2008 + _pp_lhs | null results = empty + | otherwise = commafy (map ppr_ar results) <+> equals + -- Don't print the hints on a native C-- call + ppr_ar arg = case cconv of + CmmCallConv -> ppr (kindlessCmm arg) + _ -> doubleQuotes (ppr $ cmmKind arg) <+> + ppr (kindlessCmm arg) + _pp_conv = case cconv of + CmmCallConv -> empty + _ -> ptext (sLit "foreign") <+> doubleQuotes (ppr cconv) + + target (CmmLit lit) = pprLit lit + target fn' = parens (ppr fn') CmmCall (CmmPrim op) results args safety ret -> pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) @@ -282,7 +297,7 @@ genCondBranch expr ident = -- -- jump foo(a, b, c); -- -genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc +genJump :: CmmExpr -> [CmmKinded CmmExpr] -> SDoc genJump expr args = hcat [ ptext (sLit "jump") @@ -293,21 +308,21 @@ genJump expr args = CmmLoad (CmmReg _) _ -> pprExpr expr _ -> parens (pprExpr expr) , space - , parens ( commafy $ map pprHinted args ) + , parens ( commafy $ map pprKinded args ) , semi ] -pprHinted :: Outputable a => (CmmHinted a) -> SDoc -pprHinted (CmmHinted a NoHint) = ppr a -pprHinted (CmmHinted a PtrHint) = quotes(text "address") <+> ppr a -pprHinted (CmmHinted a SignedHint) = quotes(text "signed") <+> ppr a -pprHinted (CmmHinted a FloatHint) = quotes(text "float") <+> ppr a +pprKinded :: Outputable a => (CmmKinded a) -> SDoc +pprKinded (CmmKinded a NoHint) = ppr a +pprKinded (CmmKinded a PtrHint) = quotes(text "address") <+> ppr a +pprKinded (CmmKinded a SignedHint) = quotes(text "signed") <+> ppr a +pprKinded (CmmKinded a FloatHint) = quotes(text "float") <+> ppr a -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 -- -- return (a, b, c); -- -genReturn :: [CmmHinted CmmExpr] -> SDoc +genReturn :: [CmmKinded CmmExpr] -> SDoc genReturn args = hcat [ ptext (sLit "return") @@ -341,7 +356,7 @@ genSwitch expr maybe_ids snds a b = (snd a) == (snd b) caseify :: [(Int,Maybe BlockId)] -> SDoc - caseify ixs@((i,Nothing):_) + caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */") caseify as @@ -379,10 +394,13 @@ pprExpr e -- a default conservative behaviour. -- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op = pprExpr7 x <+> doc <+> pprExpr7 y pprExpr1 e = pprExpr7 e +infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc + infixMachOp1 (MO_Eq _) = Just (ptext (sLit "==")) infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!=")) infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<")) @@ -420,7 +438,8 @@ pprExpr9 e = CmmLit lit -> pprLit1 lit CmmLoad expr rep -> ppr rep <> brackets( ppr expr ) CmmReg reg -> ppr reg - CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) CmmMachOp mop args -> genMachOp mop args genMachOp :: MachOp -> [CmmExpr] -> SDoc @@ -479,8 +498,9 @@ pprLit lit = case lit of CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-' <> pprCLabel clbl2 <> ppr_offset i -pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit) -pprLit1 lit = pprLit lit +pprLit1 :: CmmLit -> SDoc +pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) +pprLit1 lit = pprLit lit ppr_offset :: Int -> SDoc ppr_offset i @@ -507,7 +527,7 @@ pprStatic s = case s of pprReg :: CmmReg -> SDoc pprReg r = case r of - CmmLocal local -> pprLocalReg local + CmmLocal local -> pprLocalReg local CmmGlobal global -> pprGlobalReg global -- @@ -523,6 +543,12 @@ pprLocalReg (LocalReg uniq rep follow) then empty else doubleQuotes (text "ptr") +-- Stack areas +pprArea :: Area -> SDoc +pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ] +pprArea (CallArea id n n') = + hcat [ text "callslot<", ppr id, char '+', ppr n, char '/', ppr n', text ">" ] + -- needs to be kept in syn with Cmm.hs.GlobalReg -- pprGlobalReg :: GlobalReg -> SDoc @@ -569,4 +595,4 @@ pprBlockId b = ppr $ getUnique b ----------------------------------------------------------------------------- commafy :: [SDoc] -> SDoc -commafy xs = hsep $ punctuate comma xs +commafy xs = fsep $ punctuate comma xs