1 ----------------------------------------------------------------------------
3 -- Pretty-printing of Cmm as (a superset of) C--
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
9 -- This is where we walk over CmmNode emitting an external representation,
10 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
11 -- is the "External Core" for the Cmm layer.
13 -- As such, this should be a well-defined syntax: we want it to look nice.
14 -- Thus, we try wherever possible to use syntax defined in [1],
15 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
16 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
17 -- than C--'s bits8 .. bits64.
19 -- We try to ensure that all information available in the abstract
20 -- syntax is reproduced, or reproducible, in the concrete syntax.
21 -- Data that is not in printed out can be reconstructed according to
22 -- conventions used in the pretty printer. There are at least two such
24 -- 1) if a value has wordRep type, the type is not appended in the
26 -- 2) MachOps that operate over wordRep type are printed in a
27 -- C-style, rather than as their internal MachRep name.
29 -- These conventions produce much more readable Cmm output.
31 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
33 {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}
44 import CmmUtils (isTrivialCmmExpr)
54 import Prelude hiding (succ)
56 -------------------------------------------------
57 -- Outputable instances
59 instance Outputable CmmStackInfo where
62 instance Outputable CmmTopInfo where
66 instance Outputable (CmmNode e x) where
69 instance Outputable Convention where
72 instance Outputable ForeignConvention where
73 ppr = pprForeignConvention
75 instance Outputable ForeignTarget where
76 ppr = pprForeignTarget
79 instance Outputable (Block CmmNode C C) where
81 instance Outputable (Block CmmNode C O) where
83 instance Outputable (Block CmmNode O C) where
85 instance Outputable (Block CmmNode O O) where
88 instance Outputable (Graph CmmNode e x) where
91 instance Outputable CmmGraph where
94 ----------------------------------------------------------
95 -- Outputting types Cmm contains
97 pprStackInfo :: CmmStackInfo -> SDoc
98 pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
99 ptext (sLit "arg_space: ") <> ppr arg_space <+>
100 ptext (sLit "updfr_space: ") <> ppr updfr_space
102 pprTopInfo :: CmmTopInfo -> SDoc
103 pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
104 vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl,
105 ptext (sLit "stack_info: ") <> ppr stack_info]
107 ----------------------------------------------------------
108 -- Outputting blocks and graphs
110 pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc
111 pprBlock block = foldBlockNodesB3 ( ($$) . ppr
112 , ($$) . (nest 4) . ppr
113 , ($$) . (nest 4) . ppr
118 pprGraph :: Graph CmmNode e x -> SDoc
119 pprGraph GNil = empty
120 pprGraph (GUnit block) = ppr block
121 pprGraph (GMany entry body exit)
123 $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
125 where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc
126 pprMaybeO NothingO = empty
127 pprMaybeO (JustO block) = ppr block
129 pprCmmGraph :: CmmGraph -> SDoc
131 = text "{" <> text "offset"
132 $$ nest 2 (vcat $ map ppr blocks)
134 where blocks = postorderDfs g
136 ---------------------------------------------
137 -- Outputting CmmNode and types which it contains
139 pprConvention :: Convention -> SDoc
140 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
141 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
142 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
143 pprConvention Slow = text "<slow-convention>"
144 pprConvention GC = text "<gc-convention>"
145 pprConvention PrimOpCall = text "<primop-call-convention>"
146 pprConvention PrimOpReturn = text "<primop-ret-convention>"
147 pprConvention (Foreign c) = ppr c
148 pprConvention (Private {}) = text "<private-convention>"
150 pprForeignConvention :: ForeignConvention -> SDoc
151 pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
153 pprForeignTarget :: ForeignTarget -> SDoc
154 pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
155 where ppr_fc :: ForeignConvention -> SDoc
156 ppr_fc (ForeignConvention c args res) =
157 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res
158 ppr_target :: CmmExpr -> SDoc
159 ppr_target t@(CmmLit _) = ppr t
160 ppr_target fn' = parens (ppr fn')
162 pprForeignTarget (PrimTarget op)
163 -- HACK: We're just using a ForeignLabel to get this printed, the label
164 -- might not really be foreign.
165 = ppr (CmmLabel (mkForeignLabel
166 (mkFastString (show op))
167 Nothing ForeignLabelInThisPackage IsFunction))
168 pprNode :: CmmNode e x -> SDoc
169 pprNode node = pp_node <+> pp_debug
172 pp_node = case node of
174 CmmEntry id -> ppr id <> colon
177 CmmComment s -> text "//" <+> ftext s
180 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
183 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
185 rep = ppr ( cmmExprType expr )
187 -- call "ccall" foo(x, y)[r1, r2];
189 CmmUnsafeForeignCall target results args ->
190 hsep [ ppUnless (null results) $
191 parens (commafy $ map ppr results) <+> equals,
193 ppr target <> parens (commafy $ map ppr args) <> semi]
196 CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
198 -- if (expr) goto t; else goto f;
199 CmmCondBranch expr t f ->
200 hsep [ ptext (sLit "if")
202 , ptext (sLit "goto")
204 , ptext (sLit "else goto")
208 CmmSwitch expr maybe_ids ->
209 hang (hcat [ ptext (sLit "switch [0 .. ")
210 , int (length maybe_ids - 1)
212 , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr)
215 4 (vcat ( map caseify pairs )) $$ rbrace
216 where pairs = groupBy snds (zip [0 .. ] maybe_ids )
217 snds a b = (snd a) == (snd b)
218 caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ")
219 <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */")
220 caseify as = let (is,ids) = unzip as
221 in hsep [ ptext (sLit "case")
222 , hcat (punctuate comma (map int is))
223 , ptext (sLit ": goto")
224 , ppr (head [ id | Just id <- ids]) <> semi ]
226 CmmCall tgt k out res updfr_off ->
227 hcat [ ptext (sLit "call"), space
228 , pprFun tgt, ptext (sLit "(...)"), space
229 , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
231 , ptext (sLit " with update frame") <+> ppr updfr_off
233 where pprFun f@(CmmLit _) = ppr f
234 pprFun f = parens (ppr f)
236 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
237 hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
238 [ ptext (sLit "foreign call"), space
239 , ppr t, ptext (sLit "(...)"), space
240 , ptext (sLit "returns to") <+> ppr s
241 <+> ptext (sLit "args:") <+> parens (ppr as)
242 <+> ptext (sLit "ress:") <+> parens (ppr rs)
243 , ptext (sLit " with update frame") <+> ppr u
248 if not debugIsOn then empty
250 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
251 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
252 CmmAssign {} -> text " // CmmAssign"
253 CmmStore {} -> text " // CmmStore"
254 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
255 CmmBranch {} -> text " // CmmBranch"
256 CmmCondBranch {} -> text " // CmmCondBranch"
257 CmmSwitch {} -> text " // CmmSwitch"
258 CmmCall {} -> text " // CmmCall"
259 CmmForeignCall {} -> text " // CmmForeignCall"
261 commafy :: [SDoc] -> SDoc
262 commafy xs = hsep $ punctuate comma xs