Improve panic printout
[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 [Unsafe foreign calls clobber caller-save registers]
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 [Unsafe foreign calls clobber caller-save registers]
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 {} -> fold f z activeRegs
334 -- See Note [Safe foreign calls clobber STG registers]
335 _ -> z
336 where fold :: forall a b.
337 DefinerOfRegs GlobalReg a =>
338 (b -> GlobalReg -> b) -> b -> a -> b
339 fold f z n = foldRegsDefd dflags f z n
340
341 platform = targetPlatform dflags
342 activeRegs = activeStgRegs platform
343 activeCallerSavesRegs = filter (callerSaves platform) activeRegs
344
345 foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
346 foreignTargetRegs _ = activeCallerSavesRegs
347
348 -- Note [Safe foreign calls clobber STG registers]
349 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
350 --
351 -- During stack layout phase every safe foreign call is expanded into a block
352 -- that contains unsafe foreign call (instead of safe foreign call) and ends
353 -- with a normal call (See Note [Foreign calls]). This means that we must
354 -- treat safe foreign call as if it was a normal call (because eventually it
355 -- will be). This is important if we try to run sinking pass before stack
356 -- layout phase. Consider this example of what might go wrong (this is cmm
357 -- code from stablename001 test). Here is code after common block elimination
358 -- (before stack layout):
359 --
360 -- c1q6:
361 -- _s1pf::P64 = R1;
362 -- _c1q8::I64 = performMajorGC;
363 -- I64[(young<c1q9> + 8)] = c1q9;
364 -- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...)
365 -- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
366 -- c1q9:
367 -- I64[(young<c1qb> + 8)] = c1qb;
368 -- R1 = _s1pc::P64;
369 -- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
370 --
371 -- If we run sinking pass now (still before stack layout) we will get this:
372 --
373 -- c1q6:
374 -- I64[(young<c1q9> + 8)] = c1q9;
375 -- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...)
376 -- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
377 -- c1q9:
378 -- I64[(young<c1qb> + 8)] = c1qb;
379 -- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call
380 -- R1 = _s1pc::P64;
381 -- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
382 --
383 -- Notice that _s1pf was sunk past a foreign call. When we run stack layout
384 -- safe call to performMajorGC will be turned into:
385 --
386 -- c1q6:
387 -- _s1pc::P64 = P64[Sp + 8];
388 -- I64[Sp - 8] = c1q9;
389 -- Sp = Sp - 8;
390 -- I64[I64[CurrentTSO + 24] + 16] = Sp;
391 -- P64[CurrentNursery + 8] = Hp + 8;
392 -- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,]
393 -- result hints: [PtrHint] suspendThread(BaseReg, 0);
394 -- call "ccall" arg hints: [] result hints: [] performMajorGC();
395 -- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint]
396 -- result hints: [PtrHint] resumeThread(_u1qI::I64);
397 -- BaseReg = _u1qJ::I64;
398 -- _u1qK::P64 = CurrentTSO;
399 -- _u1qL::P64 = I64[_u1qK::P64 + 24];
400 -- Sp = I64[_u1qL::P64 + 16];
401 -- SpLim = _u1qL::P64 + 192;
402 -- HpAlloc = 0;
403 -- Hp = I64[CurrentNursery + 8] - 8;
404 -- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
405 -- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
406 -- c1q9:
407 -- I64[(young<c1qb> + 8)] = c1qb;
408 -- _s1pf::P64 = R1; <------ INCORRECT!
409 -- R1 = _s1pc::P64;
410 -- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
411 --
412 -- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
413 -- call is clearly incorrect. This is what would happen if we assumed that
414 -- safe foreign call has the same semantics as unsafe foreign call. To prevent
415 -- this we need to treat safe foreign call as if was normal call.
416
417 -----------------------------------
418 -- mapping Expr in CmmNode
419
420 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
421 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
422 mapForeignTarget _ m@(PrimTarget _) = m
423
424 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
425 -- Take a transformer on expressions and apply it recursively.
426 -- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
427 -- then uses f to rewrite the resulting expression
428 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
429 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
430 wrapRecExp f e = f e
431
432 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
433 mapExp _ f@(CmmEntry _) = f
434 mapExp _ m@(CmmComment _) = m
435 mapExp f (CmmAssign r e) = CmmAssign r (f e)
436 mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
437 mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
438 mapExp _ l@(CmmBranch _) = l
439 mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
440 mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
441 mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
442 mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
443
444 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
445 mapExpDeep f = mapExp $ wrapRecExp f
446
447 ------------------------------------------------------------------------
448 -- mapping Expr in CmmNode, but not performing allocation if no changes
449
450 mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
451 mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
452 mapForeignTargetM _ (PrimTarget _) = Nothing
453
454 wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
455 -- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
456 -- then gives f a chance to rewrite the resulting expression
457 wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
458 wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
459 wrapRecExpM f e = f e
460
461 mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
462 mapExpM _ (CmmEntry _) = Nothing
463 mapExpM _ (CmmComment _) = Nothing
464 mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
465 mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
466 mapExpM _ (CmmBranch _) = Nothing
467 mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e
468 mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
469 mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
470 mapExpM f (CmmUnsafeForeignCall tgt fs as)
471 = case mapForeignTargetM f tgt of
472 Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
473 Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
474 mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
475 = case mapForeignTargetM f tgt of
476 Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
477 Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
478
479 -- share as much as possible
480 mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
481 mapListM f xs = let (b, r) = mapListT f xs
482 in if b then Just r else Nothing
483
484 mapListJ :: (a -> Maybe a) -> [a] -> [a]
485 mapListJ f xs = snd (mapListT f xs)
486
487 mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
488 mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
489 where g (_, y, Nothing) (True, ys) = (True, y:ys)
490 g (_, _, Just y) (True, ys) = (True, y:ys)
491 g (ys', _, Nothing) (False, _) = (False, ys')
492 g (_, _, Just y) (False, ys) = (True, y:ys)
493
494 mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
495 mapExpDeepM f = mapExpM $ wrapRecExpM f
496
497 -----------------------------------
498 -- folding Expr in CmmNode
499
500 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
501 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
502 foldExpForeignTarget _ (PrimTarget _) z = z
503
504 -- Take a folder on expressions and apply it recursively.
505 -- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
506 -- itself, delegating all the other CmmExpr forms to 'f'.
507 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
508 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
509 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
510 wrapRecExpf f e z = f e z
511
512 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
513 foldExp _ (CmmEntry {}) z = z
514 foldExp _ (CmmComment {}) z = z
515 foldExp f (CmmAssign _ e) z = f e z
516 foldExp f (CmmStore addr e) z = f addr $ f e z
517 foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
518 foldExp _ (CmmBranch _) z = z
519 foldExp f (CmmCondBranch e _ _) z = f e z
520 foldExp f (CmmSwitch e _) z = f e z
521 foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
522 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
523
524 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
525 foldExpDeep f = foldExp (wrapRecExpf f)
526
527 -- -----------------------------------------------------------------------------
528
529 mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
530 mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
531 mapSuccessors f (CmmCondBranch p y n) = CmmCondBranch p (f y) (f n)
532 mapSuccessors f (CmmSwitch e arms) = CmmSwitch e (map (fmap f) arms)
533 mapSuccessors _ n = n
534