Use OPTIONS rather than OPTIONS_GHC for pragmas
[ghc.git] / compiler / cmm / PprCmm.hs
1 {-# OPTIONS -w #-}
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
6 -- for details
7
8 ----------------------------------------------------------------------------
9 --
10 -- Pretty-printing of Cmm as (a superset of) C--
11 --
12 -- (c) The University of Glasgow 2004-2006
13 --
14 -----------------------------------------------------------------------------
15
16 --
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.
20 --
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.
26 --
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
31 -- cases:
32 -- 1) if a value has wordRep type, the type is not appended in the
33 -- output.
34 -- 2) MachOps that operate over wordRep type are printed in a
35 -- C-style, rather than as their internal MachRep name.
36 --
37 -- These conventions produce much more readable Cmm output.
38 --
39 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
40 --
41
42 module PprCmm (
43 writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
44 ) where
45
46 #include "HsVersions.h"
47
48 import Cmm
49 import CmmUtils
50 import MachOp
51 import CLabel
52
53 import ForeignCall
54 import Unique
55 import Outputable
56 import FastString
57
58 import Data.List
59 import System.IO
60 import Data.Maybe
61
62 pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc
63 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
64 where
65 separator = space $$ ptext SLIT("-------------------") $$ space
66
67 writeCmms :: Handle -> [Cmm] -> IO ()
68 writeCmms handle cmms = printForC handle (pprCmms cmms)
69
70 -----------------------------------------------------------------------------
71
72 instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
73 ppr c = pprCmm c
74
75 instance (Outputable d, Outputable info, Outputable i)
76 => Outputable (GenCmmTop d info i) where
77 ppr t = pprTop t
78
79 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
80 ppr b = pprBBlock b
81
82 instance Outputable BlockId where
83 ppr id = pprBlockId id
84
85 instance Outputable CmmStmt where
86 ppr s = pprStmt s
87
88 instance Outputable CmmExpr where
89 ppr e = pprExpr e
90
91 instance Outputable CmmReg where
92 ppr e = pprReg e
93
94 instance Outputable LocalReg where
95 ppr e = pprLocalReg e
96
97 instance Outputable GlobalReg where
98 ppr e = pprGlobalReg e
99
100 instance Outputable CmmStatic where
101 ppr e = pprStatic e
102
103 instance Outputable CmmInfo where
104 ppr e = pprInfo e
105
106
107
108 -----------------------------------------------------------------------------
109
110 pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
111 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
112
113 -- --------------------------------------------------------------------------
114 -- Top level `procedure' blocks.
115 --
116 pprTop :: (Outputable d, Outputable info, Outputable i)
117 => GenCmmTop d info i -> SDoc
118
119 pprTop (CmmProc info lbl params blocks )
120
121 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
122 , nest 8 $ lbrace <+> ppr info $$ rbrace
123 , nest 4 $ vcat (map ppr blocks)
124 , rbrace ]
125
126 -- --------------------------------------------------------------------------
127 -- We follow [1], 4.5
128 --
129 -- section "data" { ... }
130 --
131 pprTop (CmmData section ds) =
132 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
133 $$ rbrace
134
135 -- --------------------------------------------------------------------------
136 instance Outputable CmmSafety where
137 ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
138 ppr (CmmSafe srt) = ppr srt
139
140 -- --------------------------------------------------------------------------
141 -- Info tables. The current pretty printer needs refinement
142 -- but will work for now.
143 --
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),
161 pprTypeInfo info]
162
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),
167 pprLit descr]
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
176 ]
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]
187
188 pprUpdateFrame :: UpdateFrame -> SDoc
189 pprUpdateFrame (UpdateFrame expr args) =
190 hcat [ ptext SLIT("jump")
191 , space
192 , if isTrivialCmmExpr expr
193 then pprExpr expr
194 else case expr of
195 CmmLoad (CmmReg _) _ -> pprExpr expr
196 _ -> parens (pprExpr expr)
197 , space
198 , parens ( commafy $ map ppr args ) ]
199
200
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))
207
208 -- --------------------------------------------------------------------------
209 -- Statements. C-- usually, exceptions to this should be obvious.
210 --
211 pprStmt :: CmmStmt -> SDoc
212 pprStmt stmt = case stmt of
213
214 -- ;
215 CmmNop -> semi
216
217 -- // text
218 CmmComment s -> text "//" <+> ftext s
219
220 -- reg = expr;
221 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
222
223 -- rep[lv] = expr;
224 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
225 where
226 rep = ppr ( cmmExprRep expr )
227
228 -- call "ccall" foo(x, y)[r1, r2];
229 -- ToDo ppr volatile
230 CmmCall (CmmCallee fn cconv) results args safety ret ->
231 hcat [ if null results
232 then empty
233 else parens (commafy $ map ppr results) <>
234 ptext SLIT(" = "),
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"),
241 semi ]
242 where
243 target (CmmLit lit) = pprLit lit
244 target fn' = parens (ppr fn')
245
246 CmmCall (CmmPrim op) results args safety ret ->
247 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
248 results args safety ret)
249 where
250 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
251
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
257
258 -- --------------------------------------------------------------------------
259 -- goto local label. [1], section 6.6
260 --
261 -- goto lbl;
262 --
263 genBranch :: BlockId -> SDoc
264 genBranch ident =
265 ptext SLIT("goto") <+> pprBlockId ident <> semi
266
267 -- --------------------------------------------------------------------------
268 -- Conditional. [1], section 6.4
269 --
270 -- if (expr) { goto lbl; }
271 --
272 genCondBranch :: CmmExpr -> BlockId -> SDoc
273 genCondBranch expr ident =
274 hsep [ ptext SLIT("if")
275 , parens(ppr expr)
276 , ptext SLIT("goto")
277 , pprBlockId ident <> semi ]
278
279 -- --------------------------------------------------------------------------
280 -- A tail call. [1], Section 6.9
281 --
282 -- jump foo(a, b, c);
283 --
284 genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
285 genJump expr args =
286
287 hcat [ ptext SLIT("jump")
288 , space
289 , if isTrivialCmmExpr expr
290 then pprExpr expr
291 else case expr of
292 CmmLoad (CmmReg _) _ -> pprExpr expr
293 _ -> parens (pprExpr expr)
294 , space
295 , parens ( commafy $ map ppr args )
296 , semi ]
297
298 -- --------------------------------------------------------------------------
299 -- Return from a function. [1], Section 6.8.2 of version 1.128
300 --
301 -- return (a, b, c);
302 --
303 genReturn :: [(CmmExpr, MachHint)] -> SDoc
304 genReturn args =
305
306 hcat [ ptext SLIT("return")
307 , space
308 , parens ( commafy $ map ppr args )
309 , semi ]
310
311 -- --------------------------------------------------------------------------
312 -- Tabled jump to local label
313 --
314 -- The syntax is from [1], section 6.5
315 --
316 -- switch [0 .. n] (expr) { case ... ; }
317 --
318 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
319 genSwitch expr maybe_ids
320
321 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
322
323 in hang (hcat [ ptext SLIT("switch [0 .. ")
324 , int (length maybe_ids - 1)
325 , ptext SLIT("] ")
326 , if isTrivialCmmExpr expr
327 then pprExpr expr
328 else parens (pprExpr expr)
329 , ptext SLIT(" {")
330 ])
331 4 (vcat ( map caseify pairs )) $$ rbrace
332
333 where
334 snds a b = (snd a) == (snd b)
335
336 caseify :: [(Int,Maybe BlockId)] -> SDoc
337 caseify ixs@((i,Nothing):_)
338 = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
339 <> ptext SLIT(" */")
340 caseify as
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 ]
346
347 -- --------------------------------------------------------------------------
348 -- Expressions
349 --
350
351 pprExpr :: CmmExpr -> SDoc
352 pprExpr e
353 = case e of
354 CmmRegOff reg i ->
355 pprExpr (CmmMachOp (MO_Add rep)
356 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
357 where rep = cmmRegRep reg
358 CmmLit lit -> pprLit lit
359 _other -> pprExpr1 e
360
361 -- Here's the precedence table from CmmParse.y:
362 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
363 -- %left '|'
364 -- %left '^'
365 -- %left '&'
366 -- %left '>>' '<<'
367 -- %left '-' '+'
368 -- %left '/' '*' '%'
369 -- %right '~'
370
371 -- We just cope with the common operators for now, the rest will get
372 -- a default conservative behaviour.
373
374 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
375 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
376 = pprExpr7 x <+> doc <+> pprExpr7 y
377 pprExpr1 e = pprExpr7 e
378
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
388
389 -- %left '-' '+'
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
395
396 infixMachOp7 (MO_Add _) = Just (char '+')
397 infixMachOp7 (MO_Sub _) = Just (char '-')
398 infixMachOp7 _ = Nothing
399
400 -- %left '/' '*' '%'
401 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
402 = pprExpr8 x <+> doc <+> pprExpr9 y
403 pprExpr8 e = pprExpr9 e
404
405 infixMachOp8 (MO_U_Quot _) = Just (char '/')
406 infixMachOp8 (MO_Mul _) = Just (char '*')
407 infixMachOp8 (MO_U_Rem _) = Just (char '%')
408 infixMachOp8 _ = Nothing
409
410 pprExpr9 :: CmmExpr -> SDoc
411 pprExpr9 e =
412 case e of
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
418
419 genMachOp :: MachOp -> [CmmExpr] -> SDoc
420 genMachOp mop args
421 | Just doc <- infixMachOp mop = case args of
422 -- dyadic
423 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
424
425 -- unary
426 [x] -> doc <> pprExpr9 x
427
428 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
429 (pprMachOp mop <+>
430 parens (hcat $ punctuate comma (map pprExpr args)))
431 empty
432
433 | isJust (infixMachOp1 mop)
434 || isJust (infixMachOp7 mop)
435 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
436
437 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
438 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
439 (show mop))
440 -- replace spaces in (show mop) with underscores,
441
442 --
443 -- Unsigned ops on the word size of the machine get nice symbols.
444 -- All else get dumped in their ugly format.
445 --
446 infixMachOp :: MachOp -> Maybe SDoc
447 infixMachOp mop
448 = case mop of
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 :)
454 _ -> Nothing
455
456 -- --------------------------------------------------------------------------
457 -- Literals.
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
460 --
461 pprLit :: CmmLit -> SDoc
462 pprLit lit = case lit of
463 CmmInt i rep ->
464 hcat [ (if i < 0 then parens else id)(integer i)
465 , (if rep == wordRep
466 then empty
467 else space <> dcolon <+> ppr rep) ]
468
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
474
475 pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
476 pprLit1 lit = pprLit lit
477
478 ppr_offset :: Int -> SDoc
479 ppr_offset i
480 | i==0 = empty
481 | i>=0 = char '+' <> int i
482 | otherwise = char '-' <> int (-i)
483
484 -- --------------------------------------------------------------------------
485 -- Static data.
486 -- Strings are printed as C strings, and we print them as I8[],
487 -- following C--
488 --
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')
496
497 -- --------------------------------------------------------------------------
498 -- Registers, whether local (temps) or global
499 --
500 pprReg :: CmmReg -> SDoc
501 pprReg r
502 = case r of
503 CmmLocal local -> pprLocalReg local
504 CmmGlobal global -> pprGlobalReg global
505
506 --
507 -- We only print the type of the local reg if it isn't wordRep
508 --
509 pprLocalReg :: LocalReg -> SDoc
510 pprLocalReg (LocalReg uniq rep follow)
511 = hcat [ char '_', ppr uniq, ty ] where
512 ty = if rep == wordRep && follow == KindNonPtr
513 then empty
514 else dcolon <> ptr <> ppr rep
515 ptr = if follow == KindNonPtr
516 then empty
517 else doubleQuotes (text "ptr")
518
519 -- needs to be kept in syn with Cmm.hs.GlobalReg
520 --
521 pprGlobalReg :: GlobalReg -> SDoc
522 pprGlobalReg gr
523 = case gr of
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")
539
540 -- --------------------------------------------------------------------------
541 -- data sections
542 --
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')
552 where
553 section = ptext SLIT("section")
554
555 -- --------------------------------------------------------------------------
556 -- Basic block ids
557 --
558 pprBlockId :: BlockId -> SDoc
559 pprBlockId b = ppr $ getUnique b
560
561 -----------------------------------------------------------------------------
562
563 commafy :: [SDoc] -> SDoc
564 commafy xs = hsep $ punctuate comma xs
565