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, pprSection, pprStatic
39 #include "HsVersions.h"
55 pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> 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 info) => Outputable (GenCmm CmmStatic info CmmStmt) where
68 instance (Outputable d, Outputable info, Outputable i)
69 => Outputable (GenCmmTop d info i) where
72 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
75 instance Outputable BlockId where
76 ppr id = pprBlockId id
78 instance Outputable CmmStmt where
81 instance Outputable CmmExpr where
84 instance Outputable CmmReg where
87 instance Outputable LocalReg where
90 instance Outputable GlobalReg where
91 ppr e = pprGlobalReg e
93 instance Outputable CmmStatic where
96 instance Outputable CmmInfo where
101 -----------------------------------------------------------------------------
103 pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
104 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
106 -- --------------------------------------------------------------------------
107 -- Top level `procedure' blocks.
109 pprTop :: (Outputable d, Outputable info, Outputable i)
110 => GenCmmTop d info i -> SDoc
112 pprTop (CmmProc info lbl params blocks )
114 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
115 , nest 8 $ lbrace <+> ppr info $$ rbrace
116 , nest 4 $ vcat (map ppr blocks)
119 -- --------------------------------------------------------------------------
120 -- We follow [1], 4.5
122 -- section "data" { ... }
124 pprTop (CmmData section ds) =
125 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
128 -- --------------------------------------------------------------------------
129 instance Outputable CmmSafety where
130 ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
131 ppr (CmmSafe srt) = ppr srt
133 -- --------------------------------------------------------------------------
134 -- Info tables. The current pretty printer needs refinement
135 -- but will work for now.
137 -- For ideas on how to refine it, they used to be printed in the
138 -- style of C--'s 'stackdata' declaration, just inside the proc body,
139 -- and were labelled with the procedure name ++ "_info".
140 pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) =
141 vcat [{-ptext SLIT("gc_target: ") <>
142 maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
143 ptext SLIT("update_frame: ") <>
144 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame]
145 pprInfo (CmmInfo gc_target update_frame
146 (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
147 vcat [{-ptext SLIT("gc_target: ") <>
148 maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
149 ptext SLIT("update_frame: ") <>
150 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
151 ptext SLIT("type: ") <> pprLit closure_type,
152 ptext SLIT("desc: ") <> pprLit closure_desc,
153 ptext SLIT("tag: ") <> integer (toInteger tag),
156 pprTypeInfo (ConstrInfo layout constr descr) =
157 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
158 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
159 ptext SLIT("constructor: ") <> integer (toInteger constr),
161 pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
162 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
163 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
164 ptext SLIT("srt: ") <> ppr srt,
165 ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
166 ptext SLIT("arity: ") <> integer (toInteger arity),
167 --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed
168 ptext SLIT("slow: ") <> pprLit slow_entry
170 pprTypeInfo (ThunkInfo layout srt) =
171 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
172 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
173 ptext SLIT("srt: ") <> ppr srt]
174 pprTypeInfo (ThunkSelectorInfo offset srt) =
175 vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
176 ptext SLIT("srt: ") <> ppr srt]
177 pprTypeInfo (ContInfo stack srt) =
178 vcat [ptext SLIT("stack: ") <> ppr stack,
179 ptext SLIT("srt: ") <> ppr srt]
181 pprUpdateFrame :: UpdateFrame -> SDoc
182 pprUpdateFrame (UpdateFrame expr args) =
183 hcat [ ptext SLIT("jump")
185 , if isTrivialCmmExpr expr
188 CmmLoad (CmmReg _) _ -> pprExpr expr
189 _ -> parens (pprExpr expr)
191 , parens ( commafy $ map ppr args ) ]
194 -- --------------------------------------------------------------------------
195 -- Basic blocks look like assembly blocks.
196 -- lbl: stmt ; stmt ; ..
197 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
198 pprBBlock (BasicBlock ident stmts) =
199 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
201 -- --------------------------------------------------------------------------
202 -- Statements. C-- usually, exceptions to this should be obvious.
204 pprStmt :: CmmStmt -> SDoc
205 pprStmt stmt = case stmt of
211 CmmComment s -> text "//" <+> ftext s
214 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
217 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
219 rep = ppr ( cmmExprRep expr )
221 -- call "ccall" foo(x, y)[r1, r2];
223 CmmCall (CmmCallee fn cconv) results args safety ret ->
224 hcat [ if null results
226 else parens (commafy $ map ppr results) <>
228 ptext SLIT("call"), space,
229 doubleQuotes(ppr cconv), space,
230 target fn, parens ( commafy $ map ppr args ),
231 brackets (ppr safety),
232 case ret of CmmMayReturn -> empty
233 CmmNeverReturns -> ptext SLIT(" never returns"),
236 target (CmmLit lit) = pprLit lit
237 target fn' = parens (ppr fn')
239 CmmCall (CmmPrim op) results args safety ret ->
240 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
241 results args safety ret)
243 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
245 CmmBranch ident -> genBranch ident
246 CmmCondBranch expr ident -> genCondBranch expr ident
247 CmmJump expr params -> genJump expr params
248 CmmReturn params -> genReturn params
249 CmmSwitch arg ids -> genSwitch arg ids
251 -- --------------------------------------------------------------------------
252 -- goto local label. [1], section 6.6
256 genBranch :: BlockId -> SDoc
258 ptext SLIT("goto") <+> pprBlockId ident <> semi
260 -- --------------------------------------------------------------------------
261 -- Conditional. [1], section 6.4
263 -- if (expr) { goto lbl; }
265 genCondBranch :: CmmExpr -> BlockId -> SDoc
266 genCondBranch expr ident =
267 hsep [ ptext SLIT("if")
270 , pprBlockId ident <> semi ]
272 -- --------------------------------------------------------------------------
273 -- A tail call. [1], Section 6.9
275 -- jump foo(a, b, c);
277 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
280 hcat [ ptext SLIT("jump")
282 , if isTrivialCmmExpr expr
285 CmmLoad (CmmReg _) _ -> pprExpr expr
286 _ -> parens (pprExpr expr)
288 , parens ( commafy $ map ppr args )
291 -- --------------------------------------------------------------------------
292 -- Return from a function. [1], Section 6.8.2 of version 1.128
296 genReturn :: [(CmmExpr, MachHint)] -> SDoc
299 hcat [ ptext SLIT("return")
301 , parens ( commafy $ map ppr args )
304 -- --------------------------------------------------------------------------
305 -- Tabled jump to local label
307 -- The syntax is from [1], section 6.5
309 -- switch [0 .. n] (expr) { case ... ; }
311 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
312 genSwitch expr maybe_ids
314 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
316 in hang (hcat [ ptext SLIT("switch [0 .. ")
317 , int (length maybe_ids - 1)
319 , if isTrivialCmmExpr expr
321 else parens (pprExpr expr)
324 4 (vcat ( map caseify pairs )) $$ rbrace
327 snds a b = (snd a) == (snd b)
329 caseify :: [(Int,Maybe BlockId)] -> SDoc
330 caseify ixs@((i,Nothing):_)
331 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
334 = let (is,ids) = unzip as
335 in hsep [ ptext SLIT("case")
336 , hcat (punctuate comma (map int is))
337 , ptext SLIT(": goto")
338 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
340 -- --------------------------------------------------------------------------
344 pprExpr :: CmmExpr -> SDoc
348 pprExpr (CmmMachOp (MO_Add rep)
349 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
350 where rep = cmmRegRep reg
351 CmmLit lit -> pprLit lit
354 -- Here's the precedence table from CmmParse.y:
355 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
364 -- We just cope with the common operators for now, the rest will get
365 -- a default conservative behaviour.
367 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
368 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
369 = pprExpr7 x <+> doc <+> pprExpr7 y
370 pprExpr1 e = pprExpr7 e
372 infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
373 infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
374 infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
375 infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
376 infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
377 infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
378 infixMachOp1 (MO_U_Gt _) = Just (char '>')
379 infixMachOp1 (MO_U_Lt _) = Just (char '<')
380 infixMachOp1 _ = Nothing
383 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
384 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
385 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
386 = pprExpr7 x <+> doc <+> pprExpr8 y
387 pprExpr7 e = pprExpr8 e
389 infixMachOp7 (MO_Add _) = Just (char '+')
390 infixMachOp7 (MO_Sub _) = Just (char '-')
391 infixMachOp7 _ = Nothing
394 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
395 = pprExpr8 x <+> doc <+> pprExpr9 y
396 pprExpr8 e = pprExpr9 e
398 infixMachOp8 (MO_U_Quot _) = Just (char '/')
399 infixMachOp8 (MO_Mul _) = Just (char '*')
400 infixMachOp8 (MO_U_Rem _) = Just (char '%')
401 infixMachOp8 _ = Nothing
403 pprExpr9 :: CmmExpr -> SDoc
406 CmmLit lit -> pprLit1 lit
407 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
408 CmmReg reg -> ppr reg
409 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
410 CmmMachOp mop args -> genMachOp mop args
412 genMachOp :: MachOp -> [CmmExpr] -> SDoc
414 | Just doc <- infixMachOp mop = case args of
416 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
419 [x] -> doc <> pprExpr9 x
421 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
423 parens (hcat $ punctuate comma (map pprExpr args)))
426 | isJust (infixMachOp1 mop)
427 || isJust (infixMachOp7 mop)
428 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
430 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
431 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
433 -- replace spaces in (show mop) with underscores,
436 -- Unsigned ops on the word size of the machine get nice symbols.
437 -- All else get dumped in their ugly format.
439 infixMachOp :: MachOp -> Maybe SDoc
442 MO_And _ -> Just $ char '&'
443 MO_Or _ -> Just $ char '|'
444 MO_Xor _ -> Just $ char '^'
445 MO_Not _ -> Just $ char '~'
446 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
449 -- --------------------------------------------------------------------------
451 -- To minimise line noise we adopt the convention that if the literal
452 -- has the natural machine word size, we do not append the type
454 pprLit :: CmmLit -> SDoc
455 pprLit lit = case lit of
457 hcat [ (if i < 0 then parens else id)(integer i)
460 else space <> dcolon <+> ppr rep) ]
462 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
463 CmmLabel clbl -> pprCLabel clbl
464 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
465 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
466 <> pprCLabel clbl2 <> ppr_offset i
468 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
469 pprLit1 lit = pprLit lit
471 ppr_offset :: Int -> SDoc
474 | i>=0 = char '+' <> int i
475 | otherwise = char '-' <> int (-i)
477 -- --------------------------------------------------------------------------
479 -- Strings are printed as C strings, and we print them as I8[],
482 pprStatic :: CmmStatic -> SDoc
483 pprStatic s = case s of
484 CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
485 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
486 CmmAlign i -> nest 4 $ text "align" <+> int i
487 CmmDataLabel clbl -> pprCLabel clbl <> colon
488 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
490 -- --------------------------------------------------------------------------
491 -- Registers, whether local (temps) or global
493 pprReg :: CmmReg -> SDoc
496 CmmLocal local -> pprLocalReg local
497 CmmGlobal global -> pprGlobalReg global
500 -- We only print the type of the local reg if it isn't wordRep
502 pprLocalReg :: LocalReg -> SDoc
503 pprLocalReg (LocalReg uniq rep follow)
504 = hcat [ char '_', ppr uniq, ty ] where
505 ty = if rep == wordRep && follow == KindNonPtr
507 else dcolon <> ptr <> ppr rep
508 ptr = if follow == KindNonPtr
510 else doubleQuotes (text "ptr")
512 -- needs to be kept in syn with Cmm.hs.GlobalReg
514 pprGlobalReg :: GlobalReg -> SDoc
517 VanillaReg n -> char 'R' <> int n
518 FloatReg n -> char 'F' <> int n
519 DoubleReg n -> char 'D' <> int n
520 LongReg n -> char 'L' <> int n
521 Sp -> ptext SLIT("Sp")
522 SpLim -> ptext SLIT("SpLim")
523 Hp -> ptext SLIT("Hp")
524 HpLim -> ptext SLIT("HpLim")
525 CurrentTSO -> ptext SLIT("CurrentTSO")
526 CurrentNursery -> ptext SLIT("CurrentNursery")
527 HpAlloc -> ptext SLIT("HpAlloc")
528 GCEnter1 -> ptext SLIT("stg_gc_enter_1")
529 GCFun -> ptext SLIT("stg_gc_fun")
530 BaseReg -> ptext SLIT("BaseReg")
531 PicBaseReg -> ptext SLIT("PicBaseReg")
533 -- --------------------------------------------------------------------------
536 pprSection :: Section -> SDoc
537 pprSection s = case s of
538 Text -> section <+> doubleQuotes (ptext SLIT("text"))
539 Data -> section <+> doubleQuotes (ptext SLIT("data"))
540 ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
541 RelocatableReadOnlyData
542 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
543 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
544 OtherSection s' -> section <+> doubleQuotes (text s')
546 section = ptext SLIT("section")
548 -- --------------------------------------------------------------------------
551 pprBlockId :: BlockId -> SDoc
552 pprBlockId b = ppr $ getUnique b
554 -----------------------------------------------------------------------------
556 commafy :: [SDoc] -> SDoc
557 commafy xs = hsep $ punctuate comma xs