2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
8 ----------------------------------------------------------------------------
10 -- Pretty-printing of Cmm as (a superset of) C--
12 -- (c) The University of Glasgow 2004-2006
14 -----------------------------------------------------------------------------
17 -- This is where we walk over Cmm emitting an external representation,
18 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
19 -- is the "External Core" for the Cmm layer.
21 -- As such, this should be a well-defined syntax: we want it to look nice.
22 -- Thus, we try wherever possible to use syntax defined in [1],
23 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
24 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
25 -- than C--'s bits8 .. bits64.
27 -- We try to ensure that all information available in the abstract
28 -- syntax is reproduced, or reproducible, in the concrete syntax.
29 -- Data that is not in printed out can be reconstructed according to
30 -- conventions used in the pretty printer. There are at least two such
32 -- 1) if a value has wordRep type, the type is not appended in the
34 -- 2) MachOps that operate over wordRep type are printed in a
35 -- C-style, rather than as their internal MachRep name.
37 -- These conventions produce much more readable Cmm output.
39 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
43 ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic, pprLit
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 LocalReg where
98 instance Outputable GlobalReg where
99 ppr e = pprGlobalReg e
101 instance Outputable CmmStatic where
104 instance Outputable CmmInfo where
109 -----------------------------------------------------------------------------
111 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
112 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
114 -- --------------------------------------------------------------------------
115 -- Top level `procedure' blocks.
117 pprTop :: (Outputable d, Outputable info, Outputable i)
118 => GenCmmTop d info i -> SDoc
120 pprTop (CmmProc info lbl params graph )
122 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
123 , nest 8 $ lbrace <+> ppr info $$ rbrace
127 -- --------------------------------------------------------------------------
128 -- We follow [1], 4.5
130 -- section "data" { ... }
132 pprTop (CmmData section ds) =
133 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
136 -- --------------------------------------------------------------------------
137 instance Outputable CmmSafety where
138 ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
139 ppr (CmmSafe srt) = ppr srt
141 -- --------------------------------------------------------------------------
142 -- Info tables. The current pretty printer needs refinement
143 -- but will work for now.
145 -- For ideas on how to refine it, they used to be printed in the
146 -- style of C--'s 'stackdata' declaration, just inside the proc body,
147 -- and were labelled with the procedure name ++ "_info".
148 pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) =
149 vcat [{-ptext (sLit "gc_target: ") <>
150 maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
151 ptext (sLit "update_frame: ") <>
152 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
153 pprInfo (CmmInfo gc_target update_frame
154 (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
155 vcat [{-ptext (sLit "gc_target: ") <>
156 maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
157 ptext (sLit "update_frame: ") <>
158 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
159 ptext (sLit "type: ") <> pprLit closure_type,
160 ptext (sLit "desc: ") <> pprLit closure_desc,
161 ptext (sLit "tag: ") <> integer (toInteger tag),
164 pprTypeInfo (ConstrInfo layout constr descr) =
165 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
166 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
167 ptext (sLit "constructor: ") <> integer (toInteger constr),
169 pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
170 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
171 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
172 ptext (sLit "srt: ") <> ppr srt,
173 ptext (sLit "fun_type: ") <> integer (toInteger fun_type),
174 ptext (sLit "arity: ") <> integer (toInteger arity),
175 --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
176 ptext (sLit "slow: ") <> pprLit slow_entry
178 pprTypeInfo (ThunkInfo layout srt) =
179 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
180 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
181 ptext (sLit "srt: ") <> ppr srt]
182 pprTypeInfo (ThunkSelectorInfo offset srt) =
183 vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
184 ptext (sLit "srt: ") <> ppr srt]
185 pprTypeInfo (ContInfo stack srt) =
186 vcat [ptext (sLit "stack: ") <> ppr stack,
187 ptext (sLit "srt: ") <> ppr srt]
189 pprUpdateFrame :: UpdateFrame -> SDoc
190 pprUpdateFrame (UpdateFrame expr args) =
191 hcat [ ptext (sLit "jump")
193 , if isTrivialCmmExpr expr
196 CmmLoad (CmmReg _) _ -> pprExpr expr
197 _ -> parens (pprExpr expr)
199 , parens ( commafy $ map ppr args ) ]
202 -- --------------------------------------------------------------------------
203 -- Basic blocks look like assembly blocks.
204 -- lbl: stmt ; stmt ; ..
205 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
206 pprBBlock (BasicBlock ident stmts) =
207 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
209 -- --------------------------------------------------------------------------
210 -- Statements. C-- usually, exceptions to this should be obvious.
212 pprStmt :: CmmStmt -> SDoc
213 pprStmt stmt = case stmt of
219 CmmComment s -> text "//" <+> ftext s
222 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
225 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
227 rep = ppr ( cmmExprRep expr )
229 -- call "ccall" foo(x, y)[r1, r2];
231 CmmCall (CmmCallee fn cconv) results args safety ret ->
232 hcat [ if null results
234 else parens (commafy $ map ppr results) <>
236 ptext (sLit "foreign"), space,
237 doubleQuotes(ppr cconv), space,
238 target fn, parens ( commafy $ map ppr args ),
239 brackets (ppr safety),
240 case ret of CmmMayReturn -> empty
241 CmmNeverReturns -> ptext (sLit " never returns"),
244 target (CmmLit lit) = pprLit lit
245 target fn' = parens (ppr fn')
247 CmmCall (CmmPrim op) results args safety ret ->
248 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
249 results args safety ret)
251 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
253 CmmBranch ident -> genBranch ident
254 CmmCondBranch expr ident -> genCondBranch expr ident
255 CmmJump expr params -> genJump expr params
256 CmmReturn params -> genReturn params
257 CmmSwitch arg ids -> genSwitch arg ids
259 -- --------------------------------------------------------------------------
260 -- goto local label. [1], section 6.6
264 genBranch :: BlockId -> SDoc
266 ptext (sLit "goto") <+> pprBlockId ident <> semi
268 -- --------------------------------------------------------------------------
269 -- Conditional. [1], section 6.4
271 -- if (expr) { goto lbl; }
273 genCondBranch :: CmmExpr -> BlockId -> SDoc
274 genCondBranch expr ident =
275 hsep [ ptext (sLit "if")
277 , ptext (sLit "goto")
278 , pprBlockId ident <> semi ]
280 -- --------------------------------------------------------------------------
281 -- A tail call. [1], Section 6.9
283 -- jump foo(a, b, c);
285 genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
288 hcat [ ptext (sLit "jump")
290 , if isTrivialCmmExpr expr
293 CmmLoad (CmmReg _) _ -> pprExpr expr
294 _ -> parens (pprExpr expr)
296 , parens ( commafy $ map pprHinted args )
299 pprHinted :: Outputable a => (CmmHinted a) -> SDoc
300 pprHinted (CmmHinted a NoHint) = ppr a
301 pprHinted (CmmHinted a PtrHint) = quotes(text "address") <+> ppr a
302 pprHinted (CmmHinted a SignedHint) = quotes(text "signed") <+> ppr a
303 pprHinted (CmmHinted a FloatHint) = quotes(text "float") <+> ppr a
305 -- --------------------------------------------------------------------------
306 -- Return from a function. [1], Section 6.8.2 of version 1.128
310 genReturn :: [CmmHinted CmmExpr] -> SDoc
313 hcat [ ptext (sLit "return")
315 , parens ( commafy $ map ppr args )
318 -- --------------------------------------------------------------------------
319 -- Tabled jump to local label
321 -- The syntax is from [1], section 6.5
323 -- switch [0 .. n] (expr) { case ... ; }
325 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
326 genSwitch expr maybe_ids
328 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
330 in hang (hcat [ ptext (sLit "switch [0 .. ")
331 , int (length maybe_ids - 1)
333 , if isTrivialCmmExpr expr
335 else parens (pprExpr expr)
338 4 (vcat ( map caseify pairs )) $$ rbrace
341 snds a b = (snd a) == (snd b)
343 caseify :: [(Int,Maybe BlockId)] -> SDoc
344 caseify ixs@((i,Nothing):_)
345 = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
346 <> ptext (sLit " */")
348 = let (is,ids) = unzip as
349 in hsep [ ptext (sLit "case")
350 , hcat (punctuate comma (map int is))
351 , ptext (sLit ": goto")
352 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
354 -- --------------------------------------------------------------------------
358 pprExpr :: CmmExpr -> SDoc
362 pprExpr (CmmMachOp (MO_Add rep)
363 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
364 where rep = cmmRegRep reg
365 CmmLit lit -> pprLit lit
368 -- Here's the precedence table from CmmParse.y:
369 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
378 -- We just cope with the common operators for now, the rest will get
379 -- a default conservative behaviour.
381 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
382 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
383 = pprExpr7 x <+> doc <+> pprExpr7 y
384 pprExpr1 e = pprExpr7 e
386 infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
387 infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
388 infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
389 infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>"))
390 infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">="))
391 infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<="))
392 infixMachOp1 (MO_U_Gt _) = Just (char '>')
393 infixMachOp1 (MO_U_Lt _) = Just (char '<')
394 infixMachOp1 _ = Nothing
397 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
398 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
399 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
400 = pprExpr7 x <+> doc <+> pprExpr8 y
401 pprExpr7 e = pprExpr8 e
403 infixMachOp7 (MO_Add _) = Just (char '+')
404 infixMachOp7 (MO_Sub _) = Just (char '-')
405 infixMachOp7 _ = Nothing
408 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
409 = pprExpr8 x <+> doc <+> pprExpr9 y
410 pprExpr8 e = pprExpr9 e
412 infixMachOp8 (MO_U_Quot _) = Just (char '/')
413 infixMachOp8 (MO_Mul _) = Just (char '*')
414 infixMachOp8 (MO_U_Rem _) = Just (char '%')
415 infixMachOp8 _ = Nothing
417 pprExpr9 :: CmmExpr -> SDoc
420 CmmLit lit -> pprLit1 lit
421 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
422 CmmReg reg -> ppr reg
423 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
424 CmmMachOp mop args -> genMachOp mop args
426 genMachOp :: MachOp -> [CmmExpr] -> SDoc
428 | Just doc <- infixMachOp mop = case args of
430 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
433 [x] -> doc <> pprExpr9 x
435 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
437 parens (hcat $ punctuate comma (map pprExpr args)))
440 | isJust (infixMachOp1 mop)
441 || isJust (infixMachOp7 mop)
442 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
444 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
445 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
447 -- replace spaces in (show mop) with underscores,
450 -- Unsigned ops on the word size of the machine get nice symbols.
451 -- All else get dumped in their ugly format.
453 infixMachOp :: MachOp -> Maybe SDoc
456 MO_And _ -> Just $ char '&'
457 MO_Or _ -> Just $ char '|'
458 MO_Xor _ -> Just $ char '^'
459 MO_Not _ -> Just $ char '~'
460 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
463 -- --------------------------------------------------------------------------
465 -- To minimise line noise we adopt the convention that if the literal
466 -- has the natural machine word size, we do not append the type
468 pprLit :: CmmLit -> SDoc
469 pprLit lit = case lit of
471 hcat [ (if i < 0 then parens else id)(integer i)
474 else space <> dcolon <+> ppr rep) ]
476 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
477 CmmLabel clbl -> pprCLabel clbl
478 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
479 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
480 <> pprCLabel clbl2 <> ppr_offset i
482 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
483 pprLit1 lit = pprLit lit
485 ppr_offset :: Int -> SDoc
488 | i>=0 = char '+' <> int i
489 | otherwise = char '-' <> int (-i)
491 -- --------------------------------------------------------------------------
493 -- Strings are printed as C strings, and we print them as I8[],
496 pprStatic :: CmmStatic -> SDoc
497 pprStatic s = case s of
498 CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
499 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
500 CmmAlign i -> nest 4 $ text "align" <+> int i
501 CmmDataLabel clbl -> pprCLabel clbl <> colon
502 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
504 -- --------------------------------------------------------------------------
505 -- Registers, whether local (temps) or global
507 pprReg :: CmmReg -> SDoc
510 CmmLocal local -> pprLocalReg local
511 CmmGlobal global -> pprGlobalReg global
514 -- We only print the type of the local reg if it isn't wordRep
516 pprLocalReg :: LocalReg -> SDoc
517 pprLocalReg (LocalReg uniq rep follow)
518 = hcat [ char '_', ppr uniq, ty ] where
519 ty = if rep == wordRep && follow == GCKindNonPtr
521 else dcolon <> ptr <> ppr rep
522 ptr = if follow == GCKindNonPtr
524 else doubleQuotes (text "ptr")
526 -- needs to be kept in syn with Cmm.hs.GlobalReg
528 pprGlobalReg :: GlobalReg -> SDoc
531 VanillaReg n -> char 'R' <> int n
532 FloatReg n -> char 'F' <> int n
533 DoubleReg n -> char 'D' <> int n
534 LongReg n -> char 'L' <> int n
535 Sp -> ptext (sLit "Sp")
536 SpLim -> ptext (sLit "SpLim")
537 Hp -> ptext (sLit "Hp")
538 HpLim -> ptext (sLit "HpLim")
539 CurrentTSO -> ptext (sLit "CurrentTSO")
540 CurrentNursery -> ptext (sLit "CurrentNursery")
541 HpAlloc -> ptext (sLit "HpAlloc")
542 GCEnter1 -> ptext (sLit "stg_gc_enter_1")
543 GCFun -> ptext (sLit "stg_gc_fun")
544 BaseReg -> ptext (sLit "BaseReg")
545 PicBaseReg -> ptext (sLit "PicBaseReg")
547 -- --------------------------------------------------------------------------
550 pprSection :: Section -> SDoc
551 pprSection s = case s of
552 Text -> section <+> doubleQuotes (ptext (sLit "text"))
553 Data -> section <+> doubleQuotes (ptext (sLit "data"))
554 ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly"))
555 ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16"))
556 RelocatableReadOnlyData
557 -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
558 UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
559 OtherSection s' -> section <+> doubleQuotes (text s')
561 section = ptext (sLit "section")
563 -- --------------------------------------------------------------------------
566 pprBlockId :: BlockId -> SDoc
567 pprBlockId b = ppr $ getUnique b
569 -----------------------------------------------------------------------------
571 commafy :: [SDoc] -> SDoc
572 commafy xs = hsep $ punctuate comma xs