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 :: (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 info) => Outputable (GenCmmTop CmmStatic info CmmStmt) 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 instance Outputable CmmStatic where
92 instance Outputable CmmInfo where
95 -----------------------------------------------------------------------------
97 pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
98 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
100 -- --------------------------------------------------------------------------
101 -- Top level `procedure' blocks.
103 pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
104 pprTop (CmmProc info lbl params blocks )
106 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
107 , nest 8 $ lbrace <+> ppr info $$ rbrace
108 , nest 4 $ vcat (map ppr blocks)
111 -- --------------------------------------------------------------------------
112 -- We follow [1], 4.5
114 -- section "data" { ... }
116 pprTop (CmmData section ds) =
117 (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
120 -- --------------------------------------------------------------------------
121 instance Outputable CmmSafety where
122 ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
123 ppr (CmmSafe srt) = ppr srt
125 -- --------------------------------------------------------------------------
126 -- Info tables. The current pretty printer needs refinement
127 -- but will work for now.
129 -- For ideas on how to refine it, they used to be printed in the
130 -- style of C--'s 'stackdata' declaration, just inside the proc body,
131 -- and were labelled with the procedure name ++ "_info".
132 pprInfo (CmmNonInfo gc_target) =
133 ptext SLIT("gc_target: ") <>
134 ptext SLIT("TODO") --maybe (ptext SLIT("<none>")) pprBlockId gc_target
135 -- ^ gc_target is currently unused and wired to a panic
136 pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
137 gc_target tag info) =
138 vcat [ptext SLIT("type: ") <> pprLit closure_type,
139 ptext SLIT("desc: ") <> pprLit closure_desc,
140 ptext SLIT("gc_target: ") <>
141 ptext SLIT("TODO"), --maybe (ptext SLIT("<none>")) pprBlockId gc_target,
142 -- ^ gc_target is currently unused and wired to a panic
143 ptext SLIT("tag: ") <> integer (toInteger tag),
146 pprTypeInfo (ConstrInfo layout constr descr) =
147 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
148 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
149 ptext SLIT("constructor: ") <> integer (toInteger constr),
151 pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
152 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
153 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
154 ptext SLIT("srt: ") <> ppr srt,
155 ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
156 ptext SLIT("arity: ") <> integer (toInteger arity)
157 --ppr args, -- TODO: needs to be printed
158 --ppr slow_entry -- TODO: needs to be printed
160 pprTypeInfo (ThunkInfo layout srt) =
161 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
162 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
163 ptext SLIT("srt: ") <> ppr srt]
164 pprTypeInfo (ThunkSelectorInfo offset srt) =
165 vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
166 ptext SLIT("srt: ") <> ppr srt]
167 pprTypeInfo (ContInfo stack srt) =
168 vcat [ptext SLIT("stack: ") <> ppr stack,
169 ptext SLIT("srt: ") <> ppr srt]
171 -- --------------------------------------------------------------------------
172 -- Basic blocks look like assembly blocks.
173 -- lbl: stmt ; stmt ; ..
174 pprBBlock :: CmmBasicBlock -> SDoc
175 pprBBlock (BasicBlock ident stmts) =
176 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
178 -- --------------------------------------------------------------------------
179 -- Statements. C-- usually, exceptions to this should be obvious.
181 pprStmt :: CmmStmt -> SDoc
182 pprStmt stmt = case stmt of
188 CmmComment s -> text "//" <+> ftext s
191 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
194 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
196 rep = ppr ( cmmExprRep expr )
198 -- call "ccall" foo(x, y)[r1, r2];
200 CmmCall (CmmForeignCall fn cconv) results args safety ->
201 hcat [ if null results
203 else parens (commafy $ map ppr results) <>
205 ptext SLIT("call"), space,
206 doubleQuotes(ppr cconv), space,
207 target fn, parens ( commafy $ map ppr args ),
208 brackets (ppr safety), semi ]
210 target (CmmLit lit) = pprLit lit
211 target fn' = parens (ppr fn')
213 CmmCall (CmmPrim op) results args safety ->
214 pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
217 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
219 CmmBranch ident -> genBranch ident
220 CmmCondBranch expr ident -> genCondBranch expr ident
221 CmmJump expr params -> genJump expr params
222 CmmReturn params -> genReturn params
223 CmmSwitch arg ids -> genSwitch arg ids
225 -- --------------------------------------------------------------------------
226 -- goto local label. [1], section 6.6
230 genBranch :: BlockId -> SDoc
232 ptext SLIT("goto") <+> pprBlockId ident <> semi
234 -- --------------------------------------------------------------------------
235 -- Conditional. [1], section 6.4
237 -- if (expr) { goto lbl; }
239 genCondBranch :: CmmExpr -> BlockId -> SDoc
240 genCondBranch expr ident =
241 hsep [ ptext SLIT("if")
244 , pprBlockId ident <> semi ]
246 -- --------------------------------------------------------------------------
247 -- A tail call. [1], Section 6.9
249 -- jump foo(a, b, c);
251 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
254 hcat [ ptext SLIT("jump")
256 , if isTrivialCmmExpr expr
259 CmmLoad (CmmReg _) _ -> pprExpr expr
260 _ -> parens (pprExpr expr)
262 , parens ( commafy $ map ppr args )
265 -- --------------------------------------------------------------------------
266 -- Return from a function. [1], Section 6.8.2 of version 1.128
270 genReturn :: [(CmmExpr, MachHint)] -> SDoc
273 hcat [ ptext SLIT("return")
275 , parens ( commafy $ map ppr args )
278 -- --------------------------------------------------------------------------
279 -- Tabled jump to local label
281 -- The syntax is from [1], section 6.5
283 -- switch [0 .. n] (expr) { case ... ; }
285 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
286 genSwitch expr maybe_ids
288 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
290 in hang (hcat [ ptext SLIT("switch [0 .. ")
291 , int (length maybe_ids - 1)
293 , if isTrivialCmmExpr expr
295 else parens (pprExpr expr)
298 4 (vcat ( map caseify pairs )) $$ rbrace
301 snds a b = (snd a) == (snd b)
303 caseify :: [(Int,Maybe BlockId)] -> SDoc
304 caseify ixs@((i,Nothing):_)
305 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
308 = let (is,ids) = unzip as
309 in hsep [ ptext SLIT("case")
310 , hcat (punctuate comma (map int is))
311 , ptext SLIT(": goto")
312 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
314 -- --------------------------------------------------------------------------
318 pprExpr :: CmmExpr -> SDoc
322 pprExpr (CmmMachOp (MO_Add rep)
323 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
324 where rep = cmmRegRep reg
325 CmmLit lit -> pprLit lit
328 -- Here's the precedence table from CmmParse.y:
329 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
338 -- We just cope with the common operators for now, the rest will get
339 -- a default conservative behaviour.
341 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
342 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
343 = pprExpr7 x <+> doc <+> pprExpr7 y
344 pprExpr1 e = pprExpr7 e
346 infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
347 infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
348 infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
349 infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
350 infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
351 infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
352 infixMachOp1 (MO_U_Gt _) = Just (char '>')
353 infixMachOp1 (MO_U_Lt _) = Just (char '<')
354 infixMachOp1 _ = Nothing
357 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
358 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
359 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
360 = pprExpr7 x <+> doc <+> pprExpr8 y
361 pprExpr7 e = pprExpr8 e
363 infixMachOp7 (MO_Add _) = Just (char '+')
364 infixMachOp7 (MO_Sub _) = Just (char '-')
365 infixMachOp7 _ = Nothing
368 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
369 = pprExpr8 x <+> doc <+> pprExpr9 y
370 pprExpr8 e = pprExpr9 e
372 infixMachOp8 (MO_U_Quot _) = Just (char '/')
373 infixMachOp8 (MO_Mul _) = Just (char '*')
374 infixMachOp8 (MO_U_Rem _) = Just (char '%')
375 infixMachOp8 _ = Nothing
377 pprExpr9 :: CmmExpr -> SDoc
380 CmmLit lit -> pprLit1 lit
381 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
382 CmmReg reg -> ppr reg
383 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
384 CmmMachOp mop args -> genMachOp mop args
386 genMachOp :: MachOp -> [CmmExpr] -> SDoc
388 | Just doc <- infixMachOp mop = case args of
390 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
393 [x] -> doc <> pprExpr9 x
395 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
397 parens (hcat $ punctuate comma (map pprExpr args)))
400 | isJust (infixMachOp1 mop)
401 || isJust (infixMachOp7 mop)
402 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
404 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
405 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
407 -- replace spaces in (show mop) with underscores,
410 -- Unsigned ops on the word size of the machine get nice symbols.
411 -- All else get dumped in their ugly format.
413 infixMachOp :: MachOp -> Maybe SDoc
416 MO_And _ -> Just $ char '&'
417 MO_Or _ -> Just $ char '|'
418 MO_Xor _ -> Just $ char '^'
419 MO_Not _ -> Just $ char '~'
420 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
423 -- --------------------------------------------------------------------------
425 -- To minimise line noise we adopt the convention that if the literal
426 -- has the natural machine word size, we do not append the type
428 pprLit :: CmmLit -> SDoc
429 pprLit lit = case lit of
431 hcat [ (if i < 0 then parens else id)(integer i)
434 else space <> dcolon <+> ppr rep) ]
436 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
437 CmmLabel clbl -> pprCLabel clbl
438 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
439 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
440 <> pprCLabel clbl2 <> ppr_offset i
442 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
443 pprLit1 lit = pprLit lit
445 ppr_offset :: Int -> SDoc
448 | i>=0 = char '+' <> int i
449 | otherwise = char '-' <> int (-i)
451 -- --------------------------------------------------------------------------
453 -- Strings are printed as C strings, and we print them as I8[],
456 pprStatic :: CmmStatic -> SDoc
457 pprStatic s = case s of
458 CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
459 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
460 CmmAlign i -> nest 4 $ text "align" <+> int i
461 CmmDataLabel clbl -> pprCLabel clbl <> colon
462 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
464 -- --------------------------------------------------------------------------
465 -- Registers, whether local (temps) or global
467 pprReg :: CmmReg -> SDoc
470 CmmLocal local -> pprLocalReg local
471 CmmGlobal global -> pprGlobalReg global
474 -- We only print the type of the local reg if it isn't wordRep
476 pprLocalReg :: LocalReg -> SDoc
477 pprLocalReg (LocalReg uniq rep follow)
478 = hcat [ char '_', ppr uniq, ty ] where
479 ty = if rep == wordRep && follow == KindNonPtr
481 else dcolon <> ptr <> ppr rep
482 ptr = if follow == KindNonPtr
484 else doubleQuotes (text "ptr")
486 -- needs to be kept in syn with Cmm.hs.GlobalReg
488 pprGlobalReg :: GlobalReg -> SDoc
491 VanillaReg n -> char 'R' <> int n
492 FloatReg n -> char 'F' <> int n
493 DoubleReg n -> char 'D' <> int n
494 LongReg n -> char 'L' <> int n
495 Sp -> ptext SLIT("Sp")
496 SpLim -> ptext SLIT("SpLim")
497 Hp -> ptext SLIT("Hp")
498 HpLim -> ptext SLIT("HpLim")
499 CurrentTSO -> ptext SLIT("CurrentTSO")
500 CurrentNursery -> ptext SLIT("CurrentNursery")
501 HpAlloc -> ptext SLIT("HpAlloc")
502 GCEnter1 -> ptext SLIT("stg_gc_enter_1")
503 GCFun -> ptext SLIT("stg_gc_fun")
504 BaseReg -> ptext SLIT("BaseReg")
505 PicBaseReg -> ptext SLIT("PicBaseReg")
507 -- --------------------------------------------------------------------------
510 pprSection :: Section -> SDoc
511 pprSection s = case s of
512 Text -> section <+> doubleQuotes (ptext SLIT("text"))
513 Data -> section <+> doubleQuotes (ptext SLIT("data"))
514 ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
515 RelocatableReadOnlyData
516 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
517 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
518 OtherSection s' -> section <+> doubleQuotes (text s')
520 section = ptext SLIT("section")
522 -- --------------------------------------------------------------------------
525 pprBlockId :: BlockId -> SDoc
526 pprBlockId b = ppr $ getUnique b
528 -----------------------------------------------------------------------------
530 commafy :: [SDoc] -> SDoc
531 commafy xs = hsep $ punctuate comma xs