-{-# 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--
)
where
+import BlockId
import Cmm
-import CmmExpr
import CmmUtils
import MachOp
import CLabel
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
-- 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 "<none>")) pprBlockId gc_target,-}
ptext (sLit "update_frame: ") <>
maybe (ptext (sLit "<none>")) 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 "<none>")) pprBlockId gc_target,-}
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,
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)
--
-- jump foo(a, b, c);
--
-genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
+genJump :: CmmExpr -> [CmmKinded CmmExpr] -> SDoc
genJump expr args =
hcat [ ptext (sLit "jump")
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")
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
-- 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 "<<"))
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
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
pprReg :: CmmReg -> SDoc
pprReg r
= case r of
- CmmLocal local -> pprLocalReg local
+ CmmLocal local -> pprLocalReg local
CmmGlobal global -> pprGlobalReg global
--
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
-----------------------------------------------------------------------------
commafy :: [SDoc] -> SDoc
-commafy xs = hsep $ punctuate comma xs
+commafy xs = fsep $ punctuate comma xs
projects / ghc-hetmet.git / blobdiff