remove remaining redundancies from ZipCfgCmmRep
[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, CmmFormals
19 , CmmStmt(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 ----------------------------------------------------------------------
37 ----- Type synonyms and definitions
38
39 type CmmGraph = LGraph Middle Last
40 type CmmAGraph = AGraph Middle Last
41 type CmmBlock = Block Middle Last
42 type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
43 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
44
45 data Middle
46 = MidNop
47 | MidComment FastString
48
49 | MidAssign CmmReg CmmExpr -- Assign to register
50
51 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
52 -- given by cmmExprRep of the rhs.
53
54 | MidUnsafeCall -- An "unsafe" foreign call;
55 CmmCallTarget -- just a fat machine instructoin
56 CmmFormals -- zero or more results
57 CmmActuals -- zero or more arguments
58
59 | CopyIn -- Move incoming parameters or results from conventional
60 -- locations to registers. Note [CopyIn invariant]
61 Convention
62 CmmFormals -- eventually [CmmKind] will be used only for foreign
63 -- calls and will migrate into 'Convention' (helping to
64 -- drain "the swamp"), leaving this as [LocalReg]
65 C_SRT -- Static things kept alive by this block
66
67 | CopyOut Convention CmmActuals
68 -- Move outgoing parameters or results from registers to
69 -- conventional locations. Every 'LastReturn',
70 -- 'LastJump', or 'LastCall' must be dominated by a
71 -- matching 'CopyOut' in the same basic block.
72 -- As above, '[CmmKind]' will migrate into the foreign calling
73 -- convention, leaving the actuals as '[CmmExpr]'.
74
75 data Last
76 = LastBranch BlockId -- Goto another block in the same procedure
77
78 | LastCondBranch { -- conditional branch
79 cml_pred :: CmmExpr,
80 cml_true, cml_false :: BlockId
81 }
82
83 | LastReturn -- Return from a function; values in a previous CopyOut node
84
85 | LastJump CmmExpr -- Tail call to another procedure; args in a CopyOut node
86
87 | LastCall { -- A call (native or safe foreign)
88 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
89 cml_cont :: Maybe BlockId } -- BlockId of continuation, if call returns
90
91 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
92 -- The scrutinee is zero-based;
93 -- zero -> first block
94 -- one -> second block etc
95 -- Undefined outside range, and when there's a Nothing
96
97 data Convention
98 = ConventionStandard CCallConv ValueDirection
99 | ConventionPrivate
100 -- Used for control transfers within a (pre-CPS) procedure All
101 -- jump sites known, never pushed on the stack (hence no SRT)
102 -- You can choose whatever calling convention you please
103 -- (provided you make sure all the call sites agree)!
104 -- This data type eventually to be extended to record the convention.
105
106 deriving Eq
107
108 data ValueDirection = Arguments | Results
109 -- Arguments go with procedure definitions, jumps, and arguments to calls
110 -- Results go with returns and with results of calls.
111 deriving Eq
112
113 {-
114 Note [CopyIn invariant]
115 ~~~~~~~~~~~~~~~~~~~~~~~
116 One might wish for CopyIn to be a First node, but in practice, the
117 possibility raises all sorts of hairy issues with graph splicing,
118 rewriting, and so on. In the end, NR finds it better to make the
119 placement of CopyIn a dynamic invariant; it should normally be the first
120 Middle node in the basic block in which it occurs.
121 -}
122
123 ----------------------------------------------------------------------
124 ----- Instance declarations for control flow
125
126 instance HavingSuccessors Last where
127 succs = cmmSuccs
128 fold_succs = fold_cmm_succs
129
130 instance LastNode Last where
131 mkBranchNode id = LastBranch id
132 isBranchNode (LastBranch _) = True
133 isBranchNode _ = False
134 branchNodeTarget (LastBranch id) = id
135 branchNodeTarget _ = panic "asked for target of non-branch"
136
137 cmmSuccs :: Last -> [BlockId]
138 cmmSuccs (LastReturn {}) = []
139 cmmSuccs (LastJump {}) = []
140 cmmSuccs (LastBranch id) = [id]
141 cmmSuccs (LastCall _ (Just id)) = [id]
142 cmmSuccs (LastCall _ Nothing) = []
143 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
144 cmmSuccs (LastSwitch _ edges) = catMaybes edges
145
146 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
147 fold_cmm_succs _f (LastReturn {}) z = z
148 fold_cmm_succs _f (LastJump {}) z = z
149 fold_cmm_succs f (LastBranch id) z = f id z
150 fold_cmm_succs f (LastCall _ (Just id)) z = f id z
151 fold_cmm_succs _f (LastCall _ Nothing) z = z
152 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
153 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
154
155
156 ----------------------------------------------------------------------
157 ----- Instance declarations for prettyprinting (avoids recursive imports)
158
159 instance Outputable Middle where
160 ppr s = pprMiddle s
161
162 instance Outputable Last where
163 ppr s = pprLast s
164
165 instance Outputable Convention where
166 ppr = pprConvention
167
168 instance DF.DebugNodes Middle Last
169
170 instance Outputable CmmGraph where
171 ppr = pprLgraph
172
173 debugPpr :: Bool
174 debugPpr = debugIsOn
175
176 pprMiddle :: Middle -> SDoc
177 pprMiddle stmt = (case stmt of
178
179 MidNop -> semi
180
181 CopyIn conv args _ ->
182 if null args then ptext SLIT("empty CopyIn")
183 else commafy (map pprHinted args) <+> equals <+>
184 ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
185
186 CopyOut conv args ->
187 ptext SLIT("next, pass") <+> doubleQuotes(ppr conv) <+>
188 parens (commafy (map pprHinted args))
189
190 -- // text
191 MidComment s -> text "//" <+> ftext s
192
193 -- reg = expr;
194 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
195
196 -- rep[lv] = expr;
197 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
198 where
199 rep = ppr ( cmmExprRep expr )
200
201 -- call "ccall" foo(x, y)[r1, r2];
202 -- ToDo ppr volatile
203 MidUnsafeCall (CmmCallee fn cconv) results args ->
204 hcat [ if null results
205 then empty
206 else parens (commafy $ map ppr results) <>
207 ptext SLIT(" = "),
208 ptext SLIT("call"), space,
209 doubleQuotes(ppr cconv), space,
210 target fn, parens ( commafy $ map ppr args ),
211 semi ]
212 where
213 target t@(CmmLit _) = ppr t
214 target fn' = parens (ppr fn')
215
216 MidUnsafeCall (CmmPrim op) results args ->
217 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
218 where
219 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
220 ) <>
221 if debugPpr then empty
222 else text " //" <+>
223 case stmt of
224 MidNop {} -> text "MidNop"
225 CopyIn {} -> text "CopyIn"
226 CopyOut {} -> text "CopyOut"
227 MidComment {} -> text "MidComment"
228 MidAssign {} -> text "MidAssign"
229 MidStore {} -> text "MidStore"
230 MidUnsafeCall {} -> text "MidUnsafeCall"
231
232
233 pprHinted :: Outputable a => (a, MachHint) -> SDoc
234 pprHinted (a, NoHint) = ppr a
235 pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a
236 pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a
237 pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a
238
239 pprLast :: Last -> SDoc
240 pprLast stmt = (case stmt of
241 LastBranch ident -> ptext SLIT("goto") <+> ppr ident <> semi
242 LastCondBranch expr t f -> genFullCondBranch expr t f
243 LastJump expr -> hcat [ ptext SLIT("jump"), space, pprFun expr
244 , ptext SLIT("(...)"), semi]
245 LastReturn -> hcat [ ptext SLIT("return"), space
246 , ptext SLIT("(...)"), semi]
247 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
248 LastCall tgt k -> genBareCall tgt k
249 ) <>
250 if debugPpr then empty
251 else text " //" <+>
252 case stmt of
253 LastBranch {} -> text "LastBranch"
254 LastCondBranch {} -> text "LastCondBranch"
255 LastJump {} -> text "LastJump"
256 LastReturn {} -> text "LastReturn"
257 LastSwitch {} -> text "LastSwitch"
258 LastCall {} -> text "LastCall"
259
260 genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
261 genBareCall fn k =
262 hcat [ ptext SLIT("call"), space
263 , pprFun fn, ptext SLIT("(...)"), space
264 , case k of Nothing -> ptext SLIT("never returns")
265 Just k -> ptext SLIT("returns to") <+> ppr k
266 , semi ]
267 where
268
269 pprFun :: CmmExpr -> SDoc
270 pprFun f@(CmmLit _) = ppr f
271 pprFun f = parens (ppr f)
272
273 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
274 genFullCondBranch expr t f =
275 hsep [ ptext SLIT("if")
276 , parens(ppr expr)
277 , ptext SLIT("goto")
278 , ppr t <> semi
279 , ptext SLIT("else goto")
280 , ppr f <> semi
281 ]
282
283 pprConvention :: Convention -> SDoc
284 pprConvention (ConventionStandard c _) = ppr c
285 pprConvention (ConventionPrivate {} ) = text "<private-convention>"
286
287 commafy :: [SDoc] -> SDoc
288 commafy xs = hsep $ punctuate comma xs