Add support for producing position-independent executables
[ghc.git] / compiler / cmm / PprCmm.hs
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.cminusminus.org/. We differ
19 -- 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
36 module PprCmm
37 ( module PprCmmDecl
38 , module PprCmmExpr
39 )
40 where
41
42 import BlockId ()
43 import CLabel
44 import Cmm
45 import CmmUtils
46 import CmmSwitch
47 import DynFlags
48 import FastString
49 import Outputable
50 import PprCmmDecl
51 import PprCmmExpr
52 import Util
53 import PprCore ()
54
55 import BasicTypes
56 import Hoopl.Block
57 import Hoopl.Graph
58 import Data.List
59 import Prelude hiding (succ)
60
61 -------------------------------------------------
62 -- Outputable instances
63
64 instance Outputable CmmStackInfo where
65 ppr = pprStackInfo
66
67 instance Outputable CmmTopInfo where
68 ppr = pprTopInfo
69
70
71 instance Outputable (CmmNode e x) where
72 ppr = pprNode
73
74 instance Outputable Convention where
75 ppr = pprConvention
76
77 instance Outputable ForeignConvention where
78 ppr = pprForeignConvention
79
80 instance Outputable ForeignTarget where
81 ppr = pprForeignTarget
82
83 instance Outputable CmmReturnInfo where
84 ppr = pprReturnInfo
85
86 instance Outputable (Block CmmNode C C) where
87 ppr = pprBlock
88 instance Outputable (Block CmmNode C O) where
89 ppr = pprBlock
90 instance Outputable (Block CmmNode O C) where
91 ppr = pprBlock
92 instance Outputable (Block CmmNode O O) where
93 ppr = pprBlock
94
95 instance Outputable (Graph CmmNode e x) where
96 ppr = pprGraph
97
98 instance Outputable CmmGraph where
99 ppr = pprCmmGraph
100
101 ----------------------------------------------------------
102 -- Outputting types Cmm contains
103
104 pprStackInfo :: CmmStackInfo -> SDoc
105 pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
106 text "arg_space: " <> ppr arg_space <+>
107 text "updfr_space: " <> ppr updfr_space
108
109 pprTopInfo :: CmmTopInfo -> SDoc
110 pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
111 vcat [text "info_tbl: " <> ppr info_tbl,
112 text "stack_info: " <> ppr stack_info]
113
114 ----------------------------------------------------------
115 -- Outputting blocks and graphs
116
117 pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
118 => Block CmmNode e x -> IndexedCO e SDoc SDoc
119 pprBlock block
120 = foldBlockNodesB3 ( ($$) . ppr
121 , ($$) . (nest 4) . ppr
122 , ($$) . (nest 4) . ppr
123 )
124 block
125 empty
126
127 pprGraph :: Graph CmmNode e x -> SDoc
128 pprGraph GNil = empty
129 pprGraph (GUnit block) = ppr block
130 pprGraph (GMany entry body exit)
131 = text "{"
132 $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
133 $$ text "}"
134 where pprMaybeO :: Outputable (Block CmmNode e x)
135 => MaybeO ex (Block CmmNode e x) -> SDoc
136 pprMaybeO NothingO = empty
137 pprMaybeO (JustO block) = ppr block
138
139 pprCmmGraph :: CmmGraph -> SDoc
140 pprCmmGraph g
141 = text "{" <> text "offset"
142 $$ nest 2 (vcat $ map ppr blocks)
143 $$ text "}"
144 where blocks = postorderDfs g
145 -- postorderDfs has the side-effect of discarding unreachable code,
146 -- so pretty-printed Cmm will omit any unreachable blocks. This can
147 -- sometimes be confusing.
148
149 ---------------------------------------------
150 -- Outputting CmmNode and types which it contains
151
152 pprConvention :: Convention -> SDoc
153 pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
154 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
155 pprConvention (NativeReturn {}) = text "<native-ret-convention>"
156 pprConvention Slow = text "<slow-convention>"
157 pprConvention GC = text "<gc-convention>"
158
159 pprForeignConvention :: ForeignConvention -> SDoc
160 pprForeignConvention (ForeignConvention c args res ret) =
161 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
162
163 pprReturnInfo :: CmmReturnInfo -> SDoc
164 pprReturnInfo CmmMayReturn = empty
165 pprReturnInfo CmmNeverReturns = text "never returns"
166
167 pprForeignTarget :: ForeignTarget -> SDoc
168 pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
169 where
170 ppr_target :: CmmExpr -> SDoc
171 ppr_target t@(CmmLit _) = ppr t
172 ppr_target fn' = parens (ppr fn')
173
174 pprForeignTarget (PrimTarget op)
175 -- HACK: We're just using a ForeignLabel to get this printed, the label
176 -- might not really be foreign.
177 = ppr
178 (CmmLabel (mkForeignLabel
179 (mkFastString (show op))
180 Nothing ForeignLabelInThisPackage IsFunction))
181
182 pprNode :: CmmNode e x -> SDoc
183 pprNode node = pp_node <+> pp_debug
184 where
185 pp_node :: SDoc
186 pp_node = sdocWithDynFlags $ \dflags -> case node of
187 -- label:
188 CmmEntry id tscope -> ppr id <> colon <+>
189 (sdocWithDynFlags $ \dflags ->
190 ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
191
192 -- // text
193 CmmComment s -> text "//" <+> ftext s
194
195 -- //tick bla<...>
196 CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
197 text "//tick" <+> ppr t
198
199 -- unwind reg = expr;
200 CmmUnwind regs ->
201 text "unwind "
202 <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
203
204 -- reg = expr;
205 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
206
207 -- rep[lv] = expr;
208 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
209 where
210 rep = sdocWithDynFlags $ \dflags ->
211 ppr ( cmmExprType dflags expr )
212
213 -- call "ccall" foo(x, y)[r1, r2];
214 -- ToDo ppr volatile
215 CmmUnsafeForeignCall target results args ->
216 hsep [ ppUnless (null results) $
217 parens (commafy $ map ppr results) <+> equals,
218 text "call",
219 ppr target <> parens (commafy $ map ppr args) <> semi]
220
221 -- goto label;
222 CmmBranch ident -> text "goto" <+> ppr ident <> semi
223
224 -- if (expr) goto t; else goto f;
225 CmmCondBranch expr t f l ->
226 hsep [ text "if"
227 , parens(ppr expr)
228 , case l of
229 Nothing -> empty
230 Just b -> parens (text "likely:" <+> ppr b)
231 , text "goto"
232 , ppr t <> semi
233 , text "else goto"
234 , ppr f <> semi
235 ]
236
237 CmmSwitch expr ids ->
238 hang (hsep [ text "switch"
239 , range
240 , if isTrivialCmmExpr expr
241 then ppr expr
242 else parens (ppr expr)
243 , text "{"
244 ])
245 4 (vcat (map ppCase cases) $$ def) $$ rbrace
246 where
247 (cases, mbdef) = switchTargetsFallThrough ids
248 ppCase (is,l) = hsep
249 [ text "case"
250 , commafy $ map integer is
251 , text ": goto"
252 , ppr l <> semi
253 ]
254 def | Just l <- mbdef = hsep
255 [ text "default: goto"
256 , ppr l <> semi
257 ]
258 | otherwise = empty
259
260 range = brackets $ hsep [integer lo, text "..", integer hi]
261 where (lo,hi) = switchTargetsRange ids
262
263 CmmCall tgt k regs out res updfr_off ->
264 hcat [ text "call", space
265 , pprFun tgt, parens (interpp'SP regs), space
266 , returns <+>
267 text "args: " <> ppr out <> comma <+>
268 text "res: " <> ppr res <> comma <+>
269 text "upd: " <> ppr updfr_off
270 , semi ]
271 where pprFun f@(CmmLit _) = ppr f
272 pprFun f = parens (ppr f)
273
274 returns
275 | Just r <- k = text "returns to" <+> ppr r <> comma
276 | otherwise = empty
277
278 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
279 hcat $ if i then [text "interruptible", space] else [] ++
280 [ text "foreign call", space
281 , ppr t, text "(...)", space
282 , text "returns to" <+> ppr s
283 <+> text "args:" <+> parens (ppr as)
284 <+> text "ress:" <+> parens (ppr rs)
285 , text "ret_args:" <+> ppr a
286 , text "ret_off:" <+> ppr u
287 , semi ]
288
289 pp_debug :: SDoc
290 pp_debug =
291 if not debugIsOn then empty
292 else case node of
293 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
294 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
295 CmmTick {} -> empty
296 CmmUnwind {} -> text " // CmmUnwind"
297 CmmAssign {} -> text " // CmmAssign"
298 CmmStore {} -> text " // CmmStore"
299 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
300 CmmBranch {} -> text " // CmmBranch"
301 CmmCondBranch {} -> text " // CmmCondBranch"
302 CmmSwitch {} -> text " // CmmSwitch"
303 CmmCall {} -> text " // CmmCall"
304 CmmForeignCall {} -> text " // CmmForeignCall"
305
306 commafy :: [SDoc] -> SDoc
307 commafy xs = hsep $ punctuate comma xs