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
46 #include "HsVersions.h"
62 pprCmms :: (Outputable info) => [GenCmm CmmStatic info (ListGraph CmmStmt)] -> 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 info) => Outputable (GenCmm CmmStatic info (ListGraph CmmStmt)) where
75 instance (Outputable d, Outputable info, Outputable i)
76 => Outputable (GenCmmTop d info i) where
79 instance Outputable i => Outputable (ListGraph i) where
80 ppr (ListGraph blocks) = vcat (map ppr blocks)
82 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
85 instance Outputable BlockId where
86 ppr id = pprBlockId id
88 instance Outputable CmmStmt where
91 instance Outputable CmmExpr where
94 instance Outputable CmmReg where
97 instance Outputable LocalReg where
100 instance Outputable GlobalReg where
101 ppr e = pprGlobalReg e
103 instance Outputable CmmStatic where
106 instance Outputable CmmInfo where
111 -----------------------------------------------------------------------------
113 pprCmm :: (Outputable info) => GenCmm CmmStatic info (ListGraph CmmStmt) -> SDoc
114 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
116 -- --------------------------------------------------------------------------
117 -- Top level `procedure' blocks.
119 pprTop :: (Outputable d, Outputable info, Outputable g)
120 => GenCmmTop d info g -> SDoc
122 pprTop (CmmProc info lbl params graph)
124 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
125 , nest 8 $ lbrace <+> ppr info $$ rbrace
129 -- --------------------------------------------------------------------------
130 -- We follow [1], 4.5
132 -- section "data" { ... }
134 pprTop (CmmData section ds) =
135 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
138 -- --------------------------------------------------------------------------
139 instance Outputable CmmSafety where
140 ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
141 ppr (CmmSafe srt) = ppr srt
143 -- --------------------------------------------------------------------------
144 -- Info tables. The current pretty printer needs refinement
145 -- but will work for now.
147 -- For ideas on how to refine it, they used to be printed in the
148 -- style of C--'s 'stackdata' declaration, just inside the proc body,
149 -- and were labelled with the procedure name ++ "_info".
150 pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) =
151 vcat [{-ptext SLIT("gc_target: ") <>
152 maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
153 ptext SLIT("update_frame: ") <>
154 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame]
155 pprInfo (CmmInfo gc_target update_frame
156 (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
157 vcat [{-ptext SLIT("gc_target: ") <>
158 maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
159 ptext SLIT("update_frame: ") <>
160 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
161 ptext SLIT("type: ") <> pprLit closure_type,
162 ptext SLIT("desc: ") <> pprLit closure_desc,
163 ptext SLIT("tag: ") <> integer (toInteger tag),
166 pprTypeInfo (ConstrInfo layout constr descr) =
167 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
168 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
169 ptext SLIT("constructor: ") <> integer (toInteger constr),
171 pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
172 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
173 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
174 ptext SLIT("srt: ") <> ppr srt,
175 ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
176 ptext SLIT("arity: ") <> integer (toInteger arity),
177 --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed
178 ptext SLIT("slow: ") <> pprLit slow_entry
180 pprTypeInfo (ThunkInfo layout srt) =
181 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
182 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
183 ptext SLIT("srt: ") <> ppr srt]
184 pprTypeInfo (ThunkSelectorInfo offset srt) =
185 vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
186 ptext SLIT("srt: ") <> ppr srt]
187 pprTypeInfo (ContInfo stack srt) =
188 vcat [ptext SLIT("stack: ") <> ppr stack,
189 ptext SLIT("srt: ") <> ppr srt]
191 pprUpdateFrame :: UpdateFrame -> SDoc
192 pprUpdateFrame (UpdateFrame expr args) =
193 hcat [ ptext SLIT("jump")
195 , if isTrivialCmmExpr expr
198 CmmLoad (CmmReg _) _ -> pprExpr expr
199 _ -> parens (pprExpr expr)
201 , parens ( commafy $ map ppr args ) ]
204 -- --------------------------------------------------------------------------
205 -- Basic blocks look like assembly blocks.
206 -- lbl: stmt ; stmt ; ..
207 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
208 pprBBlock (BasicBlock ident stmts) =
209 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
211 -- --------------------------------------------------------------------------
212 -- Statements. C-- usually, exceptions to this should be obvious.
214 pprStmt :: CmmStmt -> SDoc
215 pprStmt stmt = case stmt of
221 CmmComment s -> text "//" <+> ftext s
224 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
227 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
229 rep = ppr ( cmmExprRep expr )
231 -- call "ccall" foo(x, y)[r1, r2];
233 CmmCall (CmmCallee fn cconv) results args safety ret ->
234 hcat [ if null results
236 else parens (commafy $ map ppr results) <>
238 ptext SLIT("call"), space,
239 doubleQuotes(ppr cconv), space,
240 target fn, parens ( commafy $ map ppr args ),
241 brackets (ppr safety),
242 case ret of CmmMayReturn -> empty
243 CmmNeverReturns -> ptext SLIT(" never returns"),
246 target (CmmLit lit) = pprLit lit
247 target fn' = parens (ppr fn')
249 CmmCall (CmmPrim op) results args safety ret ->
250 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
251 results args safety ret)
253 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
255 CmmBranch ident -> genBranch ident
256 CmmCondBranch expr ident -> genCondBranch expr ident
257 CmmJump expr params -> genJump expr params
258 CmmReturn params -> genReturn params
259 CmmSwitch arg ids -> genSwitch arg ids
261 -- --------------------------------------------------------------------------
262 -- goto local label. [1], section 6.6
266 genBranch :: BlockId -> SDoc
268 ptext SLIT("goto") <+> pprBlockId ident <> semi
270 -- --------------------------------------------------------------------------
271 -- Conditional. [1], section 6.4
273 -- if (expr) { goto lbl; }
275 genCondBranch :: CmmExpr -> BlockId -> SDoc
276 genCondBranch expr ident =
277 hsep [ ptext SLIT("if")
280 , pprBlockId ident <> semi ]
282 -- --------------------------------------------------------------------------
283 -- A tail call. [1], Section 6.9
285 -- jump foo(a, b, c);
287 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
290 hcat [ ptext SLIT("jump")
292 , if isTrivialCmmExpr expr
295 CmmLoad (CmmReg _) _ -> pprExpr expr
296 _ -> parens (pprExpr expr)
298 , parens ( commafy $ map ppr args )
301 -- --------------------------------------------------------------------------
302 -- Return from a function. [1], Section 6.8.2 of version 1.128
306 genReturn :: [(CmmExpr, MachHint)] -> SDoc
309 hcat [ ptext SLIT("return")
311 , parens ( commafy $ map ppr args )
314 -- --------------------------------------------------------------------------
315 -- Tabled jump to local label
317 -- The syntax is from [1], section 6.5
319 -- switch [0 .. n] (expr) { case ... ; }
321 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
322 genSwitch expr maybe_ids
324 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
326 in hang (hcat [ ptext SLIT("switch [0 .. ")
327 , int (length maybe_ids - 1)
329 , if isTrivialCmmExpr expr
331 else parens (pprExpr expr)
334 4 (vcat ( map caseify pairs )) $$ rbrace
337 snds a b = (snd a) == (snd b)
339 caseify :: [(Int,Maybe BlockId)] -> SDoc
340 caseify ixs@((i,Nothing):_)
341 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
344 = let (is,ids) = unzip as
345 in hsep [ ptext SLIT("case")
346 , hcat (punctuate comma (map int is))
347 , ptext SLIT(": goto")
348 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
350 -- --------------------------------------------------------------------------
354 pprExpr :: CmmExpr -> SDoc
358 pprExpr (CmmMachOp (MO_Add rep)
359 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
360 where rep = cmmRegRep reg
361 CmmLit lit -> pprLit lit
364 -- Here's the precedence table from CmmParse.y:
365 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
374 -- We just cope with the common operators for now, the rest will get
375 -- a default conservative behaviour.
377 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
378 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
379 = pprExpr7 x <+> doc <+> pprExpr7 y
380 pprExpr1 e = pprExpr7 e
382 infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
383 infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
384 infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
385 infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
386 infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
387 infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
388 infixMachOp1 (MO_U_Gt _) = Just (char '>')
389 infixMachOp1 (MO_U_Lt _) = Just (char '<')
390 infixMachOp1 _ = Nothing
393 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
394 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
395 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
396 = pprExpr7 x <+> doc <+> pprExpr8 y
397 pprExpr7 e = pprExpr8 e
399 infixMachOp7 (MO_Add _) = Just (char '+')
400 infixMachOp7 (MO_Sub _) = Just (char '-')
401 infixMachOp7 _ = Nothing
404 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
405 = pprExpr8 x <+> doc <+> pprExpr9 y
406 pprExpr8 e = pprExpr9 e
408 infixMachOp8 (MO_U_Quot _) = Just (char '/')
409 infixMachOp8 (MO_Mul _) = Just (char '*')
410 infixMachOp8 (MO_U_Rem _) = Just (char '%')
411 infixMachOp8 _ = Nothing
413 pprExpr9 :: CmmExpr -> SDoc
416 CmmLit lit -> pprLit1 lit
417 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
418 CmmReg reg -> ppr reg
419 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
420 CmmMachOp mop args -> genMachOp mop args
422 genMachOp :: MachOp -> [CmmExpr] -> SDoc
424 | Just doc <- infixMachOp mop = case args of
426 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
429 [x] -> doc <> pprExpr9 x
431 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
433 parens (hcat $ punctuate comma (map pprExpr args)))
436 | isJust (infixMachOp1 mop)
437 || isJust (infixMachOp7 mop)
438 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
440 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
441 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
443 -- replace spaces in (show mop) with underscores,
446 -- Unsigned ops on the word size of the machine get nice symbols.
447 -- All else get dumped in their ugly format.
449 infixMachOp :: MachOp -> Maybe SDoc
452 MO_And _ -> Just $ char '&'
453 MO_Or _ -> Just $ char '|'
454 MO_Xor _ -> Just $ char '^'
455 MO_Not _ -> Just $ char '~'
456 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
459 -- --------------------------------------------------------------------------
461 -- To minimise line noise we adopt the convention that if the literal
462 -- has the natural machine word size, we do not append the type
464 pprLit :: CmmLit -> SDoc
465 pprLit lit = case lit of
467 hcat [ (if i < 0 then parens else id)(integer i)
470 else space <> dcolon <+> ppr rep) ]
472 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
473 CmmLabel clbl -> pprCLabel clbl
474 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
475 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
476 <> pprCLabel clbl2 <> ppr_offset i
478 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
479 pprLit1 lit = pprLit lit
481 ppr_offset :: Int -> SDoc
484 | i>=0 = char '+' <> int i
485 | otherwise = char '-' <> int (-i)
487 -- --------------------------------------------------------------------------
489 -- Strings are printed as C strings, and we print them as I8[],
492 pprStatic :: CmmStatic -> SDoc
493 pprStatic s = case s of
494 CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
495 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
496 CmmAlign i -> nest 4 $ text "align" <+> int i
497 CmmDataLabel clbl -> pprCLabel clbl <> colon
498 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
500 -- --------------------------------------------------------------------------
501 -- Registers, whether local (temps) or global
503 pprReg :: CmmReg -> SDoc
506 CmmLocal local -> pprLocalReg local
507 CmmGlobal global -> pprGlobalReg global
510 -- We only print the type of the local reg if it isn't wordRep
512 pprLocalReg :: LocalReg -> SDoc
513 pprLocalReg (LocalReg uniq rep follow)
514 = hcat [ char '_', ppr uniq, ty ] where
515 ty = if rep == wordRep && follow == KindNonPtr
517 else dcolon <> ptr <> ppr rep
518 ptr = if follow == KindNonPtr
520 else doubleQuotes (text "ptr")
522 -- needs to be kept in syn with Cmm.hs.GlobalReg
524 pprGlobalReg :: GlobalReg -> SDoc
527 VanillaReg n -> char 'R' <> int n
528 FloatReg n -> char 'F' <> int n
529 DoubleReg n -> char 'D' <> int n
530 LongReg n -> char 'L' <> int n
531 Sp -> ptext SLIT("Sp")
532 SpLim -> ptext SLIT("SpLim")
533 Hp -> ptext SLIT("Hp")
534 HpLim -> ptext SLIT("HpLim")
535 CurrentTSO -> ptext SLIT("CurrentTSO")
536 CurrentNursery -> ptext SLIT("CurrentNursery")
537 HpAlloc -> ptext SLIT("HpAlloc")
538 GCEnter1 -> ptext SLIT("stg_gc_enter_1")
539 GCFun -> ptext SLIT("stg_gc_fun")
540 BaseReg -> ptext SLIT("BaseReg")
541 PicBaseReg -> ptext SLIT("PicBaseReg")
543 -- --------------------------------------------------------------------------
546 pprSection :: Section -> SDoc
547 pprSection s = case s of
548 Text -> section <+> doubleQuotes (ptext SLIT("text"))
549 Data -> section <+> doubleQuotes (ptext SLIT("data"))
550 ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
551 RelocatableReadOnlyData
552 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
553 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
554 OtherSection s' -> section <+> doubleQuotes (text s')
556 section = ptext SLIT("section")
558 -- --------------------------------------------------------------------------
561 pprBlockId :: BlockId -> SDoc
562 pprBlockId b = ppr $ getUnique b
564 -----------------------------------------------------------------------------
566 commafy :: [SDoc] -> SDoc
567 commafy xs = hsep $ punctuate comma xs