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
59 #include "../includes/rts/storage/FunTypes.h"
62 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
63 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
65 separator = space $$ ptext (sLit "-------------------") $$ space
67 writeCmms :: Handle -> [Cmm] -> IO ()
68 writeCmms handle cmms = printForC handle (pprCmms cmms)
70 -----------------------------------------------------------------------------
72 instance (Outputable d, Outputable info, Outputable g)
73 => Outputable (GenCmm d info g) where
76 instance (Outputable d, Outputable info, Outputable i)
77 => Outputable (GenCmmTop d info i) where
80 instance (Outputable instr) => Outputable (ListGraph instr) where
81 ppr (ListGraph blocks) = vcat (map ppr blocks)
83 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
86 instance Outputable CmmStmt where
89 instance Outputable CmmExpr where
92 instance Outputable CmmReg where
95 instance Outputable CmmLit where
98 instance Outputable LocalReg where
101 instance Outputable Area where
104 instance Outputable GlobalReg where
105 ppr e = pprGlobalReg e
107 instance Outputable CmmStatic where
110 instance Outputable CmmInfo where
115 -----------------------------------------------------------------------------
117 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
118 pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
120 -- --------------------------------------------------------------------------
121 -- Top level `procedure' blocks.
123 pprTop :: (Outputable d, Outputable info, Outputable i)
124 => GenCmmTop d info i -> SDoc
126 pprTop (CmmProc info lbl params graph )
128 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
129 , nest 8 $ lbrace <+> ppr info $$ rbrace
133 -- --------------------------------------------------------------------------
134 -- We follow [1], 4.5
136 -- section "data" { ... }
138 pprTop (CmmData section ds) =
139 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
142 -- --------------------------------------------------------------------------
143 instance Outputable CmmSafety where
144 ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
145 ppr (CmmSafe srt) = ppr srt
146 ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
148 -- --------------------------------------------------------------------------
149 -- Info tables. The current pretty printer needs refinement
150 -- but will work for now.
152 -- For ideas on how to refine it, they used to be printed in the
153 -- style of C--'s 'stackdata' declaration, just inside the proc body,
154 -- and were labelled with the procedure name ++ "_info".
155 pprInfo :: CmmInfo -> SDoc
156 pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
157 vcat [{-ptext (sLit "gc_target: ") <>
158 maybe (ptext (sLit "<none>")) ppr gc_target,-}
159 ptext (sLit "update_frame: ") <>
160 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
161 pprInfo (CmmInfo _gc_target update_frame
162 (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
163 vcat [{-ptext (sLit "gc_target: ") <>
164 maybe (ptext (sLit "<none>")) ppr gc_target,-}
165 ptext (sLit "has static closure: ") <> ppr stat_clos <+>
166 ptext (sLit "update_frame: ") <>
167 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
168 ptext (sLit "type: ") <> pprLit closure_type,
169 ptext (sLit "desc: ") <> pprLit closure_desc,
170 ptext (sLit "tag: ") <> integer (toInteger tag),
173 pprTypeInfo :: ClosureTypeInfo -> SDoc
174 pprTypeInfo (ConstrInfo layout constr descr) =
175 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
176 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
177 ptext (sLit "constructor: ") <> integer (toInteger constr),
179 pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
180 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
181 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
182 ptext (sLit "srt: ") <> ppr srt,
184 ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
186 ptext (sLit "arity: ") <> integer (toInteger arity),
187 --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
188 ptext (sLit "slow: ") <> pprLit slow_entry
190 pprTypeInfo (ThunkInfo layout srt) =
191 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
192 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
193 ptext (sLit "srt: ") <> ppr srt]
194 pprTypeInfo (ThunkSelectorInfo offset srt) =
195 vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
196 ptext (sLit "srt: ") <> ppr srt]
197 pprTypeInfo (ContInfo stack srt) =
198 vcat [ptext (sLit "stack: ") <> ppr stack,
199 ptext (sLit "srt: ") <> ppr srt]
202 argDescrType :: ArgDescr -> StgHalfWord
203 -- The "argument type" RTS field type
204 argDescrType (ArgSpec n) = n
205 argDescrType (ArgGen liveness)
206 | isBigLiveness liveness = ARG_GEN_BIG
207 | otherwise = ARG_GEN
210 isBigLiveness :: Liveness -> Bool
211 isBigLiveness (BigLiveness _) = True
212 isBigLiveness (SmallLiveness _) = False
215 pprUpdateFrame :: UpdateFrame -> SDoc
216 pprUpdateFrame (UpdateFrame expr args) =
217 hcat [ ptext (sLit "jump")
219 , if isTrivialCmmExpr expr
222 CmmLoad (CmmReg _) _ -> pprExpr expr
223 _ -> parens (pprExpr expr)
225 , parens ( commafy $ map ppr args ) ]
228 -- --------------------------------------------------------------------------
229 -- Basic blocks look like assembly blocks.
230 -- lbl: stmt ; stmt ; ..
231 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
232 pprBBlock (BasicBlock ident stmts) =
233 hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
235 -- --------------------------------------------------------------------------
236 -- Statements. C-- usually, exceptions to this should be obvious.
238 pprStmt :: CmmStmt -> SDoc
239 pprStmt stmt = case stmt of
245 CmmComment s -> text "//" <+> ftext s
248 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
251 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
253 rep = ppr ( cmmExprType expr )
255 -- call "ccall" foo(x, y)[r1, r2];
257 CmmCall (CmmCallee fn cconv) results args safety ret ->
258 sep [ pp_lhs <+> pp_conv
259 , nest 2 (pprExpr9 fn <>
260 parens (commafy (map ppr_ar args)))
261 <> brackets (ppr safety)
262 , case ret of CmmMayReturn -> empty
263 CmmNeverReturns -> ptext $ sLit (" never returns")
266 pp_lhs | null results = empty
267 | otherwise = commafy (map ppr_ar results) <+> equals
268 -- Don't print the hints on a native C-- call
270 ppr_ar :: Outputable a => CmmHinted a -> SDoc
271 ppr_ar (CmmHinted ar k) = case cconv of
272 CmmCallConv -> ppr ar
274 pp_conv = case cconv of
276 _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
278 -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
279 CmmCall (CmmPrim op) results args safety ret ->
280 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
281 results args safety ret)
283 -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
284 -- use one to get the label printed.
285 lbl = CmmLabel (mkForeignLabel
286 (mkFastString (show op))
287 Nothing ForeignLabelInThisPackage IsFunction)
289 CmmBranch ident -> genBranch ident
290 CmmCondBranch expr ident -> genCondBranch expr ident
291 CmmJump expr params -> genJump expr params
292 CmmReturn params -> genReturn params
293 CmmSwitch arg ids -> genSwitch arg ids
295 instance Outputable ForeignHint where
297 ppr SignedHint = quotes(text "signed")
298 -- ppr AddrHint = quotes(text "address")
300 ppr AddrHint = (text "PtrHint")
302 -- Just look like a tuple, since it was a tuple before
303 -- ... is that a good idea? --Isaac Dupree
304 instance (Outputable a) => Outputable (CmmHinted a) where
305 ppr (CmmHinted a k) = ppr (a, k)
307 -- --------------------------------------------------------------------------
308 -- goto local label. [1], section 6.6
312 genBranch :: BlockId -> SDoc
314 ptext (sLit "goto") <+> ppr ident <> semi
316 -- --------------------------------------------------------------------------
317 -- Conditional. [1], section 6.4
319 -- if (expr) { goto lbl; }
321 genCondBranch :: CmmExpr -> BlockId -> SDoc
322 genCondBranch expr ident =
323 hsep [ ptext (sLit "if")
325 , ptext (sLit "goto")
326 , ppr ident <> semi ]
328 -- --------------------------------------------------------------------------
329 -- A tail call. [1], Section 6.9
331 -- jump foo(a, b, c);
333 genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
335 hcat [ ptext (sLit "jump")
337 , if isTrivialCmmExpr expr
340 CmmLoad (CmmReg _) _ -> pprExpr expr
341 _ -> parens (pprExpr expr)
343 , parens ( commafy $ map ppr args )
347 -- --------------------------------------------------------------------------
348 -- Return from a function. [1], Section 6.8.2 of version 1.128
352 genReturn :: [CmmHinted CmmExpr] -> SDoc
354 hcat [ ptext (sLit "return")
356 , parens ( commafy $ map ppr args )
359 -- --------------------------------------------------------------------------
360 -- Tabled jump to local label
362 -- The syntax is from [1], section 6.5
364 -- switch [0 .. n] (expr) { case ... ; }
366 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
367 genSwitch expr maybe_ids
369 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
371 in hang (hcat [ ptext (sLit "switch [0 .. ")
372 , int (length maybe_ids - 1)
374 , if isTrivialCmmExpr expr
376 else parens (pprExpr expr)
379 4 (vcat ( map caseify pairs )) $$ rbrace
382 snds a b = (snd a) == (snd b)
384 caseify :: [(Int,Maybe BlockId)] -> SDoc
385 caseify ixs@((_,Nothing):_)
386 = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
387 <> ptext (sLit " */")
389 = let (is,ids) = unzip as
390 in hsep [ ptext (sLit "case")
391 , hcat (punctuate comma (map int is))
392 , ptext (sLit ": goto")
393 , ppr (head [ id | Just id <- ids]) <> semi ]
395 -- --------------------------------------------------------------------------
399 pprExpr :: CmmExpr -> SDoc
403 pprExpr (CmmMachOp (MO_Add rep)
404 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
405 where rep = typeWidth (cmmRegType reg)
406 CmmLit lit -> pprLit lit
409 -- Here's the precedence table from CmmParse.y:
410 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
419 -- We just cope with the common operators for now, the rest will get
420 -- a default conservative behaviour.
422 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
423 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
424 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
425 = pprExpr7 x <+> doc <+> pprExpr7 y
426 pprExpr1 e = pprExpr7 e
428 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
430 infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
431 infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
432 infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
433 infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>"))
434 infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">="))
435 infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<="))
436 infixMachOp1 (MO_U_Gt _) = Just (char '>')
437 infixMachOp1 (MO_U_Lt _) = Just (char '<')
438 infixMachOp1 _ = Nothing
441 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
442 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
443 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
444 = pprExpr7 x <+> doc <+> pprExpr8 y
445 pprExpr7 e = pprExpr8 e
447 infixMachOp7 (MO_Add _) = Just (char '+')
448 infixMachOp7 (MO_Sub _) = Just (char '-')
449 infixMachOp7 _ = Nothing
452 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
453 = pprExpr8 x <+> doc <+> pprExpr9 y
454 pprExpr8 e = pprExpr9 e
456 infixMachOp8 (MO_U_Quot _) = Just (char '/')
457 infixMachOp8 (MO_Mul _) = Just (char '*')
458 infixMachOp8 (MO_U_Rem _) = Just (char '%')
459 infixMachOp8 _ = Nothing
461 pprExpr9 :: CmmExpr -> SDoc
464 CmmLit lit -> pprLit1 lit
465 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
466 CmmReg reg -> ppr reg
467 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
468 CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
469 CmmMachOp mop args -> genMachOp mop args
471 genMachOp :: MachOp -> [CmmExpr] -> SDoc
473 | Just doc <- infixMachOp mop = case args of
475 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
478 [x] -> doc <> pprExpr9 x
480 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
482 parens (hcat $ punctuate comma (map pprExpr args)))
485 | isJust (infixMachOp1 mop)
486 || isJust (infixMachOp7 mop)
487 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
489 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
490 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
492 -- replace spaces in (show mop) with underscores,
495 -- Unsigned ops on the word size of the machine get nice symbols.
496 -- All else get dumped in their ugly format.
498 infixMachOp :: MachOp -> Maybe SDoc
501 MO_And _ -> Just $ char '&'
502 MO_Or _ -> Just $ char '|'
503 MO_Xor _ -> Just $ char '^'
504 MO_Not _ -> Just $ char '~'
505 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
508 -- --------------------------------------------------------------------------
510 -- To minimise line noise we adopt the convention that if the literal
511 -- has the natural machine word size, we do not append the type
513 pprLit :: CmmLit -> SDoc
514 pprLit lit = case lit of
516 hcat [ (if i < 0 then parens else id)(integer i)
517 , ppUnless (rep == wordWidth) $
518 space <> dcolon <+> ppr rep ]
520 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
521 CmmLabel clbl -> pprCLabel clbl
522 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
523 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
524 <> pprCLabel clbl2 <> ppr_offset i
525 CmmBlock id -> ppr id
526 CmmHighStackMark -> text "<highSp>"
528 pprLit1 :: CmmLit -> SDoc
529 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
530 pprLit1 lit = pprLit lit
532 ppr_offset :: Int -> SDoc
535 | i>=0 = char '+' <> int i
536 | otherwise = char '-' <> int (-i)
538 -- --------------------------------------------------------------------------
540 -- Strings are printed as C strings, and we print them as I8[],
543 pprStatic :: CmmStatic -> SDoc
544 pprStatic s = case s of
545 CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
546 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
547 CmmAlign i -> nest 4 $ text "align" <+> int i
548 CmmDataLabel clbl -> pprCLabel clbl <> colon
549 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
551 -- --------------------------------------------------------------------------
552 -- Registers, whether local (temps) or global
554 pprReg :: CmmReg -> SDoc
557 CmmLocal local -> pprLocalReg local
558 CmmGlobal global -> pprGlobalReg global
561 -- We only print the type of the local reg if it isn't wordRep
563 pprLocalReg :: LocalReg -> SDoc
564 pprLocalReg (LocalReg uniq rep)
565 -- = ppr rep <> char '_' <> ppr uniq
567 = char '_' <> ppr uniq <>
568 (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
569 then dcolon <> ptr <> ppr rep
570 else dcolon <> ptr <> ppr rep)
574 -- then doubleQuotes (text "ptr")
578 pprArea :: Area -> SDoc
579 pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ]
580 pprArea (CallArea id) = pprAreaId id
582 pprAreaId :: AreaId -> SDoc
583 pprAreaId Old = text "old"
584 pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
586 -- needs to be kept in syn with Cmm.hs.GlobalReg
588 pprGlobalReg :: GlobalReg -> SDoc
591 VanillaReg n _ -> char 'R' <> int n
593 -- VanillaReg n VNonGcPtr -> char 'R' <> int n
594 -- VanillaReg n VGcPtr -> char 'P' <> int n
595 FloatReg n -> char 'F' <> int n
596 DoubleReg n -> char 'D' <> int n
597 LongReg n -> char 'L' <> int n
598 Sp -> ptext (sLit "Sp")
599 SpLim -> ptext (sLit "SpLim")
600 Hp -> ptext (sLit "Hp")
601 HpLim -> ptext (sLit "HpLim")
602 CurrentTSO -> ptext (sLit "CurrentTSO")
603 CurrentNursery -> ptext (sLit "CurrentNursery")
604 HpAlloc -> ptext (sLit "HpAlloc")
605 EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
606 GCEnter1 -> ptext (sLit "stg_gc_enter_1")
607 GCFun -> ptext (sLit "stg_gc_fun")
608 BaseReg -> ptext (sLit "BaseReg")
609 PicBaseReg -> ptext (sLit "PicBaseReg")
611 -- --------------------------------------------------------------------------
614 pprSection :: Section -> SDoc
615 pprSection s = case s of
616 Text -> section <+> doubleQuotes (ptext (sLit "text"))
617 Data -> section <+> doubleQuotes (ptext (sLit "data"))
618 ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly"))
619 ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16"))
620 RelocatableReadOnlyData
621 -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
622 UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
623 OtherSection s' -> section <+> doubleQuotes (text s')
625 section = ptext (sLit "section")
627 -----------------------------------------------------------------------------
629 commafy :: [SDoc] -> SDoc
630 commafy xs = fsep $ punctuate comma xs