Produce new-style Cmm from the Cmm parser
[ghc.git] / compiler / cmm / CmmNode.hs
1 -- CmmNode type for representation using Hoopl graphs.
2 {-# LANGUAGE GADTs #-}
3
4 {-# OPTIONS -fno-warn-tabs #-}
5 -- The above warning supression flag is a temporary kludge.
6 -- While working on this module you are encouraged to remove it and
7 -- detab the module (please do the detabbing in a separate patch). See
8 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
9 -- for details
10
11 module CmmNode (
12 CmmNode(..), CmmFormal, CmmActual,
13 UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..),
14 CmmReturnInfo(..),
15 mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
16 mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
17 ) where
18
19 import CmmExpr
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 #define ULabel {-# UNPACK #-} !Label
34
35 data CmmNode e x where
36 CmmEntry :: ULabel -> CmmNode C O
37
38 CmmComment :: FastString -> CmmNode O O
39
40 CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
41 -- Assign to register
42
43 CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
44 -- Assign to memory location. Size is
45 -- given by cmmExprType of the rhs.
46
47 CmmUnsafeForeignCall :: -- An unsafe foreign call;
48 -- see Note [Foreign calls]
49 -- Like a "fat machine instruction"; can occur
50 -- in the middle of a block
51 ForeignTarget -> -- call target
52 [CmmFormal] -> -- zero or more results
53 [CmmActual] -> -- zero or more arguments
54 CmmNode O O
55 -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
56 -- See Note [foreign calls clobber GlobalRegs]
57 --
58 -- Also, there is a current bug for what can be put in
59 -- arguments, 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 updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
126 intrbl:: Bool -- whether or not the call is interruptible
127 } -> CmmNode O C
128
129 {- Note [Foreign calls]
130 ~~~~~~~~~~~~~~~~~~~~~~~
131 A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
132 a CmmForeignCall call is used for *safe* foreign calls.
133
134 Unsafe ones are mostly easy: think of them as a "fat machine
135 instruction". In particular, they do *not* kill all live registers,
136 just the registers they return to (there was a bit of code in GHC that
137 conservatively assumed otherwise.) However, see [Register parameter passing].
138
139 Safe ones are trickier. A safe foreign call
140 r = f(x)
141 ultimately expands to
142 push "return address" -- Never used to return to;
143 -- just points an info table
144 save registers into TSO
145 call suspendThread
146 r = f(x) -- Make the call
147 call resumeThread
148 restore registers
149 pop "return address"
150 We cannot "lower" a safe foreign call to this sequence of Cmms, because
151 after we've saved Sp all the Cmm optimiser's assumptions are broken.
152
153 Note that a safe foreign call needs an info table.
154
155 So Safe Foreign Calls must remain as last nodes until the stack is
156 made manifest in CmmLayoutStack, where they are lowered into the above
157 sequence.
158 -}
159
160 {- Note [foreign calls clobber GlobalRegs]
161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
162
163 A foreign call is defined to clobber any GlobalRegs that are mapped to
164 caller-saves machine registers (according to the prevailing C ABI).
165 StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.
166
167 This is a design choice that makes it easier to generate code later.
168 We could instead choose to say that foreign calls do *not* clobber
169 caller-saves regs, but then we would have to figure out which regs
170 were live across the call later and insert some saves/restores.
171
172 Furthermore when we generate code we never have any GlobalRegs live
173 across a call, because they are always copied-in to LocalRegs and
174 copied-out again before making a call/jump. So all we have to do is
175 avoid any code motion that would make a caller-saves GlobalReg live
176 across a foreign call during subsequent optimisations.
177 -}
178
179 {- Note [Register parameter passing]
180 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
181 On certain architectures, some registers are utilized for parameter
182 passing in the C calling convention. For example, in x86-64 Linux
183 convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
184 argument passing. These are registers R3-R6, which our generated
185 code may also be using; as a result, it's necessary to save these
186 values before doing a foreign call. This is done during initial
187 code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However,
188 one result of doing this is that the contents of these registers
189 may mysteriously change if referenced inside the arguments. This
190 is dangerous, so you'll need to disable inlining much in the same
191 way is done in cmm/CmmOpt.hs currently. We should fix this!
192 -}
193
194 ---------------------------------------------
195 -- Eq instance of CmmNode
196 -- It is a shame GHC cannot infer it by itself :(
197
198 instance Eq (CmmNode e x) where
199 (CmmEntry a) == (CmmEntry a') = a==a'
200 (CmmComment a) == (CmmComment a') = a==a'
201 (CmmAssign a b) == (CmmAssign a' b') = a==a' && b==b'
202 (CmmStore a b) == (CmmStore a' b') = a==a' && b==b'
203 (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
204 (CmmBranch a) == (CmmBranch a') = a==a'
205 (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c'
206 (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b'
207 (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'
208 (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'
209 _ == _ = False
210
211 ----------------------------------------------
212 -- Hoopl instances of CmmNode
213
214 instance NonLocal CmmNode where
215 entryLabel (CmmEntry l) = l
216
217 successors (CmmBranch l) = [l]
218 successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
219 successors (CmmSwitch _ ls) = catMaybes ls
220 successors (CmmCall {cml_cont=l}) = maybeToList l
221 successors (CmmForeignCall {succ=l}) = [l]
222
223
224 --------------------------------------------------
225 -- Various helper types
226
227 type CmmActual = CmmExpr
228 type CmmFormal = LocalReg
229
230 type UpdFrameOffset = ByteOff
231
232 -- | A convention maps a list of values (function arguments or return
233 -- values) to registers or stack locations.
234 data Convention
235 = NativeDirectCall
236 -- ^ top-level Haskell functions use @NativeDirectCall@, which
237 -- maps arguments to registers starting with R2, according to
238 -- how many registers are available on the platform. This
239 -- convention ignores R1, because for a top-level function call
240 -- the function closure is implicit, and doesn't need to be passed.
241 | NativeNodeCall
242 -- ^ non-top-level Haskell functions, which pass the address of
243 -- the function closure in R1 (regardless of whether R1 is a
244 -- real register or not), and the rest of the arguments in
245 -- registers or on the stack.
246 | NativeReturn
247 -- ^ a native return. The convention for returns depends on
248 -- how many values are returned: for just one value returned,
249 -- the appropriate register is used (R1, F1, etc.). regardless
250 -- of whether it is a real register or not. For multiple
251 -- values returned, they are mapped to registers or the stack.
252 | Slow
253 -- ^ Slow entry points: all args pushed on the stack
254 | GC
255 -- ^ Entry to the garbage collector: uses the node reg!
256 -- (TODO: I don't think we need this --SDM)
257 deriving( Eq )
258
259 data ForeignConvention
260 = ForeignConvention
261 CCallConv -- Which foreign-call convention
262 [ForeignHint] -- Extra info about the args
263 [ForeignHint] -- Extra info about the result
264 CmmReturnInfo
265 deriving Eq
266
267 data CmmReturnInfo
268 = CmmMayReturn
269 | CmmNeverReturns
270 deriving ( Eq )
271
272 data ForeignTarget -- The target of a foreign call
273 = ForeignTarget -- A foreign procedure
274 CmmExpr -- Its address
275 ForeignConvention -- Its calling convention
276 | PrimTarget -- A possibly-side-effecting machine operation
277 CallishMachOp -- Which one
278 deriving Eq
279
280 --------------------------------------------------
281 -- Instances of register and slot users / definers
282
283 instance UserOfLocalRegs (CmmNode e x) where
284 foldRegsUsed 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 UserOfLocalRegs a =>
295 (b -> LocalReg -> b) -> b -> a -> b
296 fold f z n = foldRegsUsed f z n
297
298 instance UserOfLocalRegs ForeignTarget where
299 foldRegsUsed _f z (PrimTarget _) = z
300 foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
301
302 instance DefinerOfLocalRegs (CmmNode e x) where
303 foldRegsDefd f z n = case n of
304 CmmAssign lhs _ -> fold f z lhs
305 CmmUnsafeForeignCall _ fs _ -> fold f z fs
306 CmmForeignCall {res=res} -> fold f z res
307 _ -> z
308 where fold :: forall a b.
309 DefinerOfLocalRegs a =>
310 (b -> LocalReg -> b) -> b -> a -> b
311 fold f z n = foldRegsDefd f z n
312
313
314 -----------------------------------
315 -- mapping Expr in CmmNode
316
317 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
318 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
319 mapForeignTarget _ m@(PrimTarget _) = m
320
321 -- Take a transformer on expressions and apply it recursively.
322 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
323 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
324 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
325 wrapRecExp f e = f e
326
327 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
328 mapExp _ f@(CmmEntry _) = f
329 mapExp _ m@(CmmComment _) = m
330 mapExp f (CmmAssign r e) = CmmAssign r (f e)
331 mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
332 mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
333 mapExp _ l@(CmmBranch _) = l
334 mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
335 mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
336 mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
337 mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
338
339 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
340 mapExpDeep f = mapExp $ wrapRecExp f
341
342 ------------------------------------------------------------------------
343 -- mapping Expr in CmmNode, but not performing allocation if no changes
344
345 mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
346 mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
347 mapForeignTargetM _ (PrimTarget _) = Nothing
348
349 wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
350 wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
351 wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
352 wrapRecExpM f e = f e
353
354 mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
355 mapExpM _ (CmmEntry _) = Nothing
356 mapExpM _ (CmmComment _) = Nothing
357 mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
358 mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
359 mapExpM _ (CmmBranch _) = Nothing
360 mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e
361 mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
362 mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
363 mapExpM f (CmmUnsafeForeignCall tgt fs as)
364 = case mapForeignTargetM f tgt of
365 Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
366 Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
367 mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl)
368 = case mapForeignTargetM f tgt of
369 Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl)
370 Nothing -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as
371
372 -- share as much as possible
373 mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
374 mapListM f xs = let (b, r) = mapListT f xs
375 in if b then Just r else Nothing
376
377 mapListJ :: (a -> Maybe a) -> [a] -> [a]
378 mapListJ f xs = snd (mapListT f xs)
379
380 mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
381 mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
382 where g (_, y, Nothing) (True, ys) = (True, y:ys)
383 g (_, _, Just y) (True, ys) = (True, y:ys)
384 g (ys', _, Nothing) (False, _) = (False, ys')
385 g (_, _, Just y) (False, ys) = (True, y:ys)
386
387 mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
388 mapExpDeepM f = mapExpM $ wrapRecExpM f
389
390 -----------------------------------
391 -- folding Expr in CmmNode
392
393 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
394 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
395 foldExpForeignTarget _ (PrimTarget _) z = z
396
397 -- Take a folder on expressions and apply it recursively.
398 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
399 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
400 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
401 wrapRecExpf f e z = f e z
402
403 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
404 foldExp _ (CmmEntry {}) z = z
405 foldExp _ (CmmComment {}) z = z
406 foldExp f (CmmAssign _ e) z = f e z
407 foldExp f (CmmStore addr e) z = f addr $ f e z
408 foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
409 foldExp _ (CmmBranch _) z = z
410 foldExp f (CmmCondBranch e _ _) z = f e z
411 foldExp f (CmmSwitch e _) z = f e z
412 foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
413 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
414
415 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
416 foldExpDeep f = foldExp (wrapRecExpf f)
417
418 -- -----------------------------------------------------------------------------
419
420 mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
421 mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
422 mapSuccessors f (CmmCondBranch p y n) = CmmCondBranch p (f y) (f n)
423 mapSuccessors f (CmmSwitch e arms) = CmmSwitch e (map (fmap f) arms)
424 mapSuccessors _ n = n
425