Fix a bug in stack layout with safe foreign calls (#8083)
[ghc.git] / compiler / cmm / CmmNode.hs
1 -- CmmNode type for representation using Hoopl graphs.
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE StandaloneDeriving #-}
5 {-# LANGUAGE UndecidableInstances #-}
6
7 module CmmNode (
8 CmmNode(..), CmmFormal, CmmActual,
9 UpdFrameOffset, Convention(..),
10 ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
11 CmmReturnInfo(..),
12 mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
13 mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
14 ) where
15
16 import CodeGen.Platform
17 import CmmExpr
18 import DynFlags
19 import FastString
20 import ForeignCall
21 import SMRep
22
23 import Compiler.Hoopl
24 import Data.Maybe
25 import Data.List (tails)
26 import Prelude hiding (succ)
27
28
29 ------------------------
30 -- CmmNode
31
32 #define ULabel {-# UNPACK #-} !Label
33
34 data CmmNode e x where
35 CmmEntry :: ULabel -> CmmNode C O
36
37 CmmComment :: FastString -> CmmNode O O
38
39 CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
40 -- Assign to register
41
42 CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
43 -- Assign to memory location. Size is
44 -- given by cmmExprType of the rhs.
45
46 CmmUnsafeForeignCall :: -- An unsafe foreign call;
47 -- see Note [Foreign calls]
48 -- Like a "fat machine instruction"; can occur
49 -- in the middle of a block
50 ForeignTarget -> -- call target
51 [CmmFormal] -> -- zero or more results
52 [CmmActual] -> -- zero or more arguments
53 CmmNode O O
54 -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
55 -- See Note [foreign calls clobber GlobalRegs]
56 --
57 -- Invariant: the arguments and the ForeignTarget must not
58 -- mention any registers for which CodeGen.Platform.callerSaves
59 -- is True. See Note [Register Parameter Passing].
60
61 CmmBranch :: ULabel -> CmmNode O C
62 -- Goto another block in the same procedure
63
64 CmmCondBranch :: { -- conditional branch
65 cml_pred :: CmmExpr,
66 cml_true, cml_false :: ULabel
67 } -> CmmNode O C
68
69 CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
70 -- The scrutinee is zero-based;
71 -- zero -> first block
72 -- one -> second block etc
73 -- Undefined outside range, and when there's a Nothing
74
75 CmmCall :: { -- A native call or tail call
76 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
77
78 cml_cont :: Maybe Label,
79 -- Label of continuation (Nothing for return or tail call)
80 --
81 -- Note [Continuation BlockId]: these BlockIds are called
82 -- Continuation BlockIds, and are the only BlockIds that can
83 -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
84 -- (CmmStackSlot (Young b) _).
85
86 cml_args_regs :: [GlobalReg],
87 -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
88 -- to the call. This is essential information for the
89 -- native code generator's register allocator; without
90 -- knowing which GlobalRegs are live it has to assume that
91 -- they are all live. This list should only include
92 -- GlobalRegs that are mapped to real machine registers on
93 -- the target platform.
94
95 cml_args :: ByteOff,
96 -- Byte offset, from the *old* end of the Area associated with
97 -- the Label (if cml_cont = Nothing, then Old area), of
98 -- youngest outgoing arg. Set the stack pointer to this before
99 -- transferring control.
100 -- (NB: an update frame might also have been stored in the Old
101 -- area, but it'll be in an older part than the args.)
102
103 cml_ret_args :: ByteOff,
104 -- For calls *only*, the byte offset for youngest returned value
105 -- This is really needed at the *return* point rather than here
106 -- at the call, but in practice it's convenient to record it here.
107
108 cml_ret_off :: ByteOff
109 -- For calls *only*, the byte offset of the base of the frame that
110 -- must be described by the info table for the return point.
111 -- The older words are an update frames, which have their own
112 -- info-table and layout information
113
114 -- From a liveness point of view, the stack words older than
115 -- cml_ret_off are treated as live, even if the sequel of
116 -- the call goes into a loop.
117 } -> CmmNode O C
118
119 CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
120 -- Always the last node of a block
121 tgt :: ForeignTarget, -- call target and convention
122 res :: [CmmFormal], -- zero or more results
123 args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing]
124 succ :: ULabel, -- Label of continuation
125 ret_args :: ByteOff, -- same as cml_ret_args
126 ret_off :: ByteOff, -- same as cml_ret_off
127 intrbl:: Bool -- whether or not the call is interruptible
128 } -> CmmNode O C
129
130 {- Note [Foreign calls]
131 ~~~~~~~~~~~~~~~~~~~~~~~
132 A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
133 a CmmForeignCall call is used for *safe* foreign calls.
134
135 Unsafe ones are mostly easy: think of them as a "fat machine
136 instruction". In particular, they do *not* kill all live registers,
137 just the registers they return to (there was a bit of code in GHC that
138 conservatively assumed otherwise.) However, see [Register parameter passing].
139
140 Safe ones are trickier. A safe foreign call
141 r = f(x)
142 ultimately expands to
143 push "return address" -- Never used to return to;
144 -- just points an info table
145 save registers into TSO
146 call suspendThread
147 r = f(x) -- Make the call
148 call resumeThread
149 restore registers
150 pop "return address"
151 We cannot "lower" a safe foreign call to this sequence of Cmms, because
152 after we've saved Sp all the Cmm optimiser's assumptions are broken.
153
154 Note that a safe foreign call needs an info table.
155
156 So Safe Foreign Calls must remain as last nodes until the stack is
157 made manifest in CmmLayoutStack, where they are lowered into the above
158 sequence.
159 -}
160
161 {- Note [foreign calls clobber GlobalRegs]
162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
163
164 A foreign call is defined to clobber any GlobalRegs that are mapped to
165 caller-saves machine registers (according to the prevailing C ABI).
166 StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.
167
168 This is a design choice that makes it easier to generate code later.
169 We could instead choose to say that foreign calls do *not* clobber
170 caller-saves regs, but then we would have to figure out which regs
171 were live across the call later and insert some saves/restores.
172
173 Furthermore when we generate code we never have any GlobalRegs live
174 across a call, because they are always copied-in to LocalRegs and
175 copied-out again before making a call/jump. So all we have to do is
176 avoid any code motion that would make a caller-saves GlobalReg live
177 across a foreign call during subsequent optimisations.
178 -}
179
180 {- Note [Register parameter passing]
181 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
182 On certain architectures, some registers are utilized for parameter
183 passing in the C calling convention. For example, in x86-64 Linux
184 convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
185 argument passing. These are registers R3-R6, which our generated
186 code may also be using; as a result, it's necessary to save these
187 values before doing a foreign call. This is done during initial
188 code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However,
189 one result of doing this is that the contents of these registers
190 may mysteriously change if referenced inside the arguments. This
191 is dangerous, so you'll need to disable inlining much in the same
192 way is done in cmm/CmmOpt.hs currently. We should fix this!
193 -}
194
195 ---------------------------------------------
196 -- Eq instance of CmmNode
197
198 deriving instance Eq (CmmNode e x)
199
200 ----------------------------------------------
201 -- Hoopl instances of CmmNode
202
203 instance NonLocal CmmNode where
204 entryLabel (CmmEntry l) = l
205
206 successors (CmmBranch l) = [l]
207 successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
208 successors (CmmSwitch _ ls) = catMaybes ls
209 successors (CmmCall {cml_cont=l}) = maybeToList l
210 successors (CmmForeignCall {succ=l}) = [l]
211
212
213 --------------------------------------------------
214 -- Various helper types
215
216 type CmmActual = CmmExpr
217 type CmmFormal = LocalReg
218
219 type UpdFrameOffset = ByteOff
220
221 -- | A convention maps a list of values (function arguments or return
222 -- values) to registers or stack locations.
223 data Convention
224 = NativeDirectCall
225 -- ^ top-level Haskell functions use @NativeDirectCall@, which
226 -- maps arguments to registers starting with R2, according to
227 -- how many registers are available on the platform. This
228 -- convention ignores R1, because for a top-level function call
229 -- the function closure is implicit, and doesn't need to be passed.
230 | NativeNodeCall
231 -- ^ non-top-level Haskell functions, which pass the address of
232 -- the function closure in R1 (regardless of whether R1 is a
233 -- real register or not), and the rest of the arguments in
234 -- registers or on the stack.
235 | NativeReturn
236 -- ^ a native return. The convention for returns depends on
237 -- how many values are returned: for just one value returned,
238 -- the appropriate register is used (R1, F1, etc.). regardless
239 -- of whether it is a real register or not. For multiple
240 -- values returned, they are mapped to registers or the stack.
241 | Slow
242 -- ^ Slow entry points: all args pushed on the stack
243 | GC
244 -- ^ Entry to the garbage collector: uses the node reg!
245 -- (TODO: I don't think we need this --SDM)
246 deriving( Eq )
247
248 data ForeignConvention
249 = ForeignConvention
250 CCallConv -- Which foreign-call convention
251 [ForeignHint] -- Extra info about the args
252 [ForeignHint] -- Extra info about the result
253 CmmReturnInfo
254 deriving Eq
255
256 data CmmReturnInfo
257 = CmmMayReturn
258 | CmmNeverReturns
259 deriving ( Eq )
260
261 data ForeignTarget -- The target of a foreign call
262 = ForeignTarget -- A foreign procedure
263 CmmExpr -- Its address
264 ForeignConvention -- Its calling convention
265 | PrimTarget -- A possibly-side-effecting machine operation
266 CallishMachOp -- Which one
267 deriving Eq
268
269 foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
270 foreignTargetHints target
271 = ( res_hints ++ repeat NoHint
272 , arg_hints ++ repeat NoHint )
273 where
274 (res_hints, arg_hints) =
275 case target of
276 PrimTarget op -> callishMachOpHints op
277 ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
278 (res_hints, arg_hints)
279
280 --------------------------------------------------
281 -- Instances of register and slot users / definers
282
283 instance UserOfRegs LocalReg (CmmNode e x) where
284 foldRegsUsed dflags f z n = case n of
285 CmmAssign _ expr -> fold f z expr
286 CmmStore addr rval -> fold f (fold f z addr) rval
287 CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
288 CmmCondBranch expr _ _ -> fold f z expr
289 CmmSwitch expr _ -> fold f z expr
290 CmmCall {cml_target=tgt} -> fold f z tgt
291 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
292 _ -> z
293 where fold :: forall a b.
294 UserOfRegs LocalReg a =>
295 (b -> LocalReg -> b) -> b -> a -> b
296 fold f z n = foldRegsUsed dflags f z n
297
298 instance UserOfRegs GlobalReg (CmmNode e x) where
299 foldRegsUsed dflags f z n = case n of
300 CmmAssign _ expr -> fold f z expr
301 CmmStore addr rval -> fold f (fold f z addr) rval
302 CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
303 CmmCondBranch expr _ _ -> fold f z expr
304 CmmSwitch expr _ -> fold f z expr
305 CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
306 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
307 _ -> z
308 where fold :: forall a b.
309 UserOfRegs GlobalReg a =>
310 (b -> GlobalReg -> b) -> b -> a -> b
311 fold f z n = foldRegsUsed dflags f z n
312
313 instance UserOfRegs r CmmExpr => UserOfRegs r ForeignTarget where
314 foldRegsUsed _ _ z (PrimTarget _) = z
315 foldRegsUsed dflags f z (ForeignTarget e _) = foldRegsUsed dflags f z e
316
317 instance DefinerOfRegs LocalReg (CmmNode e x) where
318 foldRegsDefd dflags f z n = case n of
319 CmmAssign lhs _ -> fold f z lhs
320 CmmUnsafeForeignCall _ fs _ -> fold f z fs
321 CmmForeignCall {res=res} -> fold f z res
322 _ -> z
323 where fold :: forall a b.
324 DefinerOfRegs LocalReg a =>
325 (b -> LocalReg -> b) -> b -> a -> b
326 fold f z n = foldRegsDefd dflags f z n
327
328 instance DefinerOfRegs GlobalReg (CmmNode e x) where
329 foldRegsDefd dflags f z n = case n of
330 CmmAssign lhs _ -> fold f z lhs
331 CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt)
332 CmmCall {} -> fold f z activeRegs
333 CmmForeignCall {tgt=tgt} -> fold f z (foreignTargetRegs tgt)
334 _ -> z
335 where fold :: forall a b.
336 DefinerOfRegs GlobalReg a =>
337 (b -> GlobalReg -> b) -> b -> a -> b
338 fold f z n = foldRegsDefd dflags f z n
339
340 platform = targetPlatform dflags
341 activeRegs = activeStgRegs platform
342 activeCallerSavesRegs = filter (callerSaves platform) activeRegs
343
344 foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
345 foreignTargetRegs _ = activeCallerSavesRegs
346
347
348 -----------------------------------
349 -- mapping Expr in CmmNode
350
351 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
352 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
353 mapForeignTarget _ m@(PrimTarget _) = m
354
355 -- Take a transformer on expressions and apply it recursively.
356 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
357 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
358 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
359 wrapRecExp f e = f e
360
361 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
362 mapExp _ f@(CmmEntry _) = f
363 mapExp _ m@(CmmComment _) = m
364 mapExp f (CmmAssign r e) = CmmAssign r (f e)
365 mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
366 mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
367 mapExp _ l@(CmmBranch _) = l
368 mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
369 mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
370 mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
371 mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
372
373 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
374 mapExpDeep f = mapExp $ wrapRecExp f
375
376 ------------------------------------------------------------------------
377 -- mapping Expr in CmmNode, but not performing allocation if no changes
378
379 mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
380 mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
381 mapForeignTargetM _ (PrimTarget _) = Nothing
382
383 wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
384 wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
385 wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
386 wrapRecExpM f e = f e
387
388 mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
389 mapExpM _ (CmmEntry _) = Nothing
390 mapExpM _ (CmmComment _) = Nothing
391 mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
392 mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
393 mapExpM _ (CmmBranch _) = Nothing
394 mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e
395 mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
396 mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
397 mapExpM f (CmmUnsafeForeignCall tgt fs as)
398 = case mapForeignTargetM f tgt of
399 Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
400 Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
401 mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
402 = case mapForeignTargetM f tgt of
403 Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
404 Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
405
406 -- share as much as possible
407 mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
408 mapListM f xs = let (b, r) = mapListT f xs
409 in if b then Just r else Nothing
410
411 mapListJ :: (a -> Maybe a) -> [a] -> [a]
412 mapListJ f xs = snd (mapListT f xs)
413
414 mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
415 mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
416 where g (_, y, Nothing) (True, ys) = (True, y:ys)
417 g (_, _, Just y) (True, ys) = (True, y:ys)
418 g (ys', _, Nothing) (False, _) = (False, ys')
419 g (_, _, Just y) (False, ys) = (True, y:ys)
420
421 mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
422 mapExpDeepM f = mapExpM $ wrapRecExpM f
423
424 -----------------------------------
425 -- folding Expr in CmmNode
426
427 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
428 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
429 foldExpForeignTarget _ (PrimTarget _) z = z
430
431 -- Take a folder on expressions and apply it recursively.
432 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
433 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
434 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
435 wrapRecExpf f e z = f e z
436
437 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
438 foldExp _ (CmmEntry {}) z = z
439 foldExp _ (CmmComment {}) z = z
440 foldExp f (CmmAssign _ e) z = f e z
441 foldExp f (CmmStore addr e) z = f addr $ f e z
442 foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
443 foldExp _ (CmmBranch _) z = z
444 foldExp f (CmmCondBranch e _ _) z = f e z
445 foldExp f (CmmSwitch e _) z = f e z
446 foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
447 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
448
449 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
450 foldExpDeep f = foldExp (wrapRecExpf f)
451
452 -- -----------------------------------------------------------------------------
453
454 mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
455 mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
456 mapSuccessors f (CmmCondBranch p y n) = CmmCondBranch p (f y) (f n)
457 mapSuccessors f (CmmSwitch e arms) = CmmSwitch e (map (fmap f) arms)
458 mapSuccessors _ n = n
459