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
47 #include "HsVersions.h"
64 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
65 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
67 separator = space $$ ptext SLIT("-------------------") $$ space
69 writeCmms :: Handle -> [Cmm] -> IO ()
70 writeCmms handle cmms = printForC handle (pprCmms cmms)
72 -----------------------------------------------------------------------------
74 instance (Outputable info, Outputable g)
75 => Outputable (GenCmm CmmStatic info g) where
78 instance (Outputable d, Outputable info, Outputable i)
79 => Outputable (GenCmmTop d info i) where
82 instance (Outputable instr) => Outputable (ListGraph instr) where
83 ppr (ListGraph blocks) = vcat (map ppr blocks)
85 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
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, Outputable g) => GenCmm CmmStatic info g -> SDoc
114 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
116 -- --------------------------------------------------------------------------
117 -- Top level `procedure' blocks.
119 pprTop :: (Outputable d, Outputable info, Outputable i)
120 => GenCmmTop d info i -> 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("foreign"), 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 == GCKindNonPtr
517 else dcolon <> ptr <> ppr rep
518 ptr = if follow == GCKindNonPtr
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 ReadOnlyData16 -> section <+> doubleQuotes (ptext SLIT("readonly16"))
552 RelocatableReadOnlyData
553 -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
554 UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
555 OtherSection s' -> section <+> doubleQuotes (text s')
557 section = ptext SLIT("section")
559 -- --------------------------------------------------------------------------
562 pprBlockId :: BlockId -> SDoc
563 pprBlockId b = ppr $ getUnique b
565 -----------------------------------------------------------------------------
567 commafy :: [SDoc] -> SDoc
568 commafy xs = hsep $ punctuate comma xs