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/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 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 CmmStmt) where
75 instance (Outputable d, Outputable info, Outputable i)
76 => Outputable (GenCmmTop d info i) where
79 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
82 instance Outputable BlockId where
83 ppr id = pprBlockId id
85 instance Outputable CmmStmt where
88 instance Outputable CmmExpr where
91 instance Outputable CmmReg where
94 instance Outputable LocalReg where
97 instance Outputable GlobalReg where
98 ppr e = pprGlobalReg e
100 instance Outputable CmmStatic where
103 instance Outputable CmmInfo where
108 -----------------------------------------------------------------------------
110 pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
111 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
113 -- --------------------------------------------------------------------------
114 -- Top level `procedure' blocks.
116 pprTop :: (Outputable d, Outputable info, Outputable i)
117 => GenCmmTop d info i -> SDoc
119 pprTop (CmmProc info lbl params blocks )
121 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
122 , nest 8 $ lbrace <+> ppr info $$ rbrace
123 , nest 4 $ vcat (map ppr blocks)
126 -- --------------------------------------------------------------------------
127 -- We follow [1], 4.5
129 -- section "data" { ... }
131 pprTop (CmmData section ds) =
132 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
135 -- --------------------------------------------------------------------------
136 instance Outputable CmmSafety where
137 ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
138 ppr (CmmSafe srt) = ppr srt
140 -- --------------------------------------------------------------------------
141 -- Info tables. The current pretty printer needs refinement
142 -- but will work for now.
144 -- For ideas on how to refine it, they used to be printed in the
145 -- style of C--'s 'stackdata' declaration, just inside the proc body,
146 -- and were labelled with the procedure name ++ "_info".
147 pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) =
148 vcat [{-ptext SLIT("gc_target: ") <>
149 maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
150 ptext SLIT("update_frame: ") <>
151 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame]
152 pprInfo (CmmInfo gc_target update_frame
153 (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
154 vcat [{-ptext SLIT("gc_target: ") <>
155 maybe (ptext SLIT("<none>")) pprBlockId gc_target,-}
156 ptext SLIT("update_frame: ") <>
157 maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
158 ptext SLIT("type: ") <> pprLit closure_type,
159 ptext SLIT("desc: ") <> pprLit closure_desc,
160 ptext SLIT("tag: ") <> integer (toInteger tag),
163 pprTypeInfo (ConstrInfo layout constr descr) =
164 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
165 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
166 ptext SLIT("constructor: ") <> integer (toInteger constr),
168 pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
169 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
170 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
171 ptext SLIT("srt: ") <> ppr srt,
172 ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
173 ptext SLIT("arity: ") <> integer (toInteger arity),
174 --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed
175 ptext SLIT("slow: ") <> pprLit slow_entry
177 pprTypeInfo (ThunkInfo layout srt) =
178 vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
179 ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
180 ptext SLIT("srt: ") <> ppr srt]
181 pprTypeInfo (ThunkSelectorInfo offset srt) =
182 vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
183 ptext SLIT("srt: ") <> ppr srt]
184 pprTypeInfo (ContInfo stack srt) =
185 vcat [ptext SLIT("stack: ") <> ppr stack,
186 ptext SLIT("srt: ") <> ppr srt]
188 pprUpdateFrame :: UpdateFrame -> SDoc
189 pprUpdateFrame (UpdateFrame expr args) =
190 hcat [ ptext SLIT("jump")
192 , if isTrivialCmmExpr expr
195 CmmLoad (CmmReg _) _ -> pprExpr expr
196 _ -> parens (pprExpr expr)
198 , parens ( commafy $ map ppr args ) ]
201 -- --------------------------------------------------------------------------
202 -- Basic blocks look like assembly blocks.
203 -- lbl: stmt ; stmt ; ..
204 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
205 pprBBlock (BasicBlock ident stmts) =
206 hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
208 -- --------------------------------------------------------------------------
209 -- Statements. C-- usually, exceptions to this should be obvious.
211 pprStmt :: CmmStmt -> SDoc
212 pprStmt stmt = case stmt of
218 CmmComment s -> text "//" <+> ftext s
221 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
224 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
226 rep = ppr ( cmmExprRep expr )
228 -- call "ccall" foo(x, y)[r1, r2];
230 CmmCall (CmmCallee fn cconv) results args safety ret ->
231 hcat [ if null results
233 else parens (commafy $ map ppr results) <>
235 ptext SLIT("call"), space,
236 doubleQuotes(ppr cconv), space,
237 target fn, parens ( commafy $ map ppr args ),
238 brackets (ppr safety),
239 case ret of CmmMayReturn -> empty
240 CmmNeverReturns -> ptext SLIT(" never returns"),
243 target (CmmLit lit) = pprLit lit
244 target fn' = parens (ppr fn')
246 CmmCall (CmmPrim op) results args safety ret ->
247 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
248 results args safety ret)
250 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
252 CmmBranch ident -> genBranch ident
253 CmmCondBranch expr ident -> genCondBranch expr ident
254 CmmJump expr params -> genJump expr params
255 CmmReturn params -> genReturn params
256 CmmSwitch arg ids -> genSwitch arg ids
258 -- --------------------------------------------------------------------------
259 -- goto local label. [1], section 6.6
263 genBranch :: BlockId -> SDoc
265 ptext SLIT("goto") <+> pprBlockId ident <> semi
267 -- --------------------------------------------------------------------------
268 -- Conditional. [1], section 6.4
270 -- if (expr) { goto lbl; }
272 genCondBranch :: CmmExpr -> BlockId -> SDoc
273 genCondBranch expr ident =
274 hsep [ ptext SLIT("if")
277 , pprBlockId ident <> semi ]
279 -- --------------------------------------------------------------------------
280 -- A tail call. [1], Section 6.9
282 -- jump foo(a, b, c);
284 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
287 hcat [ ptext SLIT("jump")
289 , if isTrivialCmmExpr expr
292 CmmLoad (CmmReg _) _ -> pprExpr expr
293 _ -> parens (pprExpr expr)
295 , parens ( commafy $ map ppr args )
298 -- --------------------------------------------------------------------------
299 -- Return from a function. [1], Section 6.8.2 of version 1.128
303 genReturn :: [(CmmExpr, MachHint)] -> SDoc
306 hcat [ ptext SLIT("return")
308 , parens ( commafy $ map ppr args )
311 -- --------------------------------------------------------------------------
312 -- Tabled jump to local label
314 -- The syntax is from [1], section 6.5
316 -- switch [0 .. n] (expr) { case ... ; }
318 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
319 genSwitch expr maybe_ids
321 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
323 in hang (hcat [ ptext SLIT("switch [0 .. ")
324 , int (length maybe_ids - 1)
326 , if isTrivialCmmExpr expr
328 else parens (pprExpr expr)
331 4 (vcat ( map caseify pairs )) $$ rbrace
334 snds a b = (snd a) == (snd b)
336 caseify :: [(Int,Maybe BlockId)] -> SDoc
337 caseify ixs@((i,Nothing):_)
338 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
341 = let (is,ids) = unzip as
342 in hsep [ ptext SLIT("case")
343 , hcat (punctuate comma (map int is))
344 , ptext SLIT(": goto")
345 , pprBlockId (head [ id | Just id <- ids]) <> semi ]
347 -- --------------------------------------------------------------------------
351 pprExpr :: CmmExpr -> SDoc
355 pprExpr (CmmMachOp (MO_Add rep)
356 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
357 where rep = cmmRegRep reg
358 CmmLit lit -> pprLit lit
361 -- Here's the precedence table from CmmParse.y:
362 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
371 -- We just cope with the common operators for now, the rest will get
372 -- a default conservative behaviour.
374 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
375 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
376 = pprExpr7 x <+> doc <+> pprExpr7 y
377 pprExpr1 e = pprExpr7 e
379 infixMachOp1 (MO_Eq _) = Just (ptext SLIT("=="))
380 infixMachOp1 (MO_Ne _) = Just (ptext SLIT("!="))
381 infixMachOp1 (MO_Shl _) = Just (ptext SLIT("<<"))
382 infixMachOp1 (MO_U_Shr _) = Just (ptext SLIT(">>"))
383 infixMachOp1 (MO_U_Ge _) = Just (ptext SLIT(">="))
384 infixMachOp1 (MO_U_Le _) = Just (ptext SLIT("<="))
385 infixMachOp1 (MO_U_Gt _) = Just (char '>')
386 infixMachOp1 (MO_U_Lt _) = Just (char '<')
387 infixMachOp1 _ = Nothing
390 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
391 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
392 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
393 = pprExpr7 x <+> doc <+> pprExpr8 y
394 pprExpr7 e = pprExpr8 e
396 infixMachOp7 (MO_Add _) = Just (char '+')
397 infixMachOp7 (MO_Sub _) = Just (char '-')
398 infixMachOp7 _ = Nothing
401 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
402 = pprExpr8 x <+> doc <+> pprExpr9 y
403 pprExpr8 e = pprExpr9 e
405 infixMachOp8 (MO_U_Quot _) = Just (char '/')
406 infixMachOp8 (MO_Mul _) = Just (char '*')
407 infixMachOp8 (MO_U_Rem _) = Just (char '%')
408 infixMachOp8 _ = Nothing
410 pprExpr9 :: CmmExpr -> SDoc
413 CmmLit lit -> pprLit1 lit
414 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
415 CmmReg reg -> ppr reg
416 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
417 CmmMachOp mop args -> genMachOp mop args
419 genMachOp :: MachOp -> [CmmExpr] -> SDoc
421 | Just doc <- infixMachOp mop = case args of
423 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
426 [x] -> doc <> pprExpr9 x
428 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
430 parens (hcat $ punctuate comma (map pprExpr args)))
433 | isJust (infixMachOp1 mop)
434 || isJust (infixMachOp7 mop)
435 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
437 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
438 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
440 -- replace spaces in (show mop) with underscores,
443 -- Unsigned ops on the word size of the machine get nice symbols.
444 -- All else get dumped in their ugly format.
446 infixMachOp :: MachOp -> Maybe SDoc
449 MO_And _ -> Just $ char '&'
450 MO_Or _ -> Just $ char '|'
451 MO_Xor _ -> Just $ char '^'
452 MO_Not _ -> Just $ char '~'
453 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
456 -- --------------------------------------------------------------------------
458 -- To minimise line noise we adopt the convention that if the literal
459 -- has the natural machine word size, we do not append the type
461 pprLit :: CmmLit -> SDoc
462 pprLit lit = case lit of
464 hcat [ (if i < 0 then parens else id)(integer i)
467 else space <> dcolon <+> ppr rep) ]
469 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
470 CmmLabel clbl -> pprCLabel clbl
471 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
472 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
473 <> pprCLabel clbl2 <> ppr_offset i
475 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
476 pprLit1 lit = pprLit lit
478 ppr_offset :: Int -> SDoc
481 | i>=0 = char '+' <> int i
482 | otherwise = char '-' <> int (-i)
484 -- --------------------------------------------------------------------------
486 -- Strings are printed as C strings, and we print them as I8[],
489 pprStatic :: CmmStatic -> SDoc
490 pprStatic s = case s of
491 CmmStaticLit lit -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
492 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
493 CmmAlign i -> nest 4 $ text "align" <+> int i
494 CmmDataLabel clbl -> pprCLabel clbl <> colon
495 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
497 -- --------------------------------------------------------------------------
498 -- Registers, whether local (temps) or global
500 pprReg :: CmmReg -> SDoc
503 CmmLocal local -> pprLocalReg local
504 CmmGlobal global -> pprGlobalReg global
507 -- We only print the type of the local reg if it isn't wordRep
509 pprLocalReg :: LocalReg -> SDoc
510 pprLocalReg (LocalReg uniq rep follow)
511 = hcat [ char '_', ppr uniq, ty ] where
512 ty = if rep == wordRep && follow == KindNonPtr
514 else dcolon <> ptr <> ppr rep
515 ptr = if follow == KindNonPtr
517 else doubleQuotes (text "ptr")
519 -- needs to be kept in syn with Cmm.hs.GlobalReg
521 pprGlobalReg :: GlobalReg -> SDoc
524 VanillaReg n -> char 'R' <> int n
525 FloatReg n -> char 'F' <> int n
526 DoubleReg n -> char 'D' <> int n
527 LongReg n -> char 'L' <> int n
528 Sp -> ptext SLIT("Sp")
529 SpLim -> ptext SLIT("SpLim")
530 Hp -> ptext SLIT("Hp")
531 HpLim -> ptext SLIT("HpLim")
532 CurrentTSO -> ptext SLIT("CurrentTSO")
533 CurrentNursery -> ptext SLIT("CurrentNursery")
534 HpAlloc -> ptext SLIT("HpAlloc")
535 GCEnter1 -> ptext SLIT("stg_gc_enter_1")
536 GCFun -> ptext SLIT("stg_gc_fun")
537 BaseReg -> ptext SLIT("BaseReg")
538 PicBaseReg -> ptext SLIT("PicBaseReg")
540 -- --------------------------------------------------------------------------
543 pprSection :: Section -> SDoc
544 pprSection s = case s of
545 Text -> section <+> doubleQuotes (ptext SLIT("text"))
546 Data -> section <+> doubleQuotes (ptext SLIT("data"))
547 ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
548 RelocatableReadOnlyData
549 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
550 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
551 OtherSection s' -> section <+> doubleQuotes (text s')
553 section = ptext SLIT("section")
555 -- --------------------------------------------------------------------------
558 pprBlockId :: BlockId -> SDoc
559 pprBlockId b = ppr $ getUnique b
561 -----------------------------------------------------------------------------
563 commafy :: [SDoc] -> SDoc
564 commafy xs = hsep $ punctuate comma xs