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,
37 pprSection, pprStatic, pprLit
58 #include "../includes/StgFun.h"
61 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
62 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
64 separator = space $$ ptext (sLit "-------------------") $$ space
66 writeCmms :: Handle -> [Cmm] -> IO ()
67 writeCmms handle cmms = printForC handle (pprCmms cmms)
69 -----------------------------------------------------------------------------
71 instance (Outputable d, Outputable info, Outputable g)
72 => Outputable (GenCmm d info g) where
75 instance (Outputable d, Outputable info, Outputable i)
76 => Outputable (GenCmmTop d info i) where
79 instance (Outputable instr) => Outputable (ListGraph instr) where
80 ppr (ListGraph blocks) = vcat (map ppr blocks)
82 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
85 instance Outputable CmmStmt where
88 instance Outputable CmmExpr where
91 instance Outputable CmmReg where
94 instance Outputable CmmLit where
97 instance Outputable LocalReg where
100 instance Outputable Area where
103 instance Outputable GlobalReg where
104 ppr e = pprGlobalReg e
106 instance Outputable CmmStatic where
109 instance Outputable CmmInfo where
114 -----------------------------------------------------------------------------
116 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
117 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
119 -- --------------------------------------------------------------------------
120 -- Top level `procedure' blocks.
122 pprTop :: (Outputable d, Outputable info, Outputable i)
123 => GenCmmTop d info i -> SDoc
125 pprTop (CmmProc info lbl params graph )
127 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
128 , nest 8 $ lbrace <+> ppr info $$ rbrace
132 -- --------------------------------------------------------------------------
133 -- We follow [1], 4.5
135 -- section "data" { ... }
137 pprTop (CmmData section ds) =
138 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
141 -- --------------------------------------------------------------------------
142 instance Outputable CmmSafety where
143 ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
144 ppr (CmmSafe srt) = ppr srt
146 -- --------------------------------------------------------------------------
147 -- Info tables. The current pretty printer needs refinement
148 -- but will work for now.
150 -- For ideas on how to refine it, they used to be printed in the
151 -- style of C--'s 'stackdata' declaration, just inside the proc body,
152 -- and were labelled with the procedure name ++ "_info".
153 pprInfo :: CmmInfo -> SDoc
154 pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
155 vcat [{-ptext (sLit "gc_target: ") <>
156 maybe (ptext (sLit "<none>")) ppr gc_target,-}
157 ptext (sLit "update_frame: ") <>
158 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
159 pprInfo (CmmInfo _gc_target update_frame
160 (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
161 vcat [{-ptext (sLit "gc_target: ") <>
162 maybe (ptext (sLit "<none>")) ppr gc_target,-}
163 ptext (sLit "has static closure: ") <> ppr stat_clos <+>
164 ptext (sLit "update_frame: ") <>
165 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
166 ptext (sLit "type: ") <> pprLit closure_type,
167 ptext (sLit "desc: ") <> pprLit closure_desc,
168 ptext (sLit "tag: ") <> integer (toInteger tag),
171 pprTypeInfo :: ClosureTypeInfo -> SDoc
172 pprTypeInfo (ConstrInfo layout constr descr) =
173 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
174 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
175 ptext (sLit "constructor: ") <> integer (toInteger constr),
177 pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
178 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
179 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
180 ptext (sLit "srt: ") <> ppr srt,
182 ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
184 ptext (sLit "arity: ") <> integer (toInteger arity),
185 --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
186 ptext (sLit "slow: ") <> pprLit slow_entry
188 pprTypeInfo (ThunkInfo layout srt) =
189 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
190 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
191 ptext (sLit "srt: ") <> ppr srt]
192 pprTypeInfo (ThunkSelectorInfo offset srt) =
193 vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
194 ptext (sLit "srt: ") <> ppr srt]
195 pprTypeInfo (ContInfo stack srt) =
196 vcat [ptext (sLit "stack: ") <> ppr stack,
197 ptext (sLit "srt: ") <> ppr srt]
200 argDescrType :: ArgDescr -> StgHalfWord
201 -- The "argument type" RTS field type
202 argDescrType (ArgSpec n) = n
203 argDescrType (ArgGen liveness)
204 | isBigLiveness liveness = ARG_GEN_BIG
205 | otherwise = ARG_GEN
208 isBigLiveness :: Liveness -> Bool
209 isBigLiveness (BigLiveness _) = True
210 isBigLiveness (SmallLiveness _) = False
213 pprUpdateFrame :: UpdateFrame -> SDoc
214 pprUpdateFrame (UpdateFrame expr args) =
215 hcat [ ptext (sLit "jump")
217 , if isTrivialCmmExpr expr
220 CmmLoad (CmmReg _) _ -> pprExpr expr
221 _ -> parens (pprExpr expr)
223 , parens ( commafy $ map ppr args ) ]
226 -- --------------------------------------------------------------------------
227 -- Basic blocks look like assembly blocks.
228 -- lbl: stmt ; stmt ; ..
229 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
230 pprBBlock (BasicBlock ident stmts) =
231 hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
233 -- --------------------------------------------------------------------------
234 -- Statements. C-- usually, exceptions to this should be obvious.
236 pprStmt :: CmmStmt -> SDoc
237 pprStmt stmt = case stmt of
243 CmmComment s -> text "//" <+> ftext s
246 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
249 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
251 rep = ppr ( cmmExprType expr )
253 -- call "ccall" foo(x, y)[r1, r2];
255 CmmCall (CmmCallee fn cconv) results args safety ret ->
256 sep [ pp_lhs <+> pp_conv
257 , nest 2 (pprExpr9 fn <>
258 parens (commafy (map ppr_ar args)))
259 <> brackets (ppr safety)
260 , case ret of CmmMayReturn -> empty
261 CmmNeverReturns -> ptext $ sLit (" never returns")
264 pp_lhs | null results = empty
265 | otherwise = commafy (map ppr_ar results) <+> equals
266 -- Don't print the hints on a native C-- call
267 ppr_ar (CmmHinted ar k) = case cconv of
268 CmmCallConv -> ppr ar
270 pp_conv = case cconv of
272 _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
274 CmmCall (CmmPrim op) results args safety ret ->
275 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
276 results args safety ret)
278 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
280 CmmBranch ident -> genBranch ident
281 CmmCondBranch expr ident -> genCondBranch expr ident
282 CmmJump expr params -> genJump expr params
283 CmmReturn params -> genReturn params
284 CmmSwitch arg ids -> genSwitch arg ids
286 instance Outputable ForeignHint where
288 ppr SignedHint = quotes(text "signed")
289 -- ppr AddrHint = quotes(text "address")
291 ppr AddrHint = (text "PtrHint")
293 -- Just look like a tuple, since it was a tuple before
294 -- ... is that a good idea? --Isaac Dupree
295 instance (Outputable a) => Outputable (CmmHinted a) where
296 ppr (CmmHinted a k) = ppr (a, k)
298 -- --------------------------------------------------------------------------
299 -- goto local label. [1], section 6.6
303 genBranch :: BlockId -> SDoc
305 ptext (sLit "goto") <+> ppr ident <> semi
307 -- --------------------------------------------------------------------------
308 -- Conditional. [1], section 6.4
310 -- if (expr) { goto lbl; }
312 genCondBranch :: CmmExpr -> BlockId -> SDoc
313 genCondBranch expr ident =
314 hsep [ ptext (sLit "if")
316 , ptext (sLit "goto")
317 , ppr ident <> semi ]
319 -- --------------------------------------------------------------------------
320 -- A tail call. [1], Section 6.9
322 -- jump foo(a, b, c);
324 genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
326 hcat [ ptext (sLit "jump")
328 , if isTrivialCmmExpr expr
331 CmmLoad (CmmReg _) _ -> pprExpr expr
332 _ -> parens (pprExpr expr)
334 , parens ( commafy $ map ppr args )
338 -- --------------------------------------------------------------------------
339 -- Return from a function. [1], Section 6.8.2 of version 1.128
343 genReturn :: [CmmHinted CmmExpr] -> SDoc
345 hcat [ ptext (sLit "return")
347 , parens ( commafy $ map ppr args )
350 -- --------------------------------------------------------------------------
351 -- Tabled jump to local label
353 -- The syntax is from [1], section 6.5
355 -- switch [0 .. n] (expr) { case ... ; }
357 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
358 genSwitch expr maybe_ids
360 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
362 in hang (hcat [ ptext (sLit "switch [0 .. ")
363 , int (length maybe_ids - 1)
365 , if isTrivialCmmExpr expr
367 else parens (pprExpr expr)
370 4 (vcat ( map caseify pairs )) $$ rbrace
373 snds a b = (snd a) == (snd b)
375 caseify :: [(Int,Maybe BlockId)] -> SDoc
376 caseify ixs@((_,Nothing):_)
377 = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
378 <> ptext (sLit " */")
380 = let (is,ids) = unzip as
381 in hsep [ ptext (sLit "case")
382 , hcat (punctuate comma (map int is))
383 , ptext (sLit ": goto")
384 , ppr (head [ id | Just id <- ids]) <> semi ]
386 -- --------------------------------------------------------------------------
390 pprExpr :: CmmExpr -> SDoc
394 pprExpr (CmmMachOp (MO_Add rep)
395 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
396 where rep = typeWidth (cmmRegType reg)
397 CmmLit lit -> pprLit lit
400 -- Here's the precedence table from CmmParse.y:
401 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
410 -- We just cope with the common operators for now, the rest will get
411 -- a default conservative behaviour.
413 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
414 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
415 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
416 = pprExpr7 x <+> doc <+> pprExpr7 y
417 pprExpr1 e = pprExpr7 e
419 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
421 infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
422 infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
423 infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
424 infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>"))
425 infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">="))
426 infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<="))
427 infixMachOp1 (MO_U_Gt _) = Just (char '>')
428 infixMachOp1 (MO_U_Lt _) = Just (char '<')
429 infixMachOp1 _ = Nothing
432 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
433 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
434 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
435 = pprExpr7 x <+> doc <+> pprExpr8 y
436 pprExpr7 e = pprExpr8 e
438 infixMachOp7 (MO_Add _) = Just (char '+')
439 infixMachOp7 (MO_Sub _) = Just (char '-')
440 infixMachOp7 _ = Nothing
443 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
444 = pprExpr8 x <+> doc <+> pprExpr9 y
445 pprExpr8 e = pprExpr9 e
447 infixMachOp8 (MO_U_Quot _) = Just (char '/')
448 infixMachOp8 (MO_Mul _) = Just (char '*')
449 infixMachOp8 (MO_U_Rem _) = Just (char '%')
450 infixMachOp8 _ = Nothing
452 pprExpr9 :: CmmExpr -> SDoc
455 CmmLit lit -> pprLit1 lit
456 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
457 CmmReg reg -> ppr reg
458 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
459 CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
460 CmmMachOp mop args -> genMachOp mop args
462 genMachOp :: MachOp -> [CmmExpr] -> SDoc
464 | Just doc <- infixMachOp mop = case args of
466 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
469 [x] -> doc <> pprExpr9 x
471 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
473 parens (hcat $ punctuate comma (map pprExpr args)))
476 | isJust (infixMachOp1 mop)
477 || isJust (infixMachOp7 mop)
478 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
480 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
481 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
483 -- replace spaces in (show mop) with underscores,
486 -- Unsigned ops on the word size of the machine get nice symbols.
487 -- All else get dumped in their ugly format.
489 infixMachOp :: MachOp -> Maybe SDoc
492 MO_And _ -> Just $ char '&'
493 MO_Or _ -> Just $ char '|'
494 MO_Xor _ -> Just $ char '^'
495 MO_Not _ -> Just $ char '~'
496 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
499 -- --------------------------------------------------------------------------
501 -- To minimise line noise we adopt the convention that if the literal
502 -- has the natural machine word size, we do not append the type
504 pprLit :: CmmLit -> SDoc
505 pprLit lit = case lit of
507 hcat [ (if i < 0 then parens else id)(integer i)
508 , (if rep == wordWidth
510 else space <> dcolon <+> ppr rep) ]
512 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
513 CmmLabel clbl -> pprCLabel clbl
514 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
515 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
516 <> pprCLabel clbl2 <> ppr_offset i
517 CmmBlock id -> ppr id
518 CmmHighStackMark -> text "<highSp>"
520 pprLit1 :: CmmLit -> SDoc
521 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
522 pprLit1 lit = pprLit lit
524 ppr_offset :: Int -> SDoc
527 | i>=0 = char '+' <> int i
528 | otherwise = char '-' <> int (-i)
530 -- --------------------------------------------------------------------------
532 -- Strings are printed as C strings, and we print them as I8[],
535 pprStatic :: CmmStatic -> SDoc
536 pprStatic s = case s of
537 CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
538 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
539 CmmAlign i -> nest 4 $ text "align" <+> int i
540 CmmDataLabel clbl -> pprCLabel clbl <> colon
541 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
543 -- --------------------------------------------------------------------------
544 -- Registers, whether local (temps) or global
546 pprReg :: CmmReg -> SDoc
549 CmmLocal local -> pprLocalReg local
550 CmmGlobal global -> pprGlobalReg global
553 -- We only print the type of the local reg if it isn't wordRep
555 pprLocalReg :: LocalReg -> SDoc
556 pprLocalReg (LocalReg uniq rep)
557 -- = ppr rep <> char '_' <> ppr uniq
559 = char '_' <> ppr uniq <>
560 (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
561 then dcolon <> ptr <> ppr rep
562 else dcolon <> ptr <> ppr rep)
566 -- then doubleQuotes (text "ptr")
570 pprArea :: Area -> SDoc
571 pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ]
572 pprArea (CallArea id) = pprAreaId id
574 pprAreaId :: AreaId -> SDoc
575 pprAreaId Old = text "old"
576 pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
578 -- needs to be kept in syn with Cmm.hs.GlobalReg
580 pprGlobalReg :: GlobalReg -> SDoc
583 VanillaReg n _ -> char 'R' <> int n
585 -- VanillaReg n VNonGcPtr -> char 'R' <> int n
586 -- VanillaReg n VGcPtr -> char 'P' <> int n
587 FloatReg n -> char 'F' <> int n
588 DoubleReg n -> char 'D' <> int n
589 LongReg n -> char 'L' <> int n
590 Sp -> ptext (sLit "Sp")
591 SpLim -> ptext (sLit "SpLim")
592 Hp -> ptext (sLit "Hp")
593 HpLim -> ptext (sLit "HpLim")
594 CurrentTSO -> ptext (sLit "CurrentTSO")
595 CurrentNursery -> ptext (sLit "CurrentNursery")
596 HpAlloc -> ptext (sLit "HpAlloc")
597 EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
598 GCEnter1 -> ptext (sLit "stg_gc_enter_1")
599 GCFun -> ptext (sLit "stg_gc_fun")
600 BaseReg -> ptext (sLit "BaseReg")
601 PicBaseReg -> ptext (sLit "PicBaseReg")
603 -- --------------------------------------------------------------------------
606 pprSection :: Section -> SDoc
607 pprSection s = case s of
608 Text -> section <+> doubleQuotes (ptext (sLit "text"))
609 Data -> section <+> doubleQuotes (ptext (sLit "data"))
610 ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly"))
611 ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16"))
612 RelocatableReadOnlyData
613 -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
614 UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
615 OtherSection s' -> section <+> doubleQuotes (text s')
617 section = ptext (sLit "section")
619 -----------------------------------------------------------------------------
621 commafy :: [SDoc] -> SDoc
622 commafy xs = fsep $ punctuate comma xs