1{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3
4----------------------------------------------------------------------------
5--
6-- Pretty-printing of Cmm as (a superset of) C--
7--
8-- (c) The University of Glasgow 2004-2006
9--
10-----------------------------------------------------------------------------
11--
12-- This is where we walk over CmmNode emitting an external representation,
13-- suitable for parsing, in a syntax strongly reminiscent of C--. This
14-- is the "External Core" for the Cmm layer.
15--
16-- As such, this should be a well-defined syntax: we want it to look nice.
17-- Thus, we try wherever possible to use syntax defined in [1],
18-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
19-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
20-- than C--'s bits8 .. bits64.
21--
22-- We try to ensure that all information available in the abstract
23-- syntax is reproduced, or reproducible, in the concrete syntax.
24-- Data that is not in printed out can be reconstructed according to
25-- conventions used in the pretty printer. There are at least two such
26-- cases:
27--      1) if a value has wordRep type, the type is not appended in the
28--      output.
29--      2) MachOps that operate over wordRep type are printed in a
30--      C-style, rather than as their internal MachRep name.
31--
32-- These conventions produce much more readable Cmm output.
33--
34-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
35
36module PprCmm
37  ( module PprCmmDecl
38  , module PprCmmExpr
39  )
40where
41
42import GhcPrelude hiding (succ)
43
44import CLabel
45import Cmm
46import CmmUtils
47import CmmSwitch
48import DynFlags
49import FastString
50import Outputable
51import PprCmmDecl
52import PprCmmExpr
53import Util
54
55import BasicTypes
56import Hoopl.Block
57import Hoopl.Graph
58
59-------------------------------------------------
60-- Outputable instances
61
62instance Outputable CmmStackInfo where
63    ppr = pprStackInfo
64
65instance Outputable CmmTopInfo where
66    ppr = pprTopInfo
67
68
69instance Outputable (CmmNode e x) where
70    ppr = pprNode
71
72instance Outputable Convention where
73    ppr = pprConvention
74
75instance Outputable ForeignConvention where
76    ppr = pprForeignConvention
77
78instance Outputable ForeignTarget where
79    ppr = pprForeignTarget
80
81instance Outputable CmmReturnInfo where
82    ppr = pprReturnInfo
83
84instance Outputable (Block CmmNode C C) where
85    ppr = pprBlock
86instance Outputable (Block CmmNode C O) where
87    ppr = pprBlock
88instance Outputable (Block CmmNode O C) where
89    ppr = pprBlock
90instance Outputable (Block CmmNode O O) where
91    ppr = pprBlock
92
93instance Outputable (Graph CmmNode e x) where
94    ppr = pprGraph
95
96instance Outputable CmmGraph where
97    ppr = pprCmmGraph
98
99----------------------------------------------------------
100-- Outputting types Cmm contains
101
102pprStackInfo :: CmmStackInfo -> SDoc
103pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
104  text "arg_space: " <> ppr arg_space <+>
105  text "updfr_space: " <> ppr updfr_space
106
107pprTopInfo :: CmmTopInfo -> SDoc
108pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
109  vcat [text "info_tbls: " <> ppr info_tbl,
110        text "stack_info: " <> ppr stack_info]
111
112----------------------------------------------------------
113-- Outputting blocks and graphs
114
115pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
116         => Block CmmNode e x -> IndexedCO e SDoc SDoc
117pprBlock block
118    = foldBlockNodesB3 ( ($$) . ppr
119                       , ($$) . (nest 4) . ppr
120                       , ($$) . (nest 4) . ppr
121                       )
122                       block
123                       empty
124
125pprGraph :: Graph CmmNode e x -> SDoc
126pprGraph GNil = empty
127pprGraph (GUnit block) = ppr block
128pprGraph (GMany entry body exit)
129   = text "{"
130  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
131  $$ text "}"
132  where pprMaybeO :: Outputable (Block CmmNode e x)
133                  => MaybeO ex (Block CmmNode e x) -> SDoc
134        pprMaybeO NothingO = empty
135        pprMaybeO (JustO block) = ppr block
136
137pprCmmGraph :: CmmGraph -> SDoc
138pprCmmGraph g
139   = text "{" <> text "offset"
140  $$ nest 2 (vcat $ map ppr blocks)
141  $$ text "}"
142  where blocks = revPostorder g
143    -- revPostorder has the side-effect of discarding unreachable code,
144    -- so pretty-printed Cmm will omit any unreachable blocks.  This can
145    -- sometimes be confusing.
146
147---------------------------------------------
148-- Outputting CmmNode and types which it contains
149
150pprConvention :: Convention -> SDoc
151pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
152pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
153pprConvention (NativeReturn {})     = text "<native-ret-convention>"
154pprConvention  Slow                 = text "<slow-convention>"
155pprConvention  GC                   = text "<gc-convention>"
156
157pprForeignConvention :: ForeignConvention -> SDoc
158pprForeignConvention (ForeignConvention c args res ret _ _) =
159          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
160
161pprReturnInfo :: CmmReturnInfo -> SDoc
162pprReturnInfo CmmMayReturn = empty
163pprReturnInfo CmmNeverReturns = text "never returns"
164
165pprForeignTarget :: ForeignTarget -> SDoc
166pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
167  where
168        ppr_target :: CmmExpr -> SDoc
169        ppr_target t@(CmmLit _) = ppr t
170        ppr_target fn'          = parens (ppr fn')
171
172pprForeignTarget (PrimTarget op)
173 -- HACK: We're just using a ForeignLabel to get this printed, the label
174 --       might not really be foreign.
175 = ppr
176               (CmmLabel (mkForeignLabel
177                         (mkFastString (show op))
178                         Nothing ForeignLabelInThisPackage IsFunction))
179
180pprNode :: CmmNode e x -> SDoc
181pprNode node = pp_node <+> pp_debug
182  where
183    pp_node :: SDoc
184    pp_node = sdocWithDynFlags $ \dflags -> case node of
185      -- label:
186      CmmEntry id tscope -> lbl <> colon <+>
187         (sdocWithDynFlags $ \dflags ->
188           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
189          where
190            lbl = if gopt Opt_SuppressUniques dflags
191                then text "_lbl_"
192                else ppr id
193
194      -- // text
195      CmmComment s -> text "//" <+> ftext s
196
197      -- //tick bla<...>
198      CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
199                   text "//tick" <+> ppr t
200
201      -- unwind reg = expr;
202      CmmUnwind regs ->
203          text "unwind "
204          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
205
206      -- reg = expr;
207      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
208
209      -- rep[lv] = expr;
210      CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
211          where
212            rep = sdocWithDynFlags $ \dflags ->
213                  ppr ( cmmExprType dflags expr )
214
215      -- call "ccall" foo(x, y)[r1, r2];
216      -- ToDo ppr volatile
217      CmmUnsafeForeignCall target results args ->
218          hsep [ ppUnless (null results) $
219                    parens (commafy $ map ppr results) <+> equals,
220                 text "call",
221                 ppr target <> parens (commafy $ map ppr args) <> semi]
222
223      -- goto label;
224      CmmBranch ident -> text "goto" <+> ppr ident <> semi
225
226      -- if (expr) goto t; else goto f;
227      CmmCondBranch expr t f l ->
228          hsep [ text "if"
229               , parens(ppr expr)
230               , case l of
231                   Nothing -> empty
232                   Just b -> parens (text "likely:" <+> ppr b)
233               , text "goto"
234               , ppr t <> semi
235               , text "else goto"
236               , ppr f <> semi
237               ]
238
239      CmmSwitch expr ids ->
240          hang (hsep [ text "switch"
241                     , range
242                     , if isTrivialCmmExpr expr
243                       then ppr expr
244                       else parens (ppr expr)
245                     , text "{"
246                     ])
247             4 (vcat (map ppCase cases) $$ def) $$ rbrace
248          where
249            (cases, mbdef) = switchTargetsFallThrough ids
250            ppCase (is,l) = hsep
251                            [ text "case"
252                            , commafy $ map integer is
253                            , text ": goto"
254                            , ppr l <> semi
255                            ]
256            def | Just l <- mbdef = hsep
257                            [ text "default:"
258                            , braces (text "goto" <+> ppr l <> semi)
259                            ]
260                | otherwise = empty
261
262            range = brackets $ hsep [integer lo, text "..", integer hi]
263              where (lo,hi) = switchTargetsRange ids
264
265      CmmCall tgt k regs out res updfr_off ->
266          hcat [ text "call", space
267               , pprFun tgt, parens (interpp'SP regs), space
268               , returns <+>
269                 text "args: " <> ppr out <> comma <+>
270                 text "res: " <> ppr res <> comma <+>
271                 text "upd: " <> ppr updfr_off
272               , semi ]
273          where pprFun f@(CmmLit _) = ppr f
274                pprFun f = parens (ppr f)
275
276                returns
277                  | Just r <- k = text "returns to" <+> ppr r <> comma
278                  | otherwise   = empty
279
280      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
281          hcat $ if i then [text "interruptible", space] else [] ++
282               [ text "foreign call", space
283               , ppr t, text "(...)", space
284               , text "returns to" <+> ppr s
285                    <+> text "args:" <+> parens (ppr as)
286                    <+> text "ress:" <+> parens (ppr rs)
287               , text "ret_args:" <+> ppr a
288               , text "ret_off:" <+> ppr u
289               , semi ]
290
291    pp_debug :: SDoc
292    pp_debug =
293      if not debugIsOn then empty
294      else case node of
295             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"
296             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"
297             CmmTick {}              -> empty
298             CmmUnwind {}            -> text "  // CmmUnwind"
299             CmmAssign {}            -> text "  // CmmAssign"
300             CmmStore {}             -> text "  // CmmStore"
301             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"
302             CmmBranch {}            -> text "  // CmmBranch"
303             CmmCondBranch {}        -> text "  // CmmCondBranch"
304             CmmSwitch {}            -> text "  // CmmSwitch"
305             CmmCall {}              -> text "  // CmmCall"
306             CmmForeignCall {}       -> text "  // CmmForeignCall"
307
308    commafy :: [SDoc] -> SDoc
309    commafy xs = hsep $ punctuate comma xs
310