135a219e8d02d714c777466ab9e5d347d8f12b84
[ghc.git] / compiler / cmm / ZipCfgCmmRep.hs
1
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 , ValueDirection(..)
11 )
12 where
13
14 #include "HsVersions.h"
15
16 import CmmExpr
17 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
18 , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
19 , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
20 )
21 import PprCmm()
22
23 import CLabel
24 import ClosureInfo
25 import FastString
26 import ForeignCall
27 import MachOp
28 import qualified ZipDataflow as DF
29 import ZipCfg
30 import MkZipCfg
31
32 import Maybes
33 import Outputable
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 -- eventually [CmmKind] will be used only for foreign
60 -- calls and will migrate into 'Convention' (helping to
61 -- drain "the swamp")
62 C_SRT -- Static things kept alive by this block
63 | CopyOut Convention CmmActuals
64
65 data Last
66 = LastReturn CmmActuals -- Return from a function,
67 -- with these return values.
68
69 | LastJump CmmExpr CmmActuals
70 -- Tail call to another procedure
71
72 | LastBranch BlockId CmmFormalsWithoutKinds
73 -- To another block in the same procedure
74 -- The parameters are unused at present.
75
76 | LastCall { -- A call (native or safe foreign)
77 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
78 cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns
79
80 | LastCondBranch { -- conditional branch
81 cml_pred :: CmmExpr,
82 cml_true, cml_false :: BlockId
83 }
84
85 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
86 -- The scrutinee is zero-based;
87 -- zero -> first block
88 -- one -> second block etc
89 -- Undefined outside range, and when there's a Nothing
90
91 data Convention
92 = ConventionStandard CCallConv ValueDirection
93 | ConventionPrivate
94 -- 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 data ValueDirection = Arguments | Results
102 -- Arguments go with procedure definitions, jumps, and arguments to calls
103 -- Results go with returns and with results of calls.
104 deriving Eq
105
106 {-
107 Note [CopyIn invariant]
108 ~~~~~~~~~~~~~~~~~~~~~~~
109 In principle, CopyIn ought to be a First node, but in practice, the
110 possibility raises all sorts of hairy issues with graph splicing,
111 rewriting, and so on. In the end, NR finds it better to make the
112 placement of CopyIn a dynamic invariant. This change will complicate
113 the dataflow fact for the proc-point calculation, but it should make
114 things easier in many other respects.
115 -}
116
117 instance HavingSuccessors Last where
118 succs = cmmSuccs
119 fold_succs = fold_cmm_succs
120
121 instance LastNode Last where
122 mkBranchNode id = LastBranch id []
123 isBranchNode (LastBranch _ []) = True
124 isBranchNode _ = False
125 branchNodeTarget (LastBranch id []) = id
126 branchNodeTarget _ = panic "asked for target of non-branch"
127
128 cmmSuccs :: Last -> [BlockId]
129 cmmSuccs (LastReturn {}) = []
130 cmmSuccs (LastJump {}) = []
131 cmmSuccs (LastBranch id _) = [id]
132 cmmSuccs (LastCall _ (Just id)) = [id]
133 cmmSuccs (LastCall _ Nothing) = []
134 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
135 cmmSuccs (LastSwitch _ edges) = catMaybes edges
136
137 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
138 fold_cmm_succs _f (LastReturn {}) z = z
139 fold_cmm_succs _f (LastJump {}) z = z
140 fold_cmm_succs f (LastBranch id _) z = f id z
141 fold_cmm_succs f (LastCall _ (Just id)) z = f id z
142 fold_cmm_succs _f (LastCall _ Nothing) z = z
143 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
144 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
145
146
147 ----------------------------------------------------------------
148 -- prettyprinting (avoids recursive imports)
149
150 instance Outputable Middle where
151 ppr s = pprMiddle s
152
153 instance Outputable Last where
154 ppr s = pprLast s
155
156 instance Outputable Convention where
157 ppr = pprConvention
158
159 instance DF.DebugNodes Middle Last
160
161 instance Outputable CmmGraph where
162 ppr = pprLgraph
163
164 debugPpr :: Bool
165 debugPpr = debugIsOn
166
167 pprMiddle :: Middle -> SDoc
168 pprMiddle stmt = (case stmt of
169
170 MidNop -> semi
171
172 CopyIn conv args _ ->
173 if null args then ptext SLIT("empty CopyIn")
174 else commafy (map pprHinted args) <+> equals <+>
175 ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
176
177 CopyOut conv args ->
178 if null args then empty
179 else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
180 parens (commafy (map pprHinted args))
181
182 -- // text
183 MidComment s -> text "//" <+> ftext s
184
185 -- reg = expr;
186 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
187
188 -- rep[lv] = expr;
189 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
190 where
191 rep = ppr ( cmmExprRep expr )
192
193 -- call "ccall" foo(x, y)[r1, r2];
194 -- ToDo ppr volatile
195 MidUnsafeCall (CmmCallee fn cconv) results args ->
196 hcat [ if null results
197 then empty
198 else parens (commafy $ map ppr results) <>
199 ptext SLIT(" = "),
200 ptext SLIT("call"), space,
201 doubleQuotes(ppr cconv), space,
202 target fn, parens ( commafy $ map ppr args ),
203 semi ]
204 where
205 target t@(CmmLit _) = ppr t
206 target fn' = parens (ppr fn')
207
208 MidUnsafeCall (CmmPrim op) results args ->
209 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
210 where
211 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
212 ) <>
213 if debugPpr then empty
214 else text " //" <+>
215 case stmt of
216 MidNop {} -> text "MidNop"
217 CopyIn {} -> text "CopyIn"
218 CopyOut {} -> text "CopyOut"
219 MidComment {} -> text "MidComment"
220 MidAssign {} -> text "MidAssign"
221 MidStore {} -> text "MidStore"
222 MidUnsafeCall {} -> text "MidUnsafeCall"
223
224
225 pprHinted :: Outputable a => (a, MachHint) -> SDoc
226 pprHinted (a, NoHint) = ppr a
227 pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a
228 pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a
229 pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a
230
231 pprLast :: Last -> SDoc
232 pprLast stmt = (case stmt of
233 LastBranch ident args -> genBranchWithArgs ident args
234 LastCondBranch expr t f -> genFullCondBranch expr t f
235 LastJump expr params -> ppr $ CmmJump expr params
236 LastReturn results -> hcat [ ptext SLIT("return"), space
237 , parens ( commafy $ map pprHinted results )
238 , semi ]
239 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
240 LastCall tgt k -> genBareCall tgt k
241 ) <>
242 if debugPpr then empty
243 else text " //" <+>
244 case stmt of
245 LastBranch {} -> text "LastBranch"
246 LastCondBranch {} -> text "LastCondBranch"
247 LastJump {} -> text "LastJump"
248 LastReturn {} -> text "LastReturn"
249 LastSwitch {} -> text "LastSwitch"
250 LastCall {} -> text "LastCall"
251
252 genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
253 genBareCall fn k =
254 hcat [ ptext SLIT("foreign"), space
255 , doubleQuotes(ptext SLIT("<convention from CopyOut>")), space
256 , target fn, parens ( ptext SLIT("<parameters from CopyOut>") ), space
257 , case k of Nothing -> ptext SLIT("never returns")
258 Just k -> ptext SLIT("returns to") <+> ppr k
259 , semi ]
260 where
261 target t@(CmmLit _) = ppr t
262 target fn' = parens (ppr fn')
263
264 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
265 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
266 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
267 parens (commafy (map ppr args)) <> semi
268
269 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
270 genFullCondBranch expr t f =
271 hsep [ ptext SLIT("if")
272 , parens(ppr expr)
273 , ptext SLIT("goto")
274 , ppr t <> semi
275 , ptext SLIT("else goto")
276 , ppr f <> semi
277 ]
278
279 pprConvention :: Convention -> SDoc
280 pprConvention (ConventionStandard c _) = ppr c
281 pprConvention (ConventionPrivate {} ) = text "<private-convention>"
282
283 commafy :: [SDoc] -> SDoc
284 commafy xs = hsep $ punctuate comma xs