+{-# 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/CodingStyle#Warnings
+-- for details
+
----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as (a superset of) C--
--
module PprCmm (
- writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
+ writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
) where
#include "HsVersions.h"
instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
ppr c = pprCmm c
-instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where
+instance (Outputable d, Outputable info, Outputable i)
+ => Outputable (GenCmmTop d info i) where
ppr t = pprTop t
-instance Outputable CmmBasicBlock where
+instance (Outputable instr) => Outputable (GenBasicBlock instr) where
ppr b = pprBBlock b
+instance Outputable BlockId where
+ ppr id = pprBlockId id
+
instance Outputable CmmStmt where
ppr s = pprStmt s
instance Outputable CmmInfo where
ppr e = pprInfo e
+
+
-----------------------------------------------------------------------------
pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
-pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
+pprTop :: (Outputable d, Outputable info, Outputable i)
+ => GenCmmTop d info i -> SDoc
+
pprTop (CmmProc info lbl params blocks )
= vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
-- section "data" { ... }
--
pprTop (CmmData section ds) =
- (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
+ (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
$$ rbrace
-
+-- --------------------------------------------------------------------------
+instance Outputable CmmSafety where
+ ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
+ ppr (CmmSafe srt) = ppr srt
-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
-- 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 CmmNonInfo = empty
-pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
- gc_target tag info) =
- vcat [ptext SLIT("type: ") <> pprLit closure_type,
+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
+ (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
+ vcat [{-ptext SLIT("gc_target: ") <>
+ maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
+ ptext SLIT("update_frame: ") <>
+ maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
+ ptext SLIT("type: ") <> pprLit closure_type,
ptext SLIT("desc: ") <> pprLit closure_desc,
- ptext SLIT("gc_target: ") <>
- maybe (ptext SLIT("<none>")) pprBlockId gc_target,
ptext SLIT("tag: ") <> integer (toInteger tag),
pprTypeInfo info]
vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
ptext SLIT("constructor: ") <> integer (toInteger constr),
- ppr descr]
+ pprLit descr]
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,
ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
- ptext SLIT("arity: ") <> integer (toInteger arity)
- --ppr args, -- TODO: needs to be printed
- --ppr slow_entry -- TODO: needs to be printed
+ ptext SLIT("arity: ") <> integer (toInteger arity),
+ --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed
+ ptext SLIT("slow: ") <> pprLit slow_entry
]
pprTypeInfo (ThunkInfo layout srt) =
vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
ptext SLIT("srt: ") <> ppr srt]
+pprTypeInfo (ThunkSelectorInfo offset srt) =
+ vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
+ ptext SLIT("srt: ") <> ppr srt]
pprTypeInfo (ContInfo stack srt) =
vcat [ptext SLIT("stack: ") <> ppr stack,
ptext SLIT("srt: ") <> ppr srt]
+pprUpdateFrame :: UpdateFrame -> SDoc
+pprUpdateFrame (UpdateFrame expr args) =
+ hcat [ ptext SLIT("jump")
+ , space
+ , if isTrivialCmmExpr expr
+ then pprExpr expr
+ else case expr of
+ CmmLoad (CmmReg _) _ -> pprExpr expr
+ _ -> parens (pprExpr expr)
+ , space
+ , parens ( commafy $ map ppr args ) ]
+
+
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
-pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
- CmmCall (CmmForeignCall fn cconv) results args srt ->
+ CmmCall (CmmCallee fn cconv) results args safety ret ->
hcat [ if null results
then empty
else parens (commafy $ map ppr results) <>
ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
- brackets (ppr srt), semi ]
+ brackets (ppr safety),
+ case ret of CmmMayReturn -> empty
+ CmmNeverReturns -> ptext SLIT(" never returns"),
+ semi ]
where
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
- CmmCall (CmmPrim op) results args srt ->
- pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
- results args srt)
+ CmmCall (CmmPrim op) results args safety ret ->
+ pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
+ results args safety ret)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
projects / ghc-hetmet.git / blobdiff