projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Small rearrangements
[ghc-hetmet.git]
/
compiler
/
cmm
/
PprCmm.hs
diff --git
a/compiler/cmm/PprCmm.hs
b/compiler/cmm/PprCmm.hs
index
5ce008d
..
1f5be5c
100644
(file)
--- a/
compiler/cmm/PprCmm.hs
+++ b/
compiler/cmm/PprCmm.hs
@@
-33,7
+33,7
@@
--
module PprCmm (
--
module PprCmm (
- writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
+ writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
@@
-65,12
+65,16
@@
writeCmms handle cmms = printForC handle (pprCmms cmms)
instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
ppr c = pprCmm c
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
ppr t = pprTop t
-instance Outputable CmmBasicBlock where
+instance (Outputable instr) => Outputable (GenBasicBlock instr) where
ppr b = pprBBlock b
ppr b = pprBBlock b
+instance Outputable BlockId where
+ ppr id = pprBlockId id
+
instance Outputable CmmStmt where
ppr s = pprStmt s
instance Outputable CmmStmt where
ppr s = pprStmt s
@@
-92,6
+96,8
@@
instance Outputable CmmStatic where
instance Outputable CmmInfo where
ppr e = pprInfo e
instance Outputable CmmInfo where
ppr e = pprInfo e
+
+
-----------------------------------------------------------------------------
pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
-----------------------------------------------------------------------------
pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
@@
-100,7
+106,9
@@
pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
-- --------------------------------------------------------------------------
-- 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
pprTop (CmmProc info lbl params blocks )
= vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
@@
-114,7
+122,7
@@
pprTop (CmmProc info lbl params blocks )
-- section "data" { ... }
--
pprTop (CmmData section ds) =
-- 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
-- --------------------------------------------------------------------------
$$ rbrace
-- --------------------------------------------------------------------------
@@
-130,14
+138,14
@@
instance Outputable CmmSafety where
-- 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) =
-- 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) =
- vcat [ptext SLIT("gc_target: ") <>
- maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+ 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)) =
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,
+ 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("update_frame: ") <>
maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
ptext SLIT("type: ") <> pprLit closure_type,
@@
-186,7
+194,7
@@
pprUpdateFrame (UpdateFrame expr args) =
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
-- --------------------------------------------------------------------------
-- 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))
pprBBlock (BasicBlock ident stmts) =
hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
@@
-212,7
+220,7
@@
pprStmt stmt = case stmt of
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
- CmmCall (CmmForeignCall fn cconv) results args safety ->
+ CmmCall (CmmCallee fn cconv) results args safety ret ->
hcat [ if null results
then empty
else parens (commafy $ map ppr results) <>
hcat [ if null results
then empty
else parens (commafy $ map ppr results) <>
@@
-220,14
+228,17
@@
pprStmt stmt = case stmt of
ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
- brackets (ppr safety), 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')
where
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
- CmmCall (CmmPrim op) results args safety ->
- pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
- results args safety)
+ 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)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)