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