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
34 CmmComment :: FastString -> CmmNode O O
36 CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register
38 CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is
39 -- given by cmmExprType of the rhs.
41 CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls]
42 -- Like a "fat machine instruction"; can occur
43 -- in the middle of a block
44 ForeignTarget -> -- call target
45 CmmFormals -> -- zero or more results
46 CmmActuals -> -- zero or more arguments
48 -- Semantics: kills only result regs; all other regs (both GlobalReg
49 -- and LocalReg) are preserved
51 CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
53 CmmCondBranch :: { -- conditional branch
55 cml_true, cml_false :: Label
58 CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
59 -- The scrutinee is zero-based;
60 -- zero -> first block
61 -- one -> second block etc
62 -- Undefined outside range, and when there's a Nothing
64 CmmCall :: { -- A native call or tail call
65 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
67 cml_cont :: Maybe Label,
68 -- Label of continuation (Nothing for return or tail call)
71 -- cml_args_regs :: [GlobalReg],
72 -- It says which GlobalRegs are live for the parameters at the
73 -- moment of the call. Later stages can use this to give liveness
74 -- everywhere, which in turn guides register allocation.
75 -- It is the companion of cml_args; cml_args says which stack words
76 -- hold parameters, while cml_arg_regs says which global regs hold parameters
79 -- Byte offset, from the *old* end of the Area associated with
80 -- the Label (if cml_cont = Nothing, then Old area), of
81 -- youngest outgoing arg. Set the stack pointer to this before
82 -- transferring control.
83 -- (NB: an update frame might also have been stored in the Old
84 -- area, but it'll be in an older part than the args.)
86 cml_ret_args :: ByteOff,
87 -- For calls *only*, the byte offset for youngest returned value
88 -- This is really needed at the *return* point rather than here
89 -- at the call, but in practice it's convenient to record it here.
91 cml_ret_off :: ByteOff
92 -- For calls *only*, the byte offset of the base of the frame that
93 -- must be described by the info table for the return point.
94 -- The older words are an update frames, which have their own
95 -- info-table and layout information
97 -- From a liveness point of view, the stack words older than
98 -- cml_ret_off are treated as live, even if the sequel of
99 -- the call goes into a loop.
102 CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
103 -- Always the last node of a block
104 tgt :: ForeignTarget, -- call target and convention
105 res :: CmmFormals, -- zero or more results
106 args :: CmmActuals, -- zero or more arguments
107 succ :: Label, -- Label of continuation
108 updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
109 intrbl:: Bool -- whether or not the call is interruptible
112 {- Note [Foreign calls]
113 ~~~~~~~~~~~~~~~~~~~~~~~
114 A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
115 a CmmForeignCall call is used for *safe* foreign calls.
116 Unsafe ones are easy: think of them as a "fat machine instruction".
117 In particular, they do *not* kill all live registers (there was a bit
118 of code in GHC that conservatively assumed otherwise.)
120 Safe ones are trickier. A safe foreign call
122 ultimately expands to
123 push "return address" -- Never used to return to;
124 -- just points an info table
125 save registers into TSO
127 r = f(x) -- Make the call
131 We cannot "lower" a safe foreign call to this sequence of Cmms, because
132 after we've saved Sp all the Cmm optimiser's assumptions are broken.
133 Furthermore, currently the smart Cmm constructors know the calling
134 conventions for Haskell, the garbage collector, etc, and "lower" them
135 so that a LastCall passes no parameters or results. But the smart
136 constructors do *not* (currently) know the foreign call conventions.
138 Note that a safe foreign call needs an info table.
141 ---------------------------------------------
142 -- Eq instance of CmmNode
143 -- It is a shame GHC cannot infer it by itself :(
145 instance Eq (CmmNode e x) where
146 (CmmEntry a) == (CmmEntry a') = a==a'
147 (CmmComment a) == (CmmComment a') = a==a'
148 (CmmAssign a b) == (CmmAssign a' b') = a==a' && b==b'
149 (CmmStore a b) == (CmmStore a' b') = a==a' && b==b'
150 (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
151 (CmmBranch a) == (CmmBranch a') = a==a'
152 (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c'
153 (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b'
154 (CmmCall a b c d e) == (CmmCall a' b' c' d' e') = a==a' && b==b' && c==c' && d==d' && e==e'
155 (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'
158 ----------------------------------------------
159 -- Hoopl instances of CmmNode
161 instance NonLocal CmmNode where
162 entryLabel (CmmEntry l) = l
164 successors (CmmBranch l) = [l]
165 successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
166 successors (CmmSwitch _ ls) = catMaybes ls
167 successors (CmmCall {cml_cont=l}) = maybeToList l
168 successors (CmmForeignCall {succ=l}) = [l]
171 instance HooplNode CmmNode where
172 mkBranchNode label = CmmBranch label
173 mkLabelNode label = CmmEntry label
175 --------------------------------------------------
176 -- Various helper types
178 type UpdFrameOffset = ByteOff
181 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
182 | NativeNodeCall -- Native C-- call including the node argument
183 | NativeReturn -- Native C-- return
184 | Slow -- Slow entry points: all args pushed on the stack
185 | GC -- Entry to the garbage collector: uses the node reg!
186 | PrimOpCall -- Calling prim ops
187 | PrimOpReturn -- Returning from prim ops
188 | Foreign -- Foreign call/return
191 -- Used for control transfers within a (pre-CPS) procedure All
192 -- jump sites known, never pushed on the stack (hence no SRT)
193 -- You can choose whatever calling convention you please
194 -- (provided you make sure all the call sites agree)!
195 -- This data type eventually to be extended to record the convention.
198 data ForeignConvention
200 CCallConv -- Which foreign-call convention
201 [ForeignHint] -- Extra info about the args
202 [ForeignHint] -- Extra info about the result
205 data ForeignTarget -- The target of a foreign call
206 = ForeignTarget -- A foreign procedure
207 CmmExpr -- Its address
208 ForeignConvention -- Its calling convention
209 | PrimTarget -- A possibly-side-effecting machine operation
210 CallishMachOp -- Which one
213 --------------------------------------------------
214 -- Instances of register and slot users / definers
216 instance UserOfLocalRegs (CmmNode e x) where
217 foldRegsUsed f z n = case n of
218 CmmAssign _ expr -> fold f z expr
219 CmmStore addr rval -> fold f (fold f z addr) rval
220 CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
221 CmmCondBranch expr _ _ -> fold f z expr
222 CmmSwitch expr _ -> fold f z expr
223 CmmCall {cml_target=tgt} -> fold f z tgt
224 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
226 where fold :: forall a b.
228 (b -> LocalReg -> b) -> b -> a -> b
229 fold f z n = foldRegsUsed f z n
231 instance UserOfLocalRegs ForeignTarget where
232 foldRegsUsed _f z (PrimTarget _) = z
233 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
235 instance DefinerOfLocalRegs (CmmNode e x) where
236 foldRegsDefd f z n = case n of
237 CmmAssign lhs _ -> fold f z lhs
238 CmmUnsafeForeignCall _ fs _ -> fold f z fs
239 CmmForeignCall {res=res} -> fold f z res
241 where fold :: forall a b.
242 DefinerOfLocalRegs a =>
243 (b -> LocalReg -> b) -> b -> a -> b
244 fold f z n = foldRegsDefd f z n
247 instance UserOfSlots (CmmNode e x) where
248 foldSlotsUsed f z n = case n of
249 CmmAssign _ expr -> fold f z expr
250 CmmStore addr rval -> fold f (fold f z addr) rval
251 CmmUnsafeForeignCall _ _ args -> fold f z args
252 CmmCondBranch expr _ _ -> fold f z expr
253 CmmSwitch expr _ -> fold f z expr
254 CmmCall {cml_target=tgt} -> fold f z tgt
255 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
257 where fold :: forall a b.
259 (b -> SubArea -> b) -> b -> a -> b
260 fold f z n = foldSlotsUsed f z n
262 instance UserOfSlots ForeignTarget where
263 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
264 foldSlotsUsed _f z (PrimTarget _) = z
266 instance DefinerOfSlots (CmmNode e x) where
267 foldSlotsDefd f z n = case n of
268 CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
269 CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
274 (b -> SubArea -> b) -> b -> a -> b
275 fold f z n = foldSlotsDefd f z n
276 foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
278 -----------------------------------
279 -- mapping Expr in CmmNode
281 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
282 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
283 mapForeignTarget _ m@(PrimTarget _) = m
285 -- Take a transformer on expressions and apply it recursively.
286 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
287 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
288 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
291 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
292 mapExp _ f@(CmmEntry _) = f
293 mapExp _ m@(CmmComment _) = m
294 mapExp f (CmmAssign r e) = CmmAssign r (f e)
295 mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
296 mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
297 mapExp _ l@(CmmBranch _) = l
298 mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
299 mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
300 mapExp f (CmmCall tgt mb_id o i s) = CmmCall (f tgt) mb_id o i s
301 mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
303 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
304 mapExpDeep f = mapExp $ wrapRecExp f
306 -----------------------------------
307 -- folding Expr in CmmNode
309 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
310 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
311 foldExpForeignTarget _ (PrimTarget _) z = z
313 -- Take a folder on expressions and apply it recursively.
314 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
315 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
316 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
317 wrapRecExpf f e z = f e z
319 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
320 foldExp _ (CmmEntry {}) z = z
321 foldExp _ (CmmComment {}) z = z
322 foldExp f (CmmAssign _ e) z = f e z
323 foldExp f (CmmStore addr e) z = f addr $ f e z
324 foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
325 foldExp _ (CmmBranch _) z = z
326 foldExp f (CmmCondBranch e _ _) z = f e z
327 foldExp f (CmmSwitch e _) z = f e z
328 foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
329 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
331 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
332 foldExpDeep f = foldExp $ wrapRecExpf f