1 ----------------------------------------------------------------------------
3 -- Pretty-printing of Cmm as (a superset of) C--
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
10 -- This is where we walk over Cmm emitting an external representation,
11 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
12 -- is the "External Core" for the Cmm layer.
14 -- As such, this should be a well-defined syntax: we want it to look nice.
15 -- Thus, we try wherever possible to use syntax defined in [1],
16 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
17 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
18 -- than C--'s bits8 .. bits64.
20 -- We try to ensure that all information available in the abstract
21 -- syntax is reproduced, or reproducible, in the concrete syntax.
22 -- Data that is not in printed out can be reconstructed according to
23 -- conventions used in the pretty printer. There are at least two such
25 -- 1) if a value has wordRep type, the type is not appended in the
27 -- 2) MachOps that operate over wordRep type are printed in a
28 -- C-style, rather than as their internal MachRep name.
30 -- These conventions produce much more readable Cmm output.
32 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
36 writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
39 #include "HsVersions.h"
42 import CmmUtils ( isTrivialCmmExpr )
43 import MachOp ( MachOp(..), pprMachOp, MachRep(..), wordRep )
44 import CLabel ( pprCLabel, mkForeignLabel, entryLblToInfoLbl )
46 import ForeignCall ( CCallConv(..) )
47 import Unique ( getUnique )
49 import FastString ( mkFastString )
51 import Data.List ( intersperse, groupBy )
53 import Maybe ( isJust )
54 import Data.Char ( chr )
56 pprCmms :: [Cmm] -> SDoc
57 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
59 separator = space $$ ptext SLIT("-------------------") $$ space
61 writeCmms :: Handle -> [Cmm] -> IO ()
62 writeCmms handle cmms = printForC handle (pprCmms cmms)
64 -----------------------------------------------------------------------------
66 instance Outputable Cmm where
69 instance Outputable CmmTop where
72 instance Outputable CmmBasicBlock where
75 instance Outputable CmmStmt where
78 instance Outputable CmmExpr where
81 instance Outputable CmmReg where
84 instance Outputable GlobalReg where
85 ppr e = pprGlobalReg e
87 -----------------------------------------------------------------------------
90 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
92 -- --------------------------------------------------------------------------
93 -- Top level `procedure' blocks. The info tables, if not null, are
94 -- printed in the style of C--'s 'stackdata' declaration, just inside
95 -- the proc body, and are labelled with the procedure name ++ "_info".
97 pprTop :: CmmTop -> SDoc
98 pprTop (CmmProc info lbl params blocks )
100 = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace
101 , nest 8 $ pprInfo info lbl
102 , nest 4 $ vcat (map ppr blocks)
108 (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
109 4 $ vcat (map pprStatic i))
112 -- --------------------------------------------------------------------------
113 -- We follow [1], 4.5
115 -- section "data" { ... }
117 pprTop (CmmData section ds) =
118 (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
122 -- --------------------------------------------------------------------------
123 -- Basic blocks look like assembly blocks.
124 -- lbl: stmt ; stmt ; ..
125 pprBBlock :: CmmBasicBlock -> SDoc
126 pprBBlock (BasicBlock ident stmts) =
127 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
129 -- --------------------------------------------------------------------------
130 -- Statements. C-- usually, exceptions to this should be obvious.
132 pprStmt :: CmmStmt -> SDoc
133 pprStmt stmt = case stmt of
139 CmmComment s -> text "//" <+> ftext s
142 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
145 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
147 rep = ppr ( cmmExprRep expr )
149 -- call "ccall" foo(x, y)[r1, r2];
151 CmmCall (CmmForeignCall fn cconv) results args _volatile ->
152 hcat [ ptext SLIT("call"), space,
153 doubleQuotes(ppr cconv), space,
154 target fn, parens ( commafy $ map ppr args ),
157 else brackets( commafy $ map ppr results)), semi ]
159 target (CmmLit lit) = pprLit lit
160 target fn' = parens (ppr fn')
162 CmmCall (CmmPrim op) results args volatile ->
163 pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
164 results args volatile)
166 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
168 CmmBranch ident -> genBranch ident
169 CmmCondBranch expr ident -> genCondBranch expr ident
170 CmmJump expr params -> genJump expr params
171 CmmSwitch arg ids -> genSwitch arg ids
173 -- --------------------------------------------------------------------------
174 -- goto local label. [1], section 6.6
178 genBranch :: BlockId -> SDoc
180 ptext SLIT("goto") <+> pprBlockId ident <> semi
182 -- --------------------------------------------------------------------------
183 -- Conditional. [1], section 6.4
185 -- if (expr) { goto lbl; }
187 genCondBranch :: CmmExpr -> BlockId -> SDoc
188 genCondBranch expr ident =
189 hsep [ ptext SLIT("if")
192 , pprBlockId ident <> semi ]
194 -- --------------------------------------------------------------------------
195 -- A tail call. [1], Section 6.9
197 -- jump foo(a, b, c);
199 genJump :: CmmExpr -> [LocalReg] -> SDoc
200 genJump expr actuals =
202 hcat [ ptext SLIT("jump")
204 , if isTrivialCmmExpr expr
207 CmmLoad (CmmReg _) _ -> pprExpr expr
208 _ -> parens (pprExpr expr)
213 pprActuals [] = empty
214 pprActuals as = parens ( commafy $ map pprLocalReg as )
216 -- --------------------------------------------------------------------------
217 -- Tabled jump to local label
219 -- The syntax is from [1], section 6.5
221 -- switch [0 .. n] (expr) { case ... ; }
223 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
224 genSwitch expr maybe_ids
226 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
228 in hang (hcat [ ptext SLIT("switch [0 .. ")
229 , int (length maybe_ids - 1)
231 , if isTrivialCmmExpr expr
233 else parens (pprExpr expr)
236 4 (vcat ( map caseify pairs )) $$ rbrace
239 snds a b = (snd a) == (snd b)
241 caseify :: [(Int,Maybe BlockId)] -> SDoc
242 caseify ixs@((i,Nothing):_)
243 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
246 = let (is,ids) = unzip as
247 in hsep [ ptext SLIT("case")
248 , hcat (punctuate comma (map int is))
249 , ptext SLIT(": goto")
250 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
252 -- --------------------------------------------------------------------------
256 pprExpr :: CmmExpr -> SDoc
260 pprExpr (CmmMachOp (MO_Add rep)
261 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
262 where rep = cmmRegRep reg
263 CmmLit lit -> pprLit lit
266 -- Here's the precedence table from CmmParse.y:
267 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
276 -- We just cope with the common operators for now, the rest will get
277 -- a default conservative behaviour.
279 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
280 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
281 = pprExpr7 x <+> doc <+> pprExpr7 y
282 pprExpr1 e = pprExpr7 e
284 infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
285 infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
286 infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
287 infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
288 infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
289 infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
290 infixMachOp1 (MO_U_Gt _) = Just (char '>')
291 infixMachOp1 (MO_U_Lt _) = Just (char '<')
292 infixMachOp1 _ = Nothing
295 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
296 = pprExpr7 x <+> doc <+> pprExpr8 y
297 pprExpr7 e = pprExpr8 e
299 infixMachOp7 (MO_Add _) = Just (char '+')
300 infixMachOp7 (MO_Sub _) = Just (char '-')
301 infixMachOp7 _ = Nothing
304 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
305 = pprExpr8 x <+> doc <+> pprExpr9 y
306 pprExpr8 e = pprExpr9 e
308 infixMachOp8 (MO_U_Quot _) = Just (char '/')
309 infixMachOp8 (MO_Mul _) = Just (char '*')
310 infixMachOp8 (MO_U_Rem _) = Just (char '%')
311 infixMachOp8 _ = Nothing
313 pprExpr9 :: CmmExpr -> SDoc
316 CmmLit lit -> pprLit1 lit
317 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
318 CmmReg reg -> ppr reg
319 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
320 CmmMachOp mop args -> genMachOp mop args
322 genMachOp :: MachOp -> [CmmExpr] -> SDoc
324 | Just doc <- infixMachOp mop = case args of
326 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
329 [x] -> doc <> pprExpr9 x
331 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
333 parens (hcat $ punctuate comma (map pprExpr args)))
336 | isJust (infixMachOp1 mop)
337 || isJust (infixMachOp7 mop)
338 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
340 | otherwise = char '%' <> pprMachOp mop <> parens (commafy (map pprExpr args))
343 -- Unsigned ops on the word size of the machine get nice symbols.
344 -- All else get dumped in their ugly format.
346 infixMachOp :: MachOp -> Maybe SDoc
349 MO_And _ -> Just $ char '&'
350 MO_Or _ -> Just $ char '|'
351 MO_Xor _ -> Just $ char '^'
352 MO_Not _ -> Just $ char '~'
353 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
356 -- --------------------------------------------------------------------------
358 -- To minimise line noise we adopt the convention that if the literal
359 -- has the natural machine word size, we do not append the type
361 pprLit :: CmmLit -> SDoc
362 pprLit lit = case lit of
364 hcat [ (if i < 0 then parens else id)(integer i)
367 else space <> dcolon <+> ppr rep) ]
369 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
370 CmmLabel clbl -> pprCLabel clbl
371 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
372 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
373 <> pprCLabel clbl2 <> ppr_offset i
375 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
376 pprLit1 lit = pprLit lit
378 ppr_offset :: Int -> SDoc
381 | i>=0 = char '+' <> int i
382 | otherwise = char '-' <> int (-i)
384 -- --------------------------------------------------------------------------
386 -- Strings are printed as C strings, and we print them as I8[],
389 pprStatic :: CmmStatic -> SDoc
390 pprStatic s = case s of
391 CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
392 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
393 CmmAlign i -> nest 4 $ text "align" <+> int i
394 CmmDataLabel clbl -> pprCLabel clbl <> colon
395 CmmString s' -> nest 4 $ text "I8[]" <+>
396 doubleQuotes (text (map (chr.fromIntegral) s'))
398 -- --------------------------------------------------------------------------
399 -- Registers, whether local (temps) or global
401 pprReg :: CmmReg -> SDoc
404 CmmLocal local -> pprLocalReg local
405 CmmGlobal global -> pprGlobalReg global
408 -- We only print the type of the local reg if it isn't wordRep
410 pprLocalReg :: LocalReg -> SDoc
411 pprLocalReg (LocalReg uniq rep)
412 = hcat [ char '_', ppr uniq,
414 then empty else dcolon <> ppr rep) ]
416 -- needs to be kept in syn with Cmm.hs.GlobalReg
418 pprGlobalReg :: GlobalReg -> SDoc
421 VanillaReg n -> char 'R' <> int n
422 FloatReg n -> char 'F' <> int n
423 DoubleReg n -> char 'D' <> int n
424 LongReg n -> char 'L' <> int n
425 Sp -> ptext SLIT("Sp")
426 SpLim -> ptext SLIT("SpLim")
427 Hp -> ptext SLIT("Hp")
428 HpLim -> ptext SLIT("HpLim")
429 CurrentTSO -> ptext SLIT("CurrentTSO")
430 CurrentNursery -> ptext SLIT("CurrentNursery")
431 HpAlloc -> ptext SLIT("HpAlloc")
432 GCEnter1 -> ptext SLIT("stg_gc_enter_1")
433 GCFun -> ptext SLIT("stg_gc_fun")
434 BaseReg -> ptext SLIT("BaseReg")
435 PicBaseReg -> ptext SLIT("PicBaseReg")
437 -- --------------------------------------------------------------------------
440 pprSection :: Section -> SDoc
441 pprSection s = case s of
442 Text -> section <+> doubleQuotes (ptext SLIT("text"))
443 Data -> section <+> doubleQuotes (ptext SLIT("data"))
444 ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
445 RelocatableReadOnlyData
446 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
447 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
448 OtherSection s' -> section <+> doubleQuotes (text s')
450 section = ptext SLIT("section")
452 -- --------------------------------------------------------------------------
455 pprBlockId :: BlockId -> SDoc
456 pprBlockId b = ppr $ getUnique b
458 -----------------------------------------------------------------------------
460 commafy :: [SDoc] -> SDoc
461 commafy xs = hsep $ punctuate comma xs