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".
96 Safe ones are trickier. A safe foreign call
99 push "return address" -- Never used to return to;
100 -- just points an info table
101 save registers into TSO
103 r = f(x) -- Make the call
107 We cannot "lower" a safe foreign call to this sequence of Cmms, because
108 after we've saved Sp all the Cmm optimiser's assumptions are broken.
109 Furthermore, currently the smart Cmm constructors know the calling
110 conventions for Haskell, the garbage collector, etc, and "lower" them
111 so that a LastCall passes no parameters or results. But the smart
112 constructors do *not* (currently) know the foreign call conventions.
114 Note that a safe foreign call needs an info table.
117 ---------------------------------------------
118 -- Eq instance of CmmNode
119 -- It is a shame GHC cannot infer it by itself :(
121 instance Eq (CmmNode e x) where
122 (CmmEntry a) == (CmmEntry a') = a==a'
123 (CmmComment a) == (CmmComment a') = a==a'
124 (CmmAssign a b) == (CmmAssign a' b') = a==a' && b==b'
125 (CmmStore a b) == (CmmStore a' b') = a==a' && b==b'
126 (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
127 (CmmBranch a) == (CmmBranch a') = a==a'
128 (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c'
129 (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b'
130 (CmmCall a b c d e) == (CmmCall a' b' c' d' e') = a==a' && b==b' && c==c' && d==d' && e==e'
131 (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 ----------------------------------------------
135 -- Hoopl instances of CmmNode
137 instance NonLocal CmmNode where
138 entryLabel (CmmEntry l) = l
140 successors (CmmBranch l) = [l]
141 successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
142 successors (CmmSwitch _ ls) = catMaybes ls
143 successors (CmmCall {cml_cont=l}) = maybeToList l
144 successors (CmmForeignCall {succ=l}) = [l]
147 instance HooplNode CmmNode where
148 mkBranchNode label = CmmBranch label
149 mkLabelNode label = CmmEntry label
151 --------------------------------------------------
152 -- Various helper types
154 type UpdFrameOffset = ByteOff
157 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
158 | NativeNodeCall -- Native C-- call including the node argument
159 | NativeReturn -- Native C-- return
160 | Slow -- Slow entry points: all args pushed on the stack
161 | GC -- Entry to the garbage collector: uses the node reg!
162 | PrimOpCall -- Calling prim ops
163 | PrimOpReturn -- Returning from prim ops
164 | Foreign -- Foreign call/return
167 -- Used for control transfers within a (pre-CPS) procedure All
168 -- jump sites known, never pushed on the stack (hence no SRT)
169 -- You can choose whatever calling convention you please
170 -- (provided you make sure all the call sites agree)!
171 -- This data type eventually to be extended to record the convention.
174 data ForeignConvention
176 CCallConv -- Which foreign-call convention
177 [ForeignHint] -- Extra info about the args
178 [ForeignHint] -- Extra info about the result
181 data ForeignTarget -- The target of a foreign call
182 = ForeignTarget -- A foreign procedure
183 CmmExpr -- Its address
184 ForeignConvention -- Its calling convention
185 | PrimTarget -- A possibly-side-effecting machine operation
186 CallishMachOp -- Which one
189 --------------------------------------------------
190 -- Instances of register and slot users / definers
192 instance UserOfLocalRegs (CmmNode e x) where
193 foldRegsUsed f z n = case n of
194 CmmAssign _ expr -> fold f z expr
195 CmmStore addr rval -> fold f (fold f z addr) rval
196 CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
197 CmmCondBranch expr _ _ -> fold f z expr
198 CmmSwitch expr _ -> fold f z expr
199 CmmCall {cml_target=tgt} -> fold f z tgt
200 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
202 where fold :: forall a b.
204 (b -> LocalReg -> b) -> b -> a -> b
205 fold f z n = foldRegsUsed f z n
207 instance UserOfLocalRegs ForeignTarget where
208 foldRegsUsed _f z (PrimTarget _) = z
209 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
211 instance DefinerOfLocalRegs (CmmNode e x) where
212 foldRegsDefd f z n = case n of
213 CmmAssign lhs _ -> fold f z lhs
214 CmmUnsafeForeignCall _ fs _ -> fold f z fs
215 CmmForeignCall {res=res} -> fold f z res
217 where fold :: forall a b.
218 DefinerOfLocalRegs a =>
219 (b -> LocalReg -> b) -> b -> a -> b
220 fold f z n = foldRegsDefd f z n
223 instance UserOfSlots (CmmNode e x) where
224 foldSlotsUsed f z n = case n of
225 CmmAssign _ expr -> fold f z expr
226 CmmStore addr rval -> fold f (fold f z addr) rval
227 CmmUnsafeForeignCall _ _ args -> fold f z args
228 CmmCondBranch expr _ _ -> fold f z expr
229 CmmSwitch expr _ -> fold f z expr
230 CmmCall {cml_target=tgt} -> fold f z tgt
231 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
233 where fold :: forall a b.
235 (b -> SubArea -> b) -> b -> a -> b
236 fold f z n = foldSlotsUsed f z n
238 instance UserOfSlots ForeignTarget where
239 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
240 foldSlotsUsed _f z (PrimTarget _) = z
242 instance DefinerOfSlots (CmmNode e x) where
243 foldSlotsDefd f z n = case n of
244 CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
245 CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
250 (b -> SubArea -> b) -> b -> a -> b
251 fold f z n = foldSlotsDefd f z n
252 foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
254 -----------------------------------
255 -- mapping Expr in CmmNode
257 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
258 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
259 mapForeignTarget _ m@(PrimTarget _) = m
261 -- Take a transformer on expressions and apply it recursively.
262 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
263 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
264 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
267 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
268 mapExp _ f@(CmmEntry _) = f
269 mapExp _ m@(CmmComment _) = m
270 mapExp f (CmmAssign r e) = CmmAssign r (f e)
271 mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
272 mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
273 mapExp _ l@(CmmBranch _) = l
274 mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
275 mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
276 mapExp f (CmmCall tgt mb_id o i s) = CmmCall (f tgt) mb_id o i s
277 mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
279 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
280 mapExpDeep f = mapExp $ wrapRecExp f
282 -----------------------------------
283 -- folding Expr in CmmNode
285 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
286 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
287 foldExpForeignTarget _ (PrimTarget _) z = z
289 -- Take a folder on expressions and apply it recursively.
290 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
291 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
292 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
293 wrapRecExpf f e z = f e z
295 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
296 foldExp _ (CmmEntry {}) z = z
297 foldExp _ (CmmComment {}) z = z
298 foldExp f (CmmAssign _ e) z = f e z
299 foldExp f (CmmStore addr e) z = f addr $ f e z
300 foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
301 foldExp _ (CmmBranch _) z = z
302 foldExp f (CmmCondBranch e _ _) z = f e z
303 foldExp f (CmmSwitch e _) z = f e z
304 foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
305 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
307 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
308 foldExpDeep f = foldExp $ wrapRecExpf f