+{-# 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--
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
--
-module PprCmm (
- writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
- ) where
+module PprCmm
+ ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
+ )
+where
#include "HsVersions.h"
import Cmm
+import CmmExpr
import CmmUtils
import MachOp
import CLabel
import System.IO
import Data.Maybe
-pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc
+pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ ptext SLIT("-------------------") $$ space
-----------------------------------------------------------------------------
-instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
+instance (Outputable info, Outputable g)
+ => Outputable (GenCmm CmmStatic info g) 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 (ListGraph instr) where
+ ppr (ListGraph blocks) = vcat (map ppr blocks)
+
+instance (Outputable instr) => Outputable (GenBasicBlock instr) where
ppr b = pprBBlock b
instance Outputable CmmStmt where
instance Outputable CmmInfo where
ppr e = pprInfo e
+
+
-----------------------------------------------------------------------------
-pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
+pprCmm :: (Outputable info, Outputable g) => GenCmm CmmStatic info g -> SDoc
pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
-pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
-pprTop (CmmProc info lbl params blocks )
+pprTop :: (Outputable d, Outputable info, Outputable i)
+ => GenCmmTop d info i -> SDoc
+
+pprTop (CmmProc info lbl params graph )
= vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
, nest 8 $ lbrace <+> ppr info $$ rbrace
- , nest 4 $ vcat (map ppr blocks)
+ , nest 4 $ ppr graph
, rbrace ]
-- --------------------------------------------------------------------------
-- 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
-- --------------------------------------------------------------------------
-- 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)) =
- 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("srt: ") <> ppr srt,
ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
ptext SLIT("arity: ") <> integer (toInteger arity),
- --ppr args, -- TODO: needs to be printed
+ --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed
ptext SLIT("slow: ") <> pprLit slow_entry
]
pprTypeInfo (ThunkInfo layout srt) =
-- --------------------------------------------------------------------------
-- 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 safety ->
+ CmmCall (CmmCallee fn cconv) results args safety ret ->
hcat [ if null results
then empty
else parens (commafy $ map ppr results) <>
ptext SLIT(" = "),
- ptext SLIT("call"), space,
+ ptext SLIT("foreign"), 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')
- 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)
CmmLoad (CmmReg _) _ -> pprExpr expr
_ -> parens (pprExpr expr)
, space
- , parens ( commafy $ map ppr args )
+ , parens ( commafy $ map pprHinted args )
, semi ]
+pprHinted :: Outputable a => (a, MachHint) -> SDoc
+pprHinted (a, NoHint) = ppr a
+pprHinted (a, PtrHint) = quotes(text "address") <+> ppr a
+pprHinted (a, SignedHint) = quotes(text "signed") <+> ppr a
+pprHinted (a, FloatHint) = quotes(text "float") <+> ppr a
+
-- --------------------------------------------------------------------------
-- Return from a function. [1], Section 6.8.2 of version 1.128
--
pprLocalReg :: LocalReg -> SDoc
pprLocalReg (LocalReg uniq rep follow)
= hcat [ char '_', ppr uniq, ty ] where
- ty = if rep == wordRep && follow == KindNonPtr
+ ty = if rep == wordRep && follow == GCKindNonPtr
then empty
else dcolon <> ptr <> ppr rep
- ptr = if follow == KindNonPtr
+ ptr = if follow == GCKindNonPtr
then empty
else doubleQuotes (text "ptr")
Text -> section <+> doubleQuotes (ptext SLIT("text"))
Data -> section <+> doubleQuotes (ptext SLIT("data"))
ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
+ ReadOnlyData16 -> section <+> doubleQuotes (ptext SLIT("readonly16"))
RelocatableReadOnlyData
-> section <+> doubleQuotes (ptext SLIT("relreadonly"))
UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
projects / ghc-hetmet.git / blobdiff