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