Merge branch 'coloured-core' of https://github.com/nominolo/ghc into coloured-core
[ghc.git] / compiler / cmm / CmmNode.hs
1 -- CmmNode type for representation using Hoopl graphs.
2 {-# LANGUAGE GADTs #-}
3
4 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
5 #if __GLASGOW_HASKELL__ >= 701
6 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
7 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
8 #endif
9
10 module CmmNode
11 ( CmmNode(..)
12 , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
13 , mapExp, mapExpDeep, foldExp, foldExpDeep
14 )
15 where
16
17 import CmmExpr
18 import CmmDecl
19 import FastString
20 import ForeignCall
21 import SMRep
22
23 import Compiler.Hoopl
24 import Data.Maybe
25 import Prelude hiding (succ)
26
27
28 ------------------------
29 -- CmmNode
30
31 data CmmNode e x where
32 CmmEntry :: Label -> CmmNode C O
33 CmmComment :: FastString -> CmmNode O O
34 CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register
35 CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is
36 -- given by cmmExprType of the rhs.
37 CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls]
38 ForeignTarget -> -- call target
39 CmmFormals -> -- zero or more results
40 CmmActuals -> -- zero or more arguments
41 CmmNode O O
42 CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
43 CmmCondBranch :: { -- conditional branch
44 cml_pred :: CmmExpr,
45 cml_true, cml_false :: Label
46 } -> CmmNode O C
47 CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
48 -- The scrutinee is zero-based;
49 -- zero -> first block
50 -- one -> second block etc
51 -- Undefined outside range, and when there's a Nothing
52 CmmCall :: { -- A call (native or safe foreign)
53 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
54
55 cml_cont :: Maybe Label,
56 -- Label of continuation (Nothing for return or tail call)
57
58 cml_args :: ByteOff,
59 -- Byte offset, from the *old* end of the Area associated with
60 -- the Label (if cml_cont = Nothing, then Old area), of
61 -- youngest outgoing arg. Set the stack pointer to this before
62 -- transferring control.
63 -- (NB: an update frame might also have been stored in the Old
64 -- area, but it'll be in an older part than the args.)
65
66 cml_ret_args :: ByteOff,
67 -- For calls *only*, the byte offset for youngest returned value
68 -- This is really needed at the *return* point rather than here
69 -- at the call, but in practice it's convenient to record it here.
70
71 cml_ret_off :: ByteOff
72 -- For calls *only*, the byte offset of the base of the frame that
73 -- must be described by the info table for the return point.
74 -- The older words are an update frames, which have their own
75 -- info-table and layout information
76
77 -- From a liveness point of view, the stack words older than
78 -- cml_ret_off are treated as live, even if the sequel of
79 -- the call goes into a loop.
80 } -> CmmNode O C
81 CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
82 tgt :: ForeignTarget, -- call target and convention
83 res :: CmmFormals, -- zero or more results
84 args :: CmmActuals, -- zero or more arguments
85 succ :: Label, -- Label of continuation
86 updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
87 intrbl:: Bool -- whether or not the call is interruptible
88 } -> CmmNode O C
89
90 {- Note [Foreign calls]
91 ~~~~~~~~~~~~~~~~~~~~~~~
92 A MidForeign call is used for *unsafe* foreign calls;
93 a LastForeign call is used for *safe* foreign calls.
94 Unsafe ones are easy: think of them as a "fat machine instruction".
95 In particular, they do *not* kill all live registers (there was a bit
96 of code in GHC that conservatively assumed otherwise.)
97
98 Safe ones are trickier. A safe foreign call
99 r = f(x)
100 ultimately expands to
101 push "return address" -- Never used to return to;
102 -- just points an info table
103 save registers into TSO
104 call suspendThread
105 r = f(x) -- Make the call
106 call resumeThread
107 restore registers
108 pop "return address"
109 We cannot "lower" a safe foreign call to this sequence of Cmms, because
110 after we've saved Sp all the Cmm optimiser's assumptions are broken.
111 Furthermore, currently the smart Cmm constructors know the calling
112 conventions for Haskell, the garbage collector, etc, and "lower" them
113 so that a LastCall passes no parameters or results. But the smart
114 constructors do *not* (currently) know the foreign call conventions.
115
116 Note that a safe foreign call needs an info table.
117 -}
118
119 ---------------------------------------------
120 -- Eq instance of CmmNode
121 -- It is a shame GHC cannot infer it by itself :(
122
123 instance Eq (CmmNode e x) where
124 (CmmEntry a) == (CmmEntry a') = a==a'
125 (CmmComment a) == (CmmComment a') = a==a'
126 (CmmAssign a b) == (CmmAssign a' b') = a==a' && b==b'
127 (CmmStore a b) == (CmmStore a' b') = a==a' && b==b'
128 (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
129 (CmmBranch a) == (CmmBranch a') = a==a'
130 (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c'
131 (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b'
132 (CmmCall a b c d e) == (CmmCall a' b' c' d' e') = a==a' && b==b' && c==c' && d==d' && e==e'
133 (CmmForeignCall a b c d e f) == (CmmForeignCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f'
134 _ == _ = False
135
136 ----------------------------------------------
137 -- Hoopl instances of CmmNode
138
139 instance NonLocal CmmNode where
140 entryLabel (CmmEntry l) = l
141
142 successors (CmmBranch l) = [l]
143 successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
144 successors (CmmSwitch _ ls) = catMaybes ls
145 successors (CmmCall {cml_cont=l}) = maybeToList l
146 successors (CmmForeignCall {succ=l}) = [l]
147
148
149 instance HooplNode CmmNode where
150 mkBranchNode label = CmmBranch label
151 mkLabelNode label = CmmEntry label
152
153 --------------------------------------------------
154 -- Various helper types
155
156 type UpdFrameOffset = ByteOff
157
158 data Convention
159 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
160 | NativeNodeCall -- Native C-- call including the node argument
161 | NativeReturn -- Native C-- return
162 | Slow -- Slow entry points: all args pushed on the stack
163 | GC -- Entry to the garbage collector: uses the node reg!
164 | PrimOpCall -- Calling prim ops
165 | PrimOpReturn -- Returning from prim ops
166 | Foreign -- Foreign call/return
167 ForeignConvention
168 | Private
169 -- Used for control transfers within a (pre-CPS) procedure All
170 -- jump sites known, never pushed on the stack (hence no SRT)
171 -- You can choose whatever calling convention you please
172 -- (provided you make sure all the call sites agree)!
173 -- This data type eventually to be extended to record the convention.
174 deriving( Eq )
175
176 data ForeignConvention
177 = ForeignConvention
178 CCallConv -- Which foreign-call convention
179 [ForeignHint] -- Extra info about the args
180 [ForeignHint] -- Extra info about the result
181 deriving Eq
182
183 data ForeignTarget -- The target of a foreign call
184 = ForeignTarget -- A foreign procedure
185 CmmExpr -- Its address
186 ForeignConvention -- Its calling convention
187 | PrimTarget -- A possibly-side-effecting machine operation
188 CallishMachOp -- Which one
189 deriving Eq
190
191 --------------------------------------------------
192 -- Instances of register and slot users / definers
193
194 instance UserOfLocalRegs (CmmNode e x) where
195 foldRegsUsed f z n = case n of
196 CmmAssign _ expr -> fold f z expr
197 CmmStore addr rval -> fold f (fold f z addr) rval
198 CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
199 CmmCondBranch expr _ _ -> fold f z expr
200 CmmSwitch expr _ -> fold f z expr
201 CmmCall {cml_target=tgt} -> fold f z tgt
202 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
203 _ -> z
204 where fold :: forall a b.
205 UserOfLocalRegs a =>
206 (b -> LocalReg -> b) -> b -> a -> b
207 fold f z n = foldRegsUsed f z n
208
209 instance UserOfLocalRegs ForeignTarget where
210 foldRegsUsed _f z (PrimTarget _) = z
211 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
212
213 instance DefinerOfLocalRegs (CmmNode e x) where
214 foldRegsDefd f z n = case n of
215 CmmAssign lhs _ -> fold f z lhs
216 CmmUnsafeForeignCall _ fs _ -> fold f z fs
217 CmmForeignCall {res=res} -> fold f z res
218 _ -> z
219 where fold :: forall a b.
220 DefinerOfLocalRegs a =>
221 (b -> LocalReg -> b) -> b -> a -> b
222 fold f z n = foldRegsDefd f z n
223
224
225 instance UserOfSlots (CmmNode e x) where
226 foldSlotsUsed f z n = case n of
227 CmmAssign _ expr -> fold f z expr
228 CmmStore addr rval -> fold f (fold f z addr) rval
229 CmmUnsafeForeignCall _ _ args -> fold f z args
230 CmmCondBranch expr _ _ -> fold f z expr
231 CmmSwitch expr _ -> fold f z expr
232 CmmCall {cml_target=tgt} -> fold f z tgt
233 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
234 _ -> z
235 where fold :: forall a b.
236 UserOfSlots a =>
237 (b -> SubArea -> b) -> b -> a -> b
238 fold f z n = foldSlotsUsed f z n
239
240 instance UserOfSlots ForeignTarget where
241 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
242 foldSlotsUsed _f z (PrimTarget _) = z
243
244 instance DefinerOfSlots (CmmNode e x) where
245 foldSlotsDefd f z n = case n of
246 CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
247 CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
248 _ -> z
249 where
250 fold :: forall a b.
251 DefinerOfSlots a =>
252 (b -> SubArea -> b) -> b -> a -> b
253 fold f z n = foldSlotsDefd f z n
254 foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
255
256 -----------------------------------
257 -- mapping Expr in CmmNode
258
259 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
260 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
261 mapForeignTarget _ m@(PrimTarget _) = m
262
263 -- Take a transformer on expressions and apply it recursively.
264 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
265 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
266 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
267 wrapRecExp f e = f e
268
269 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
270 mapExp _ f@(CmmEntry _) = f
271 mapExp _ m@(CmmComment _) = m
272 mapExp f (CmmAssign r e) = CmmAssign r (f e)
273 mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
274 mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
275 mapExp _ l@(CmmBranch _) = l
276 mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
277 mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
278 mapExp f (CmmCall tgt mb_id o i s) = CmmCall (f tgt) mb_id o i s
279 mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
280
281 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
282 mapExpDeep f = mapExp $ wrapRecExp f
283
284 -----------------------------------
285 -- folding Expr in CmmNode
286
287 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
288 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
289 foldExpForeignTarget _ (PrimTarget _) z = z
290
291 -- Take a folder on expressions and apply it recursively.
292 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
293 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
294 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
295 wrapRecExpf f e z = f e z
296
297 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
298 foldExp _ (CmmEntry {}) z = z
299 foldExp _ (CmmComment {}) z = z
300 foldExp f (CmmAssign _ e) z = f e z
301 foldExp f (CmmStore addr e) z = f addr $ f e z
302 foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
303 foldExp _ (CmmBranch _) z = z
304 foldExp f (CmmCondBranch e _ _) z = f e z
305 foldExp f (CmmSwitch e _) z = f e z
306 foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
307 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
308
309 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
310 foldExpDeep f = foldExp $ wrapRecExpf f