1 -- CmmNode type for representation using Hoopl graphs.
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 #-}
12 , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
13 , mapExp, mapExpDeep, foldExp, foldExpDeep
25 import Prelude hiding (succ)
28 ------------------------
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
42 CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
43 CmmCondBranch :: { -- conditional branch
45 cml_true, cml_false :: Label
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!
55 cml_cont :: Maybe Label,
56 -- Label of continuation (Nothing for return or tail call)
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.)
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.
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
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.
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
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.)
98 Safe ones are trickier. A safe foreign call
100 ultimately expands to
101 push "return address" -- Never used to return to;
102 -- just points an info table
103 save registers into TSO
105 r = f(x) -- Make the call
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.
116 Note that a safe foreign call needs an info table.
119 ---------------------------------------------
120 -- Eq instance of CmmNode
121 -- It is a shame GHC cannot infer it by itself :(
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'
136 ----------------------------------------------
137 -- Hoopl instances of CmmNode
139 instance NonLocal CmmNode where
140 entryLabel (CmmEntry l) = l
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]
149 instance HooplNode CmmNode where
150 mkBranchNode label = CmmBranch label
151 mkLabelNode label = CmmEntry label
153 --------------------------------------------------
154 -- Various helper types
156 type UpdFrameOffset = ByteOff
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
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.
176 data ForeignConvention
178 CCallConv -- Which foreign-call convention
179 [ForeignHint] -- Extra info about the args
180 [ForeignHint] -- Extra info about the result
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
191 --------------------------------------------------
192 -- Instances of register and slot users / definers
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
204 where fold :: forall a b.
206 (b -> LocalReg -> b) -> b -> a -> b
207 fold f z n = foldRegsUsed f z n
209 instance UserOfLocalRegs ForeignTarget where
210 foldRegsUsed _f z (PrimTarget _) = z
211 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
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
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
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
235 where fold :: forall a b.
237 (b -> SubArea -> b) -> b -> a -> b
238 fold f z n = foldSlotsUsed f z n
240 instance UserOfSlots ForeignTarget where
241 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
242 foldSlotsUsed _f z (PrimTarget _) = z
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
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)
256 -----------------------------------
257 -- mapping Expr in CmmNode
259 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
260 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
261 mapForeignTarget _ m@(PrimTarget _) = m
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)
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
281 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
282 mapExpDeep f = mapExp $ wrapRecExp f
284 -----------------------------------
285 -- folding Expr in CmmNode
287 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
288 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
289 foldExpForeignTarget _ (PrimTarget _) z = z
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
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
309 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
310 foldExpDeep f = foldExp $ wrapRecExpf f