f5a88cebb8d03cf3aaf04e013ff654b425e39cb8
[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__ >= 703
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, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf
14 , mapExpM, mapExpDeepM, wrapRecExpM
15 )
16 where
17
18 import CmmExpr
19 import CmmDecl
20 import FastString
21 import ForeignCall
22 import SMRep
23
24 import Compiler.Hoopl
25 import Data.Maybe
26 import Data.List (tails)
27 import Prelude hiding (succ)
28
29
30 ------------------------
31 -- CmmNode
32
33 data CmmNode e x where
34 CmmEntry :: Label -> CmmNode C O
35
36 CmmComment :: FastString -> CmmNode O O
37
38 CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O
39 -- Assign to register
40
41 CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O
42 -- Assign to memory location. Size is
43 -- given by cmmExprType of the rhs.
44
45 CmmUnsafeForeignCall :: -- An unsafe foreign call;
46 -- see Note [Foreign calls]
47 -- Like a "fat machine instruction"; can occur
48 -- in the middle of a block
49 ForeignTarget -> -- call target
50 [CmmFormal] -> -- zero or more results
51 [CmmActual] -> -- zero or more arguments
52 CmmNode O O
53 -- Semantics: kills only result regs; all other regs (both GlobalReg
54 -- and LocalReg) are preserved. But there is a current
55 -- bug for what can be put in arguments, see
56 -- Note [Register Parameter Passing]
57
58 CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
59
60 CmmCondBranch :: { -- conditional branch
61 cml_pred :: CmmExpr,
62 cml_true, cml_false :: Label
63 } -> CmmNode O C
64
65 CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
66 -- The scrutinee is zero-based;
67 -- zero -> first block
68 -- one -> second block etc
69 -- Undefined outside range, and when there's a Nothing
70
71 CmmCall :: { -- A native call or tail call
72 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
73
74 cml_cont :: Maybe Label,
75 -- Label of continuation (Nothing for return or tail call)
76
77 -- ToDO: add this:
78 -- cml_args_regs :: [GlobalReg],
79 -- It says which GlobalRegs are live for the parameters at the
80 -- moment of the call. Later stages can use this to give liveness
81 -- everywhere, which in turn guides register allocation.
82 -- It is the companion of cml_args; cml_args says which stack words
83 -- hold parameters, while cml_arg_regs says which global regs hold parameters.
84 -- But do note [Register parameter passing]
85
86 cml_args :: ByteOff,
87 -- Byte offset, from the *old* end of the Area associated with
88 -- the Label (if cml_cont = Nothing, then Old area), of
89 -- youngest outgoing arg. Set the stack pointer to this before
90 -- transferring control.
91 -- (NB: an update frame might also have been stored in the Old
92 -- area, but it'll be in an older part than the args.)
93
94 cml_ret_args :: ByteOff,
95 -- For calls *only*, the byte offset for youngest returned value
96 -- This is really needed at the *return* point rather than here
97 -- at the call, but in practice it's convenient to record it here.
98
99 cml_ret_off :: ByteOff
100 -- For calls *only*, the byte offset of the base of the frame that
101 -- must be described by the info table for the return point.
102 -- The older words are an update frames, which have their own
103 -- info-table and layout information
104
105 -- From a liveness point of view, the stack words older than
106 -- cml_ret_off are treated as live, even if the sequel of
107 -- the call goes into a loop.
108 } -> CmmNode O C
109
110 CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
111 -- Always the last node of a block
112 tgt :: ForeignTarget, -- call target and convention
113 res :: [CmmFormal], -- zero or more results
114 args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing]
115 succ :: Label, -- Label of continuation
116 updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
117 intrbl:: Bool -- whether or not the call is interruptible
118 } -> CmmNode O C
119
120 {- Note [Foreign calls]
121 ~~~~~~~~~~~~~~~~~~~~~~~
122 A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
123 a CmmForeignCall call is used for *safe* foreign calls.
124
125 Unsafe ones are mostly easy: think of them as a "fat machine
126 instruction". In particular, they do *not* kill all live registers,
127 just the registers they return to (there was a bit of code in GHC that
128 conservatively assumed otherwise.) However, see [Register parameter passing].
129
130 Safe ones are trickier. A safe foreign call
131 r = f(x)
132 ultimately expands to
133 push "return address" -- Never used to return to;
134 -- just points an info table
135 save registers into TSO
136 call suspendThread
137 r = f(x) -- Make the call
138 call resumeThread
139 restore registers
140 pop "return address"
141 We cannot "lower" a safe foreign call to this sequence of Cmms, because
142 after we've saved Sp all the Cmm optimiser's assumptions are broken.
143 Furthermore, currently the smart Cmm constructors know the calling
144 conventions for Haskell, the garbage collector, etc, and "lower" them
145 so that a LastCall passes no parameters or results. But the smart
146 constructors do *not* (currently) know the foreign call conventions.
147
148 Note that a safe foreign call needs an info table.
149 -}
150
151 {- Note [Register parameter passing]
152 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
153 On certain architectures, some registers are utilized for parameter
154 passing in the C calling convention. For example, in x86-64 Linux
155 convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
156 argument passing. These are registers R3-R6, which our generated
157 code may also be using; as a result, it's necessary to save these
158 values before doing a foreign call. This is done during initial
159 code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However,
160 one result of doing this is that the contents of these registers
161 may mysteriously change if referenced inside the arguments. This
162 is dangerous, so you'll need to disable inlining much in the same
163 way is done in cmm/CmmOpt.hs currently. We should fix this!
164 -}
165
166 ---------------------------------------------
167 -- Eq instance of CmmNode
168 -- It is a shame GHC cannot infer it by itself :(
169
170 instance Eq (CmmNode e x) where
171 (CmmEntry a) == (CmmEntry a') = a==a'
172 (CmmComment a) == (CmmComment a') = a==a'
173 (CmmAssign a b) == (CmmAssign a' b') = a==a' && b==b'
174 (CmmStore a b) == (CmmStore a' b') = a==a' && b==b'
175 (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
176 (CmmBranch a) == (CmmBranch a') = a==a'
177 (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c'
178 (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b'
179 (CmmCall a b c d e) == (CmmCall a' b' c' d' e') = a==a' && b==b' && c==c' && d==d' && e==e'
180 (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'
181 _ == _ = False
182
183 ----------------------------------------------
184 -- Hoopl instances of CmmNode
185
186 instance NonLocal CmmNode where
187 entryLabel (CmmEntry l) = l
188
189 successors (CmmBranch l) = [l]
190 successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
191 successors (CmmSwitch _ ls) = catMaybes ls
192 successors (CmmCall {cml_cont=l}) = maybeToList l
193 successors (CmmForeignCall {succ=l}) = [l]
194
195
196 instance HooplNode CmmNode where
197 mkBranchNode label = CmmBranch label
198 mkLabelNode label = CmmEntry label
199
200 --------------------------------------------------
201 -- Various helper types
202
203 type UpdFrameOffset = ByteOff
204
205 data Convention
206 = NativeDirectCall -- Native C-- call skipping the node (closure) argument
207 | NativeNodeCall -- Native C-- call including the node argument
208 | NativeReturn -- Native C-- return
209 | Slow -- Slow entry points: all args pushed on the stack
210 | GC -- Entry to the garbage collector: uses the node reg!
211 | PrimOpCall -- Calling prim ops
212 | PrimOpReturn -- Returning from prim ops
213 | Foreign -- Foreign call/return
214 ForeignConvention
215 | Private
216 -- Used for control transfers within a (pre-CPS) procedure All
217 -- jump sites known, never pushed on the stack (hence no SRT)
218 -- You can choose whatever calling convention you please
219 -- (provided you make sure all the call sites agree)!
220 -- This data type eventually to be extended to record the convention.
221 deriving( Eq )
222
223 data ForeignConvention
224 = ForeignConvention
225 CCallConv -- Which foreign-call convention
226 [ForeignHint] -- Extra info about the args
227 [ForeignHint] -- Extra info about the result
228 deriving Eq
229
230 data ForeignTarget -- The target of a foreign call
231 = ForeignTarget -- A foreign procedure
232 CmmExpr -- Its address
233 ForeignConvention -- Its calling convention
234 | PrimTarget -- A possibly-side-effecting machine operation
235 CallishMachOp -- Which one
236 deriving Eq
237
238 --------------------------------------------------
239 -- Instances of register and slot users / definers
240
241 instance UserOfLocalRegs (CmmNode e x) where
242 foldRegsUsed f z n = case n of
243 CmmAssign _ expr -> fold f z expr
244 CmmStore addr rval -> fold f (fold f z addr) rval
245 CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
246 CmmCondBranch expr _ _ -> fold f z expr
247 CmmSwitch expr _ -> fold f z expr
248 CmmCall {cml_target=tgt} -> fold f z tgt
249 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
250 _ -> z
251 where fold :: forall a b.
252 UserOfLocalRegs a =>
253 (b -> LocalReg -> b) -> b -> a -> b
254 fold f z n = foldRegsUsed f z n
255
256 instance UserOfLocalRegs ForeignTarget where
257 foldRegsUsed _f z (PrimTarget _) = z
258 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
259
260 instance DefinerOfLocalRegs (CmmNode e x) where
261 foldRegsDefd f z n = case n of
262 CmmAssign lhs _ -> fold f z lhs
263 CmmUnsafeForeignCall _ fs _ -> fold f z fs
264 CmmForeignCall {res=res} -> fold f z res
265 _ -> z
266 where fold :: forall a b.
267 DefinerOfLocalRegs a =>
268 (b -> LocalReg -> b) -> b -> a -> b
269 fold f z n = foldRegsDefd f z n
270
271
272 instance UserOfSlots (CmmNode e x) where
273 foldSlotsUsed f z n = case n of
274 CmmAssign _ expr -> fold f z expr
275 CmmStore addr rval -> fold f (fold f z addr) rval
276 CmmUnsafeForeignCall _ _ args -> fold f z args
277 CmmCondBranch expr _ _ -> fold f z expr
278 CmmSwitch expr _ -> fold f z expr
279 CmmCall {cml_target=tgt} -> fold f z tgt
280 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
281 _ -> z
282 where fold :: forall a b.
283 UserOfSlots a =>
284 (b -> SubArea -> b) -> b -> a -> b
285 fold f z n = foldSlotsUsed f z n
286
287 instance UserOfSlots ForeignTarget where
288 foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
289 foldSlotsUsed _f z (PrimTarget _) = z
290
291 instance DefinerOfSlots (CmmNode e x) where
292 foldSlotsDefd f z n = case n of
293 CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
294 CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
295 _ -> z
296 where
297 fold :: forall a b.
298 DefinerOfSlots a =>
299 (b -> SubArea -> b) -> b -> a -> b
300 fold f z n = foldSlotsDefd f z n
301 foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
302
303 -----------------------------------
304 -- mapping Expr in CmmNode
305
306 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
307 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
308 mapForeignTarget _ m@(PrimTarget _) = m
309
310 -- Take a transformer on expressions and apply it recursively.
311 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
312 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
313 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
314 wrapRecExp f e = f e
315
316 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
317 mapExp _ f@(CmmEntry _) = f
318 mapExp _ m@(CmmComment _) = m
319 mapExp f (CmmAssign r e) = CmmAssign r (f e)
320 mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
321 mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
322 mapExp _ l@(CmmBranch _) = l
323 mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
324 mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
325 mapExp f (CmmCall tgt mb_id o i s) = CmmCall (f tgt) mb_id o i s
326 mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
327
328 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
329 mapExpDeep f = mapExp $ wrapRecExp f
330
331 ------------------------------------------------------------------------
332 -- mapping Expr in CmmNode, but not performing allocation if no changes
333
334 mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
335 mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
336 mapForeignTargetM _ (PrimTarget _) = Nothing
337
338 wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
339 wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
340 wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
341 wrapRecExpM f e = f e
342
343 mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
344 mapExpM _ (CmmEntry _) = Nothing
345 mapExpM _ (CmmComment _) = Nothing
346 mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
347 mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
348 mapExpM _ (CmmBranch _) = Nothing
349 mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e
350 mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
351 mapExpM f (CmmCall tgt mb_id o i s) = (\x -> CmmCall x mb_id o i s) `fmap` f tgt
352 mapExpM f (CmmUnsafeForeignCall tgt fs as)
353 = case mapForeignTargetM f tgt of
354 Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
355 Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
356 mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl)
357 = case mapForeignTargetM f tgt of
358 Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl)
359 Nothing -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as
360
361 -- share as much as possible
362 mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
363 mapListM f xs = let (b, r) = mapListT f xs
364 in if b then Just r else Nothing
365
366 mapListJ :: (a -> Maybe a) -> [a] -> [a]
367 mapListJ f xs = snd (mapListT f xs)
368
369 mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
370 mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
371 where g (_, y, Nothing) (True, ys) = (True, y:ys)
372 g (_, _, Just y) (True, ys) = (True, y:ys)
373 g (ys', _, Nothing) (False, _) = (False, ys')
374 g (_, _, Just y) (False, ys) = (True, y:ys)
375
376 mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
377 mapExpDeepM f = mapExpM $ wrapRecExpM f
378
379 -----------------------------------
380 -- folding Expr in CmmNode
381
382 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
383 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
384 foldExpForeignTarget _ (PrimTarget _) z = z
385
386 -- Take a folder on expressions and apply it recursively.
387 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
388 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
389 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
390 wrapRecExpf f e z = f e z
391
392 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
393 foldExp _ (CmmEntry {}) z = z
394 foldExp _ (CmmComment {}) z = z
395 foldExp f (CmmAssign _ e) z = f e z
396 foldExp f (CmmStore addr e) z = f addr $ f e z
397 foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
398 foldExp _ (CmmBranch _) z = z
399 foldExp f (CmmCondBranch e _ _) z = f e z
400 foldExp f (CmmSwitch e _) z = f e z
401 foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
402 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
403
404 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
405 foldExpDeep f = foldExp $ wrapRecExpf f