1 ----------------------------------------------------------------------------
3 -- Pretty-printing of Cmm as (a superset of) C--
5 -- (c) The University of Glasgow 2004-2006
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"
55 pprCmms :: [Cmm] -> SDoc
56 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
58 separator = space $$ ptext SLIT("-------------------") $$ space
60 writeCmms :: Handle -> [Cmm] -> IO ()
61 writeCmms handle cmms = printForC handle (pprCmms cmms)
63 -----------------------------------------------------------------------------
65 instance Outputable Cmm where
68 instance Outputable CmmTop where
71 instance Outputable CmmBasicBlock where
74 instance Outputable CmmStmt where
77 instance Outputable CmmExpr where
80 instance Outputable CmmReg where
83 instance Outputable LocalReg where
86 instance Outputable GlobalReg where
87 ppr e = pprGlobalReg e
89 -----------------------------------------------------------------------------
92 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
94 -- --------------------------------------------------------------------------
95 -- Top level `procedure' blocks. The info tables, if not null, are
96 -- printed in the style of C--'s 'stackdata' declaration, just inside
97 -- the proc body, and are labelled with the procedure name ++ "_info".
99 pprTop :: CmmTop -> SDoc
100 pprTop (CmmProc info lbl params blocks )
102 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
103 , nest 8 $ pprInfo info lbl
104 , nest 4 $ vcat (map ppr blocks)
110 (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
111 4 $ vcat (map pprStatic i))
114 -- --------------------------------------------------------------------------
115 -- We follow [1], 4.5
117 -- section "data" { ... }
119 pprTop (CmmData section ds) =
120 (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
124 -- --------------------------------------------------------------------------
125 -- Basic blocks look like assembly blocks.
126 -- lbl: stmt ; stmt ; ..
127 pprBBlock :: CmmBasicBlock -> SDoc
128 pprBBlock (BasicBlock ident stmts) =
129 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
131 -- --------------------------------------------------------------------------
132 -- Statements. C-- usually, exceptions to this should be obvious.
134 pprStmt :: CmmStmt -> SDoc
135 pprStmt stmt = case stmt of
141 CmmComment s -> text "//" <+> ftext s
144 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
147 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
149 rep = ppr ( cmmExprRep expr )
151 -- call "ccall" foo(x, y)[r1, r2];
153 CmmCall (CmmForeignCall fn cconv) results args _volatile ->
154 hcat [ ptext SLIT("call"), space,
155 doubleQuotes(ppr cconv), space,
156 target fn, parens ( commafy $ map ppr args ),
159 else brackets( commafy $ map ppr results)), semi ]
161 target (CmmLit lit) = pprLit lit
162 target fn' = parens (ppr fn')
164 CmmCall (CmmPrim op) results args volatile ->
165 pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
166 results args volatile)
168 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
170 CmmBranch ident -> genBranch ident
171 CmmCondBranch expr ident -> genCondBranch expr ident
172 CmmJump expr params -> genJump expr params
173 CmmReturn params -> genReturn params
174 CmmSwitch arg ids -> genSwitch arg ids
176 -- --------------------------------------------------------------------------
177 -- goto local label. [1], section 6.6
181 genBranch :: BlockId -> SDoc
183 ptext SLIT("goto") <+> pprBlockId ident <> semi
185 -- --------------------------------------------------------------------------
186 -- Conditional. [1], section 6.4
188 -- if (expr) { goto lbl; }
190 genCondBranch :: CmmExpr -> BlockId -> SDoc
191 genCondBranch expr ident =
192 hsep [ ptext SLIT("if")
195 , pprBlockId ident <> semi ]
197 -- --------------------------------------------------------------------------
198 -- A tail call. [1], Section 6.9
200 -- jump foo(a, b, c);
202 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
205 hcat [ ptext SLIT("jump")
207 , if isTrivialCmmExpr expr
210 CmmLoad (CmmReg _) _ -> pprExpr expr
211 _ -> parens (pprExpr expr)
213 , parens ( commafy $ map ppr args )
216 -- --------------------------------------------------------------------------
217 -- Return from a function. [1], Section 6.8.2 of version 1.128
221 genReturn :: [(CmmExpr, MachHint)] -> SDoc
224 hcat [ ptext SLIT("return")
226 , parens ( commafy $ map ppr args )
229 -- --------------------------------------------------------------------------
230 -- Tabled jump to local label
232 -- The syntax is from [1], section 6.5
234 -- switch [0 .. n] (expr) { case ... ; }
236 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
237 genSwitch expr maybe_ids
239 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
241 in hang (hcat [ ptext SLIT("switch [0 .. ")
242 , int (length maybe_ids - 1)
244 , if isTrivialCmmExpr expr
246 else parens (pprExpr expr)
249 4 (vcat ( map caseify pairs )) $$ rbrace
252 snds a b = (snd a) == (snd b)
254 caseify :: [(Int,Maybe BlockId)] -> SDoc
255 caseify ixs@((i,Nothing):_)
256 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
259 = let (is,ids) = unzip as
260 in hsep [ ptext SLIT("case")
261 , hcat (punctuate comma (map int is))
262 , ptext SLIT(": goto")
263 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
265 -- --------------------------------------------------------------------------
269 pprExpr :: CmmExpr -> SDoc
273 pprExpr (CmmMachOp (MO_Add rep)
274 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
275 where rep = cmmRegRep reg
276 CmmLit lit -> pprLit lit
279 -- Here's the precedence table from CmmParse.y:
280 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
289 -- We just cope with the common operators for now, the rest will get
290 -- a default conservative behaviour.
292 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
293 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
294 = pprExpr7 x <+> doc <+> pprExpr7 y
295 pprExpr1 e = pprExpr7 e
297 infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
298 infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
299 infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
300 infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
301 infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
302 infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
303 infixMachOp1 (MO_U_Gt _) = Just (char '>')
304 infixMachOp1 (MO_U_Lt _) = Just (char '<')
305 infixMachOp1 _ = Nothing
308 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
309 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
310 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
311 = pprExpr7 x <+> doc <+> pprExpr8 y
312 pprExpr7 e = pprExpr8 e
314 infixMachOp7 (MO_Add _) = Just (char '+')
315 infixMachOp7 (MO_Sub _) = Just (char '-')
316 infixMachOp7 _ = Nothing
319 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
320 = pprExpr8 x <+> doc <+> pprExpr9 y
321 pprExpr8 e = pprExpr9 e
323 infixMachOp8 (MO_U_Quot _) = Just (char '/')
324 infixMachOp8 (MO_Mul _) = Just (char '*')
325 infixMachOp8 (MO_U_Rem _) = Just (char '%')
326 infixMachOp8 _ = Nothing
328 pprExpr9 :: CmmExpr -> SDoc
331 CmmLit lit -> pprLit1 lit
332 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
333 CmmReg reg -> ppr reg
334 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
335 CmmMachOp mop args -> genMachOp mop args
337 genMachOp :: MachOp -> [CmmExpr] -> SDoc
339 | Just doc <- infixMachOp mop = case args of
341 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
344 [x] -> doc <> pprExpr9 x
346 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
348 parens (hcat $ punctuate comma (map pprExpr args)))
351 | isJust (infixMachOp1 mop)
352 || isJust (infixMachOp7 mop)
353 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
355 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
356 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
358 -- replace spaces in (show mop) with underscores,
361 -- Unsigned ops on the word size of the machine get nice symbols.
362 -- All else get dumped in their ugly format.
364 infixMachOp :: MachOp -> Maybe SDoc
367 MO_And _ -> Just $ char '&'
368 MO_Or _ -> Just $ char '|'
369 MO_Xor _ -> Just $ char '^'
370 MO_Not _ -> Just $ char '~'
371 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
374 -- --------------------------------------------------------------------------
376 -- To minimise line noise we adopt the convention that if the literal
377 -- has the natural machine word size, we do not append the type
379 pprLit :: CmmLit -> SDoc
380 pprLit lit = case lit of
382 hcat [ (if i < 0 then parens else id)(integer i)
385 else space <> dcolon <+> ppr rep) ]
387 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
388 CmmLabel clbl -> pprCLabel clbl
389 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
390 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
391 <> pprCLabel clbl2 <> ppr_offset i
393 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
394 pprLit1 lit = pprLit lit
396 ppr_offset :: Int -> SDoc
399 | i>=0 = char '+' <> int i
400 | otherwise = char '-' <> int (-i)
402 -- --------------------------------------------------------------------------
404 -- Strings are printed as C strings, and we print them as I8[],
407 pprStatic :: CmmStatic -> SDoc
408 pprStatic s = case s of
409 CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
410 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
411 CmmAlign i -> nest 4 $ text "align" <+> int i
412 CmmDataLabel clbl -> pprCLabel clbl <> colon
413 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
415 -- --------------------------------------------------------------------------
416 -- Registers, whether local (temps) or global
418 pprReg :: CmmReg -> SDoc
421 CmmLocal local -> pprLocalReg local
422 CmmGlobal global -> pprGlobalReg global
425 -- We only print the type of the local reg if it isn't wordRep
427 pprLocalReg :: LocalReg -> SDoc
428 pprLocalReg (LocalReg uniq rep)
429 = hcat [ char '_', ppr uniq,
431 then empty else dcolon <> ppr rep) ]
433 -- needs to be kept in syn with Cmm.hs.GlobalReg
435 pprGlobalReg :: GlobalReg -> SDoc
438 VanillaReg n -> char 'R' <> int n
439 FloatReg n -> char 'F' <> int n
440 DoubleReg n -> char 'D' <> int n
441 LongReg n -> char 'L' <> int n
442 Sp -> ptext SLIT("Sp")
443 SpLim -> ptext SLIT("SpLim")
444 Hp -> ptext SLIT("Hp")
445 HpLim -> ptext SLIT("HpLim")
446 CurrentTSO -> ptext SLIT("CurrentTSO")
447 CurrentNursery -> ptext SLIT("CurrentNursery")
448 HpAlloc -> ptext SLIT("HpAlloc")
449 GCEnter1 -> ptext SLIT("stg_gc_enter_1")
450 GCFun -> ptext SLIT("stg_gc_fun")
451 BaseReg -> ptext SLIT("BaseReg")
452 PicBaseReg -> ptext SLIT("PicBaseReg")
454 -- --------------------------------------------------------------------------
457 pprSection :: Section -> SDoc
458 pprSection s = case s of
459 Text -> section <+> doubleQuotes (ptext SLIT("text"))
460 Data -> section <+> doubleQuotes (ptext SLIT("data"))
461 ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
462 RelocatableReadOnlyData
463 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
464 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
465 OtherSection s' -> section <+> doubleQuotes (text s')
467 section = ptext SLIT("section")
469 -- --------------------------------------------------------------------------
472 pprBlockId :: BlockId -> SDoc
473 pprBlockId b = ppr $ getUnique b
475 -----------------------------------------------------------------------------
477 commafy :: [SDoc] -> SDoc
478 commafy xs = hsep $ punctuate comma xs