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