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