import Data.List
import System.IO
import Data.Maybe
-import Data.Char
-pprCmms :: [Cmm] -> SDoc
+pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ ptext SLIT("-------------------") $$ space
-----------------------------------------------------------------------------
-instance Outputable Cmm where
+instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
ppr c = pprCmm c
-instance Outputable CmmTop where
+instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where
ppr t = pprTop t
instance Outputable CmmBasicBlock where
instance Outputable CmmReg where
ppr e = pprReg e
+instance Outputable LocalReg where
+ ppr e = pprLocalReg e
+
instance Outputable GlobalReg where
ppr e = pprGlobalReg e
+instance Outputable CmmStatic where
+ ppr e = pprStatic e
+
+instance Outputable CmmInfo where
+ ppr e = pprInfo e
+
-----------------------------------------------------------------------------
-pprCmm :: Cmm -> SDoc
+pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-- --------------------------------------------------------------------------
--- Top level `procedure' blocks. The info tables, if not null, are
--- printed in the style of C--'s 'stackdata' declaration, just inside
--- the proc body, and are labelled with the procedure name ++ "_info".
+-- Top level `procedure' blocks.
--
-pprTop :: CmmTop -> SDoc
+pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
pprTop (CmmProc info lbl params blocks )
- = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace
- , nest 8 $ pprInfo info lbl
+ = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
+ , nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ vcat (map ppr blocks)
, rbrace ]
- where
- pprInfo [] _ = empty
- pprInfo i label =
- (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
- 4 $ vcat (map pprStatic i))
- $$ rbrace
-
-- --------------------------------------------------------------------------
-- We follow [1], 4.5
--
$$ rbrace
+
+-- --------------------------------------------------------------------------
+-- Info tables. The current pretty printer needs refinement
+-- but will work for now.
+--
+-- 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 gc_target) =
+ ptext SLIT("gc_target: ") <>
+ maybe (ptext SLIT("<none>")) pprBlockId gc_target
+pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
+ gc_target tag info) =
+ vcat [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]
+
+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) =
+ 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
+ ]
+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]
+
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
- CmmCall (CmmForeignCall fn cconv) results args _volatile ->
- hcat [ ptext SLIT("call"), space,
+ CmmCall (CmmForeignCall fn cconv) results args srt ->
+ hcat [ if null results
+ then empty
+ else parens (commafy $ map ppr results) <>
+ ptext SLIT(" = "),
+ ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
- (if null results
- then empty
- else brackets( commafy $ map ppr results)), semi ]
+ brackets (ppr srt), semi ]
where
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
- CmmCall (CmmPrim op) results args volatile ->
+ CmmCall (CmmPrim op) results args srt ->
pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
- results args volatile)
+ results args srt)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
CmmBranch ident -> genBranch ident
CmmCondBranch expr ident -> genCondBranch expr ident
CmmJump expr params -> genJump expr params
+ CmmReturn params -> genReturn params
CmmSwitch arg ids -> genSwitch arg ids
-- --------------------------------------------------------------------------
--
-- jump foo(a, b, c);
--
-genJump :: CmmExpr -> [LocalReg] -> SDoc
-genJump expr actuals =
+genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
+genJump expr args =
hcat [ ptext SLIT("jump")
, space
else case expr of
CmmLoad (CmmReg _) _ -> pprExpr expr
_ -> parens (pprExpr expr)
- , pprActuals actuals
+ , space
+ , parens ( commafy $ map ppr args )
, semi ]
- where
- pprActuals [] = empty
- pprActuals as = parens ( commafy $ map pprLocalReg as )
+-- --------------------------------------------------------------------------
+-- Return from a function. [1], Section 6.8.2 of version 1.128
+--
+-- return (a, b, c);
+--
+genReturn :: [(CmmExpr, MachHint)] -> SDoc
+genReturn args =
+
+ hcat [ ptext SLIT("return")
+ , space
+ , parens ( commafy $ map ppr args )
+ , semi ]
-- --------------------------------------------------------------------------
-- Tabled jump to local label
CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
CmmAlign i -> nest 4 $ text "align" <+> int i
CmmDataLabel clbl -> pprCLabel clbl <> colon
- CmmString s' -> nest 4 $ text "I8[]" <+>
- doubleQuotes (text (map (chr.fromIntegral) s'))
+ CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
-- --------------------------------------------------------------------------
-- Registers, whether local (temps) or global
-- We only print the type of the local reg if it isn't wordRep
--
pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq rep)
- = hcat [ char '_', ppr uniq,
- (if rep == wordRep
- then empty else dcolon <> ppr rep) ]
+pprLocalReg (LocalReg uniq rep follow)
+ = hcat [ char '_', ppr uniq, ty ] where
+ ty = if rep == wordRep && follow == KindNonPtr
+ then empty
+ else dcolon <> ptr <> ppr rep
+ ptr = if follow == KindNonPtr
+ then empty
+ else doubleQuotes (text "ptr")
-- needs to be kept in syn with Cmm.hs.GlobalReg
--
projects / ghc-hetmet.git / blobdiff