scrape some unused barnacles off of ZipCfg and put them into ZipCfgExtras
[ghc.git] / compiler / cmm / ZipCfgCmmRep.hs
1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
2
3 -- This module is pure representation and should be imported only by
4 -- clients that need to manipulate representation and know what
5 -- they're doing. Clients that need to create flow graphs should
6 -- instead import MkZipCfgCmm.
7
8 module ZipCfgCmmRep
9 ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
10 )
11 where
12
13 #include "HsVersions.h"
14
15 import CmmExpr
16 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
17 , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
18 , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
19 )
20 import PprCmm()
21
22 import CLabel
23 import ClosureInfo
24 import FastString
25 import ForeignCall
26 import MachOp
27 import qualified ZipDataflow as DF
28 import ZipCfg
29 import MkZipCfg
30
31 import Maybes
32 import Outputable hiding (empty)
33 import qualified Outputable as PP
34 import Prelude hiding (zip, unzip, last)
35
36 type CmmGraph = LGraph Middle Last
37 type CmmAGraph = AGraph Middle Last
38 type CmmBlock = Block Middle Last
39 type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
40 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
41
42 data Middle
43 = MidNop
44 | MidComment FastString
45
46 | MidAssign CmmReg CmmExpr -- Assign to register
47
48 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
49 -- given by cmmExprRep of the rhs.
50
51 | MidUnsafeCall -- An "unsafe" foreign call;
52 CmmCallTarget -- just a fat machine instructoin
53 CmmFormals -- zero or more results
54 CmmActuals -- zero or more arguments
55
56 | CopyIn -- Move parameters or results from conventional locations to registers
57 -- Note [CopyIn invariant]
58 Convention
59 CmmFormals
60 C_SRT -- Static things kept alive by this block
61 | CopyOut Convention CmmFormals
62
63 data Last
64 = LastReturn CmmActuals -- Return from a function,
65 -- with these return values.
66
67 | LastJump CmmExpr CmmActuals
68 -- Tail call to another procedure
69
70 | LastBranch BlockId CmmFormalsWithoutKinds
71 -- To another block in the same procedure
72 -- The parameters are unused at present.
73
74 | LastCall { -- A call (native or safe foreign)
75 cml_target :: CmmCallTarget,
76 cml_actual :: CmmActuals, -- Zero or more arguments
77 cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns
78
79 | LastCondBranch { -- conditional branch
80 cml_pred :: CmmExpr,
81 cml_true, cml_false :: BlockId
82 }
83
84 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
85 -- The scrutinee is zero-based;
86 -- zero -> first block
87 -- one -> second block etc
88 -- Undefined outside range, and when there's a Nothing
89
90 data Convention
91 = Argument CCallConv -- Used for function formal params
92 | Result CCallConv -- Used for function results
93
94 | Local -- Used for control transfers within a (pre-CPS) procedure
95 -- All jump sites known, never pushed on the stack (hence no SRT)
96 -- You can choose whatever calling convention
97 -- you please (provided you make sure
98 -- all the call sites agree)!
99 deriving Eq
100
101 -- ^ In a complete LGraph for a procedure, the [[Exit]] node should not
102 -- appear, but it is useful in a subgraph (e.g., replacement for a node).
103
104 {-
105 Note [CopyIn invariant]
106 ~~~~~~~~~~~~~~~~~~~~~~~
107 In principle, CopyIn ought to be a First node, but in practice, the
108 possibility raises all sorts of hairy issues with graph splicing,
109 rewriting, and so on. In the end, NR finds it better to make the
110 placement of CopyIn a dynamic invariant. This change will complicate
111 the dataflow fact for the proc-point calculation, but it should make
112 things easier in many other respects.
113 -}
114
115 instance HavingSuccessors Last where
116 succs = cmmSuccs
117 fold_succs = fold_cmm_succs
118
119 instance LastNode Last where
120 mkBranchNode id = LastBranch id []
121 isBranchNode (LastBranch _ []) = True
122 isBranchNode _ = False
123 branchNodeTarget (LastBranch id []) = id
124 branchNodeTarget _ = panic "asked for target of non-branch"
125
126 cmmSuccs :: Last -> [BlockId]
127 cmmSuccs (LastReturn {}) = []
128 cmmSuccs (LastJump {}) = []
129 cmmSuccs (LastBranch id _) = [id]
130 cmmSuccs (LastCall _ _ (Just id)) = [id]
131 cmmSuccs (LastCall _ _ Nothing) = []
132 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
133 cmmSuccs (LastSwitch _ edges) = catMaybes edges
134
135 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
136 fold_cmm_succs _f (LastReturn {}) z = z
137 fold_cmm_succs _f (LastJump {}) z = z
138 fold_cmm_succs f (LastBranch id _) z = f id z
139 fold_cmm_succs f (LastCall _ _ (Just id)) z = f id z
140 fold_cmm_succs _f (LastCall _ _ Nothing) z = z
141 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
142 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
143
144
145 ----------------------------------------------------------------
146 -- prettyprinting (avoids recursive imports)
147
148 instance Outputable Middle where
149 ppr s = pprMiddle s
150
151 instance Outputable Last where
152 ppr s = pprLast s
153
154 instance Outputable Convention where
155 ppr = pprConvention
156
157 instance DF.DebugNodes Middle Last
158
159 instance Outputable CmmGraph where
160 ppr = pprLgraph
161
162 pprMiddle :: Middle -> SDoc
163 pprMiddle stmt = (case stmt of
164
165 MidNop -> semi
166
167 CopyIn conv args _ ->
168 if null args then ptext SLIT("empty CopyIn")
169 else commafy (map pprHinted args) <+> equals <+>
170 ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
171
172 CopyOut conv args ->
173 if null args then PP.empty
174 else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
175 parens (commafy (map pprHinted args))
176
177 -- // text
178 MidComment s -> text "//" <+> ftext s
179
180 -- reg = expr;
181 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
182
183 -- rep[lv] = expr;
184 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
185 where
186 rep = ppr ( cmmExprRep expr )
187
188 -- call "ccall" foo(x, y)[r1, r2];
189 -- ToDo ppr volatile
190 MidUnsafeCall (CmmCallee fn cconv) results args ->
191 hcat [ if null results
192 then PP.empty
193 else parens (commafy $ map ppr results) <>
194 ptext SLIT(" = "),
195 ptext SLIT("call"), space,
196 doubleQuotes(ppr cconv), space,
197 target fn, parens ( commafy $ map ppr args ),
198 semi ]
199 where
200 target t@(CmmLit _) = ppr t
201 target fn' = parens (ppr fn')
202
203 MidUnsafeCall (CmmPrim op) results args ->
204 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
205 where
206 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
207 ) <+> text "//" <+>
208 case stmt of
209 MidNop {} -> text "MidNop"
210 CopyIn {} -> text "CopyIn"
211 CopyOut {} -> text "CopyOut"
212 MidComment {} -> text "MidComment"
213 MidAssign {} -> text "MidAssign"
214 MidStore {} -> text "MidStore"
215 MidUnsafeCall {} -> text "MidUnsafeCall"
216
217
218 pprHinted :: Outputable a => (a, MachHint) -> SDoc
219 pprHinted (a, NoHint) = ppr a
220 pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a
221 pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a
222 pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a
223
224 pprLast :: Last -> SDoc
225 pprLast stmt = (case stmt of
226 LastBranch ident args -> genBranchWithArgs ident args
227 LastCondBranch expr t f -> genFullCondBranch expr t f
228 LastJump expr params -> ppr $ CmmJump expr params
229 LastReturn results -> hcat [ ptext SLIT("return"), space
230 , parens ( commafy $ map pprHinted results )
231 , semi ]
232 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
233 LastCall tgt params k -> genCall tgt params k
234 ) <+> text "//" <+>
235 case stmt of
236 LastBranch {} -> text "LastBranch"
237 LastCondBranch {} -> text "LastCondBranch"
238 LastJump {} -> text "LastJump"
239 LastReturn {} -> text "LastReturn"
240 LastSwitch {} -> text "LastSwitch"
241 LastCall {} -> text "LastCall"
242
243
244 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
245 genCall (CmmCallee fn cconv) args k =
246 hcat [ ptext SLIT("foreign"), space
247 , doubleQuotes(ppr cconv), space
248 , target fn, parens ( commafy $ map pprHinted args ), space
249 , case k of Nothing -> ptext SLIT("never returns")
250 Just k -> ptext SLIT("returns to") <+> ppr k
251 , semi ]
252 where
253 target t@(CmmLit _) = ppr t
254 target fn' = parens (ppr fn')
255
256 genCall (CmmPrim op) args k =
257 hcat [ text "%", text (show op), parens ( commafy $ map pprHinted args ),
258 ptext SLIT("returns to"), space, ppr k,
259 semi ]
260
261 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
262 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
263 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
264 parens (commafy (map ppr args)) <> semi
265
266 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
267 genFullCondBranch expr t f =
268 hsep [ ptext SLIT("if")
269 , parens(ppr expr)
270 , ptext SLIT("goto")
271 , ppr t <> semi
272 , ptext SLIT("else goto")
273 , ppr f <> semi
274 ]
275
276 pprConvention :: Convention -> SDoc
277 pprConvention (Argument c) = ppr c
278 pprConvention (Result c) = ppr c
279 pprConvention Local = text "<local>"
280
281 commafy :: [SDoc] -> SDoc
282 commafy xs = hsep $ punctuate comma xs