Generalize CmmUnwind and pass unwind information through NCG
[ghc.git] / compiler / cmm / CmmNode.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE CPP #-}
3 {-# LANGUAGE ExplicitForAll #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE GADTs #-}
7 {-# LANGUAGE MultiParamTypeClasses #-}
8 {-# LANGUAGE StandaloneDeriving #-}
9 {-# LANGUAGE UndecidableInstances #-}
10
11 -- CmmNode type for representation using Hoopl graphs.
12
13 module CmmNode (
14 CmmNode(..), CmmFormal, CmmActual, CmmTickish,
15 UpdFrameOffset, Convention(..),
16 ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
17 CmmReturnInfo(..),
18 mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
19 mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors,
20
21 -- * Tick scopes
22 CmmTickScope(..), isTickSubScope, combineTickScopes,
23 ) where
24
25 import CodeGen.Platform
26 import CmmExpr
27 import CmmSwitch
28 import DynFlags
29 import FastString
30 import ForeignCall
31 import Outputable
32 import SMRep
33 import CoreSyn (Tickish)
34 import qualified Unique as U
35
36 import Compiler.Hoopl
37 import Data.Maybe
38 import Data.List (tails,sortBy)
39 import Prelude hiding (succ)
40 import Unique (nonDetCmpUnique)
41 import Util
42
43
44 ------------------------
45 -- CmmNode
46
47 #define ULabel {-# UNPACK #-} !Label
48
49 data CmmNode e x where
50 CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
51
52 CmmComment :: FastString -> CmmNode O O
53
54 -- Tick annotation, covering Cmm code in our tick scope. We only
55 -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
56 -- See Note [CmmTick scoping details]
57 CmmTick :: !CmmTickish -> CmmNode O O
58
59 -- Unwind pseudo-instruction, encoding stack unwinding
60 -- instructions for a debugger. This describes how to reconstruct
61 -- the "old" value of a register if we want to navigate the stack
62 -- up one frame. Having unwind information for @Sp@ will allow the
63 -- debugger to "walk" the stack.
64 --
65 -- See Note [What is this unwinding business?] in Debug
66 CmmUnwind :: [(GlobalReg, CmmExpr)] -> CmmNode O O
67
68 CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
69 -- Assign to register
70
71 CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
72 -- Assign to memory location. Size is
73 -- given by cmmExprType of the rhs.
74
75 CmmUnsafeForeignCall :: -- An unsafe foreign call;
76 -- see Note [Foreign calls]
77 -- Like a "fat machine instruction"; can occur
78 -- in the middle of a block
79 ForeignTarget -> -- call target
80 [CmmFormal] -> -- zero or more results
81 [CmmActual] -> -- zero or more arguments
82 CmmNode O O
83 -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
84 -- See Note [Unsafe foreign calls clobber caller-save registers]
85 --
86 -- Invariant: the arguments and the ForeignTarget must not
87 -- mention any registers for which CodeGen.Platform.callerSaves
88 -- is True. See Note [Register Parameter Passing].
89
90 CmmBranch :: ULabel -> CmmNode O C
91 -- Goto another block in the same procedure
92
93 CmmCondBranch :: { -- conditional branch
94 cml_pred :: CmmExpr,
95 cml_true, cml_false :: ULabel,
96 cml_likely :: Maybe Bool -- likely result of the conditional,
97 -- if known
98 } -> CmmNode O C
99
100 CmmSwitch
101 :: CmmExpr -- Scrutinee, of some integral type
102 -> SwitchTargets -- Cases. See [Note SwitchTargets]
103 -> CmmNode O C
104
105 CmmCall :: { -- A native call or tail call
106 cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
107
108 cml_cont :: Maybe Label,
109 -- Label of continuation (Nothing for return or tail call)
110 --
111 -- Note [Continuation BlockId]: these BlockIds are called
112 -- Continuation BlockIds, and are the only BlockIds that can
113 -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
114 -- (CmmStackSlot (Young b) _).
115
116 cml_args_regs :: [GlobalReg],
117 -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
118 -- to the call. This is essential information for the
119 -- native code generator's register allocator; without
120 -- knowing which GlobalRegs are live it has to assume that
121 -- they are all live. This list should only include
122 -- GlobalRegs that are mapped to real machine registers on
123 -- the target platform.
124
125 cml_args :: ByteOff,
126 -- Byte offset, from the *old* end of the Area associated with
127 -- the Label (if cml_cont = Nothing, then Old area), of
128 -- youngest outgoing arg. Set the stack pointer to this before
129 -- transferring control.
130 -- (NB: an update frame might also have been stored in the Old
131 -- area, but it'll be in an older part than the args.)
132
133 cml_ret_args :: ByteOff,
134 -- For calls *only*, the byte offset for youngest returned value
135 -- This is really needed at the *return* point rather than here
136 -- at the call, but in practice it's convenient to record it here.
137
138 cml_ret_off :: ByteOff
139 -- For calls *only*, the byte offset of the base of the frame that
140 -- must be described by the info table for the return point.
141 -- The older words are an update frames, which have their own
142 -- info-table and layout information
143
144 -- From a liveness point of view, the stack words older than
145 -- cml_ret_off are treated as live, even if the sequel of
146 -- the call goes into a loop.
147 } -> CmmNode O C
148
149 CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
150 -- Always the last node of a block
151 tgt :: ForeignTarget, -- call target and convention
152 res :: [CmmFormal], -- zero or more results
153 args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing]
154 succ :: ULabel, -- Label of continuation
155 ret_args :: ByteOff, -- same as cml_ret_args
156 ret_off :: ByteOff, -- same as cml_ret_off
157 intrbl:: Bool -- whether or not the call is interruptible
158 } -> CmmNode O C
159
160 {- Note [Foreign calls]
161 ~~~~~~~~~~~~~~~~~~~~~~~
162 A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
163 a CmmForeignCall call is used for *safe* foreign calls.
164
165 Unsafe ones are mostly easy: think of them as a "fat machine
166 instruction". In particular, they do *not* kill all live registers,
167 just the registers they return to (there was a bit of code in GHC that
168 conservatively assumed otherwise.) However, see [Register parameter passing].
169
170 Safe ones are trickier. A safe foreign call
171 r = f(x)
172 ultimately expands to
173 push "return address" -- Never used to return to;
174 -- just points an info table
175 save registers into TSO
176 call suspendThread
177 r = f(x) -- Make the call
178 call resumeThread
179 restore registers
180 pop "return address"
181 We cannot "lower" a safe foreign call to this sequence of Cmms, because
182 after we've saved Sp all the Cmm optimiser's assumptions are broken.
183
184 Note that a safe foreign call needs an info table.
185
186 So Safe Foreign Calls must remain as last nodes until the stack is
187 made manifest in CmmLayoutStack, where they are lowered into the above
188 sequence.
189 -}
190
191 {- Note [Unsafe foreign calls clobber caller-save registers]
192 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
193
194 A foreign call is defined to clobber any GlobalRegs that are mapped to
195 caller-saves machine registers (according to the prevailing C ABI).
196 StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.
197
198 This is a design choice that makes it easier to generate code later.
199 We could instead choose to say that foreign calls do *not* clobber
200 caller-saves regs, but then we would have to figure out which regs
201 were live across the call later and insert some saves/restores.
202
203 Furthermore when we generate code we never have any GlobalRegs live
204 across a call, because they are always copied-in to LocalRegs and
205 copied-out again before making a call/jump. So all we have to do is
206 avoid any code motion that would make a caller-saves GlobalReg live
207 across a foreign call during subsequent optimisations.
208 -}
209
210 {- Note [Register parameter passing]
211 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
212 On certain architectures, some registers are utilized for parameter
213 passing in the C calling convention. For example, in x86-64 Linux
214 convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
215 argument passing. These are registers R3-R6, which our generated
216 code may also be using; as a result, it's necessary to save these
217 values before doing a foreign call. This is done during initial
218 code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However,
219 one result of doing this is that the contents of these registers
220 may mysteriously change if referenced inside the arguments. This
221 is dangerous, so you'll need to disable inlining much in the same
222 way is done in cmm/CmmOpt.hs currently. We should fix this!
223 -}
224
225 ---------------------------------------------
226 -- Eq instance of CmmNode
227
228 deriving instance Eq (CmmNode e x)
229
230 ----------------------------------------------
231 -- Hoopl instances of CmmNode
232
233 instance NonLocal CmmNode where
234 entryLabel (CmmEntry l _) = l
235
236 successors (CmmBranch l) = [l]
237 successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
238 successors (CmmSwitch _ ids) = switchTargetsToList ids
239 successors (CmmCall {cml_cont=l}) = maybeToList l
240 successors (CmmForeignCall {succ=l}) = [l]
241
242
243 --------------------------------------------------
244 -- Various helper types
245
246 type CmmActual = CmmExpr
247 type CmmFormal = LocalReg
248
249 type UpdFrameOffset = ByteOff
250
251 -- | A convention maps a list of values (function arguments or return
252 -- values) to registers or stack locations.
253 data Convention
254 = NativeDirectCall
255 -- ^ top-level Haskell functions use @NativeDirectCall@, which
256 -- maps arguments to registers starting with R2, according to
257 -- how many registers are available on the platform. This
258 -- convention ignores R1, because for a top-level function call
259 -- the function closure is implicit, and doesn't need to be passed.
260 | NativeNodeCall
261 -- ^ non-top-level Haskell functions, which pass the address of
262 -- the function closure in R1 (regardless of whether R1 is a
263 -- real register or not), and the rest of the arguments in
264 -- registers or on the stack.
265 | NativeReturn
266 -- ^ a native return. The convention for returns depends on
267 -- how many values are returned: for just one value returned,
268 -- the appropriate register is used (R1, F1, etc.). regardless
269 -- of whether it is a real register or not. For multiple
270 -- values returned, they are mapped to registers or the stack.
271 | Slow
272 -- ^ Slow entry points: all args pushed on the stack
273 | GC
274 -- ^ Entry to the garbage collector: uses the node reg!
275 -- (TODO: I don't think we need this --SDM)
276 deriving( Eq )
277
278 data ForeignConvention
279 = ForeignConvention
280 CCallConv -- Which foreign-call convention
281 [ForeignHint] -- Extra info about the args
282 [ForeignHint] -- Extra info about the result
283 CmmReturnInfo
284 deriving Eq
285
286 data CmmReturnInfo
287 = CmmMayReturn
288 | CmmNeverReturns
289 deriving ( Eq )
290
291 data ForeignTarget -- The target of a foreign call
292 = ForeignTarget -- A foreign procedure
293 CmmExpr -- Its address
294 ForeignConvention -- Its calling convention
295 | PrimTarget -- A possibly-side-effecting machine operation
296 CallishMachOp -- Which one
297 deriving Eq
298
299 foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
300 foreignTargetHints target
301 = ( res_hints ++ repeat NoHint
302 , arg_hints ++ repeat NoHint )
303 where
304 (res_hints, arg_hints) =
305 case target of
306 PrimTarget op -> callishMachOpHints op
307 ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
308 (res_hints, arg_hints)
309
310 --------------------------------------------------
311 -- Instances of register and slot users / definers
312
313 instance UserOfRegs LocalReg (CmmNode e x) where
314 foldRegsUsed dflags f !z n = case n of
315 CmmAssign _ expr -> fold f z expr
316 CmmStore addr rval -> fold f (fold f z addr) rval
317 CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
318 CmmCondBranch expr _ _ _ -> fold f z expr
319 CmmSwitch expr _ -> fold f z expr
320 CmmCall {cml_target=tgt} -> fold f z tgt
321 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
322 _ -> z
323 where fold :: forall a b. UserOfRegs LocalReg a
324 => (b -> LocalReg -> b) -> b -> a -> b
325 fold f z n = foldRegsUsed dflags f z n
326
327 instance UserOfRegs GlobalReg (CmmNode e x) where
328 foldRegsUsed dflags f !z n = case n of
329 CmmAssign _ expr -> fold f z expr
330 CmmStore addr rval -> fold f (fold f z addr) rval
331 CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
332 CmmCondBranch expr _ _ _ -> fold f z expr
333 CmmSwitch expr _ -> fold f z expr
334 CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
335 CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
336 _ -> z
337 where fold :: forall a b. UserOfRegs GlobalReg a
338 => (b -> GlobalReg -> b) -> b -> a -> b
339 fold f z n = foldRegsUsed dflags f z n
340
341 instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
342 -- The (Ord r) in the context is necessary here
343 -- See Note [Recursive superclasses] in TcInstDcls
344 foldRegsUsed _ _ !z (PrimTarget _) = z
345 foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e
346
347 instance DefinerOfRegs LocalReg (CmmNode e x) where
348 foldRegsDefd dflags f !z n = case n of
349 CmmAssign lhs _ -> fold f z lhs
350 CmmUnsafeForeignCall _ fs _ -> fold f z fs
351 CmmForeignCall {res=res} -> fold f z res
352 _ -> z
353 where fold :: forall a b. DefinerOfRegs LocalReg a
354 => (b -> LocalReg -> b) -> b -> a -> b
355 fold f z n = foldRegsDefd dflags f z n
356
357 instance DefinerOfRegs GlobalReg (CmmNode e x) where
358 foldRegsDefd dflags f !z n = case n of
359 CmmAssign lhs _ -> fold f z lhs
360 CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt)
361 CmmCall {} -> fold f z activeRegs
362 CmmForeignCall {} -> fold f z activeRegs
363 -- See Note [Safe foreign calls clobber STG registers]
364 _ -> z
365 where fold :: forall a b. DefinerOfRegs GlobalReg a
366 => (b -> GlobalReg -> b) -> b -> a -> b
367 fold f z n = foldRegsDefd dflags f z n
368
369 platform = targetPlatform dflags
370 activeRegs = activeStgRegs platform
371 activeCallerSavesRegs = filter (callerSaves platform) activeRegs
372
373 foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
374 foreignTargetRegs _ = activeCallerSavesRegs
375
376 -- Note [Safe foreign calls clobber STG registers]
377 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
378 --
379 -- During stack layout phase every safe foreign call is expanded into a block
380 -- that contains unsafe foreign call (instead of safe foreign call) and ends
381 -- with a normal call (See Note [Foreign calls]). This means that we must
382 -- treat safe foreign call as if it was a normal call (because eventually it
383 -- will be). This is important if we try to run sinking pass before stack
384 -- layout phase. Consider this example of what might go wrong (this is cmm
385 -- code from stablename001 test). Here is code after common block elimination
386 -- (before stack layout):
387 --
388 -- c1q6:
389 -- _s1pf::P64 = R1;
390 -- _c1q8::I64 = performMajorGC;
391 -- I64[(young<c1q9> + 8)] = c1q9;
392 -- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...)
393 -- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
394 -- c1q9:
395 -- I64[(young<c1qb> + 8)] = c1qb;
396 -- R1 = _s1pc::P64;
397 -- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
398 --
399 -- If we run sinking pass now (still before stack layout) we will get this:
400 --
401 -- c1q6:
402 -- I64[(young<c1q9> + 8)] = c1q9;
403 -- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...)
404 -- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
405 -- c1q9:
406 -- I64[(young<c1qb> + 8)] = c1qb;
407 -- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call
408 -- R1 = _s1pc::P64;
409 -- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
410 --
411 -- Notice that _s1pf was sunk past a foreign call. When we run stack layout
412 -- safe call to performMajorGC will be turned into:
413 --
414 -- c1q6:
415 -- _s1pc::P64 = P64[Sp + 8];
416 -- I64[Sp - 8] = c1q9;
417 -- Sp = Sp - 8;
418 -- I64[I64[CurrentTSO + 24] + 16] = Sp;
419 -- P64[CurrentNursery + 8] = Hp + 8;
420 -- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,]
421 -- result hints: [PtrHint] suspendThread(BaseReg, 0);
422 -- call "ccall" arg hints: [] result hints: [] performMajorGC();
423 -- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint]
424 -- result hints: [PtrHint] resumeThread(_u1qI::I64);
425 -- BaseReg = _u1qJ::I64;
426 -- _u1qK::P64 = CurrentTSO;
427 -- _u1qL::P64 = I64[_u1qK::P64 + 24];
428 -- Sp = I64[_u1qL::P64 + 16];
429 -- SpLim = _u1qL::P64 + 192;
430 -- HpAlloc = 0;
431 -- Hp = I64[CurrentNursery + 8] - 8;
432 -- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
433 -- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
434 -- c1q9:
435 -- I64[(young<c1qb> + 8)] = c1qb;
436 -- _s1pf::P64 = R1; <------ INCORRECT!
437 -- R1 = _s1pc::P64;
438 -- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
439 --
440 -- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
441 -- call is clearly incorrect. This is what would happen if we assumed that
442 -- safe foreign call has the same semantics as unsafe foreign call. To prevent
443 -- this we need to treat safe foreign call as if was normal call.
444
445 -----------------------------------
446 -- mapping Expr in CmmNode
447
448 mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
449 mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
450 mapForeignTarget _ m@(PrimTarget _) = m
451
452 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
453 -- Take a transformer on expressions and apply it recursively.
454 -- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
455 -- then uses f to rewrite the resulting expression
456 wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
457 wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
458 wrapRecExp f e = f e
459
460 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
461 mapExp _ f@(CmmEntry{}) = f
462 mapExp _ m@(CmmComment _) = m
463 mapExp _ m@(CmmTick _) = m
464 mapExp f (CmmUnwind regs) = CmmUnwind (map (fmap f) regs)
465 mapExp f (CmmAssign r e) = CmmAssign r (f e)
466 mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
467 mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
468 mapExp _ l@(CmmBranch _) = l
469 mapExp f (CmmCondBranch e ti fi l) = CmmCondBranch (f e) ti fi l
470 mapExp f (CmmSwitch e ids) = CmmSwitch (f e) ids
471 mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
472 mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
473
474 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
475 mapExpDeep f = mapExp $ wrapRecExp f
476
477 ------------------------------------------------------------------------
478 -- mapping Expr in CmmNode, but not performing allocation if no changes
479
480 mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
481 mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
482 mapForeignTargetM _ (PrimTarget _) = Nothing
483
484 wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
485 -- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
486 -- then gives f a chance to rewrite the resulting expression
487 wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
488 wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
489 wrapRecExpM f e = f e
490
491 mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
492 mapExpM _ (CmmEntry{}) = Nothing
493 mapExpM _ (CmmComment _) = Nothing
494 mapExpM _ (CmmTick _) = Nothing
495 mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> f e >>= \e' -> pure (r,e')) regs
496 mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
497 mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
498 mapExpM _ (CmmBranch _) = Nothing
499 mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
500 mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
501 mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
502 mapExpM f (CmmUnsafeForeignCall tgt fs as)
503 = case mapForeignTargetM f tgt of
504 Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
505 Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
506 mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
507 = case mapForeignTargetM f tgt of
508 Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
509 Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
510
511 -- share as much as possible
512 mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
513 mapListM f xs = let (b, r) = mapListT f xs
514 in if b then Just r else Nothing
515
516 mapListJ :: (a -> Maybe a) -> [a] -> [a]
517 mapListJ f xs = snd (mapListT f xs)
518
519 mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
520 mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
521 where g (_, y, Nothing) (True, ys) = (True, y:ys)
522 g (_, _, Just y) (True, ys) = (True, y:ys)
523 g (ys', _, Nothing) (False, _) = (False, ys')
524 g (_, _, Just y) (False, ys) = (True, y:ys)
525
526 mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
527 mapExpDeepM f = mapExpM $ wrapRecExpM f
528
529 -----------------------------------
530 -- folding Expr in CmmNode
531
532 foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
533 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
534 foldExpForeignTarget _ (PrimTarget _) z = z
535
536 -- Take a folder on expressions and apply it recursively.
537 -- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
538 -- itself, delegating all the other CmmExpr forms to 'f'.
539 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
540 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
541 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
542 wrapRecExpf f e z = f e z
543
544 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
545 foldExp _ (CmmEntry {}) z = z
546 foldExp _ (CmmComment {}) z = z
547 foldExp _ (CmmTick {}) z = z
548 foldExp f (CmmUnwind xs) z = foldr f z (map snd xs)
549 foldExp f (CmmAssign _ e) z = f e z
550 foldExp f (CmmStore addr e) z = f addr $ f e z
551 foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
552 foldExp _ (CmmBranch _) z = z
553 foldExp f (CmmCondBranch e _ _ _) z = f e z
554 foldExp f (CmmSwitch e _) z = f e z
555 foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
556 foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
557
558 foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
559 foldExpDeep f = foldExp (wrapRecExpf f)
560
561 -- -----------------------------------------------------------------------------
562
563 mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
564 mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
565 mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
566 mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids)
567 mapSuccessors _ n = n
568
569 -- -----------------------------------------------------------------------------
570
571 -- | Tickish in Cmm context (annotations only)
572 type CmmTickish = Tickish ()
573
574 -- | Tick scope identifier, allowing us to reason about what
575 -- annotations in a Cmm block should scope over. We especially take
576 -- care to allow optimisations to reorganise blocks without losing
577 -- tick association in the process.
578 data CmmTickScope
579 = GlobalScope
580 -- ^ The global scope is the "root" of the scope graph. Every
581 -- scope is a sub-scope of the global scope. It doesn't make sense
582 -- to add ticks to this scope. On the other hand, this means that
583 -- setting this scope on a block means no ticks apply to it.
584
585 | SubScope !U.Unique CmmTickScope
586 -- ^ Constructs a new sub-scope to an existing scope. This allows
587 -- us to translate Core-style scoping rules (see @tickishScoped@)
588 -- into the Cmm world. Suppose the following code:
589 --
590 -- tick<1> case ... of
591 -- A -> tick<2> ...
592 -- B -> tick<3> ...
593 --
594 -- We want the top-level tick annotation to apply to blocks
595 -- generated for the A and B alternatives. We can achieve that by
596 -- generating tick<1> into a block with scope a, while the code
597 -- for alternatives A and B gets generated into sub-scopes a/b and
598 -- a/c respectively.
599
600 | CombinedScope CmmTickScope CmmTickScope
601 -- ^ A combined scope scopes over everything that the two given
602 -- scopes cover. It is therefore a sub-scope of either scope. This
603 -- is required for optimisations. Consider common block elimination:
604 --
605 -- A -> tick<2> case ... of
606 -- C -> [common]
607 -- B -> tick<3> case ... of
608 -- D -> [common]
609 --
610 -- We will generate code for the C and D alternatives, and figure
611 -- out afterwards that it's actually common code. Scoping rules
612 -- dictate that the resulting common block needs to be covered by
613 -- both tick<2> and tick<3>, therefore we need to construct a
614 -- scope that is a child to *both* scope. Now we can do that - if
615 -- we assign the scopes a/c and b/d to the common-ed up blocks,
616 -- the new block could have a combined tick scope a/c+b/d, which
617 -- both tick<2> and tick<3> apply to.
618
619 -- Note [CmmTick scoping details]:
620 --
621 -- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
622 -- same block. Note that as a result of this, optimisations making
623 -- tick scopes more specific can *reduce* the amount of code a tick
624 -- scopes over. Fixing this would require a separate @CmmTickScope@
625 -- field for @CmmTick@. Right now we do not do this simply because I
626 -- couldn't find an example where it actually mattered -- multiple
627 -- blocks within the same scope generally jump to each other, which
628 -- prevents common block elimination from happening in the first
629 -- place. But this is no strong reason, so if Cmm optimisations become
630 -- more involved in future this might have to be revisited.
631
632 -- | Output all scope paths.
633 scopeToPaths :: CmmTickScope -> [[U.Unique]]
634 scopeToPaths GlobalScope = [[]]
635 scopeToPaths (SubScope u s) = map (u:) (scopeToPaths s)
636 scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2
637
638 -- | Returns the head uniques of the scopes. This is based on the
639 -- assumption that the @Unique@ of @SubScope@ identifies the
640 -- underlying super-scope. Used for efficient equality and comparison,
641 -- see below.
642 scopeUniques :: CmmTickScope -> [U.Unique]
643 scopeUniques GlobalScope = []
644 scopeUniques (SubScope u _) = [u]
645 scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2
646
647 -- Equality and order is based on the head uniques defined above. We
648 -- take care to short-cut the (extremly) common cases.
649 instance Eq CmmTickScope where
650 GlobalScope == GlobalScope = True
651 GlobalScope == _ = False
652 _ == GlobalScope = False
653 (SubScope u _) == (SubScope u' _) = u == u'
654 (SubScope _ _) == _ = False
655 _ == (SubScope _ _) = False
656 scope == scope' =
657 sortBy nonDetCmpUnique (scopeUniques scope) ==
658 sortBy nonDetCmpUnique (scopeUniques scope')
659 -- This is still deterministic because
660 -- the order is the same for equal lists
661
662 -- This is non-deterministic but we do not currently support deterministic
663 -- code-generation. See Note [Unique Determinism and code generation]
664 -- See Note [No Ord for Unique]
665 instance Ord CmmTickScope where
666 compare GlobalScope GlobalScope = EQ
667 compare GlobalScope _ = LT
668 compare _ GlobalScope = GT
669 compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'
670 compare scope scope' = cmpList nonDetCmpUnique
671 (sortBy nonDetCmpUnique $ scopeUniques scope)
672 (sortBy nonDetCmpUnique $ scopeUniques scope')
673
674 instance Outputable CmmTickScope where
675 ppr GlobalScope = text "global"
676 ppr (SubScope us GlobalScope)
677 = ppr us
678 ppr (SubScope us s) = ppr s <> char '/' <> ppr us
679 ppr combined = parens $ hcat $ punctuate (char '+') $
680 map (hcat . punctuate (char '/') . map ppr . reverse) $
681 scopeToPaths combined
682
683 -- | Checks whether two tick scopes are sub-scopes of each other. True
684 -- if the two scopes are equal.
685 isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
686 isTickSubScope = cmp
687 where cmp _ GlobalScope = True
688 cmp GlobalScope _ = False
689 cmp (CombinedScope s1 s2) s' = cmp s1 s' && cmp s2 s'
690 cmp s (CombinedScope s1' s2') = cmp s s1' || cmp s s2'
691 cmp (SubScope u s) s'@(SubScope u' _) = u == u' || cmp s s'
692
693 -- | Combine two tick scopes. The new scope should be sub-scope of
694 -- both parameters. We simplfy automatically if one tick scope is a
695 -- sub-scope of the other already.
696 combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
697 combineTickScopes s1 s2
698 | s1 `isTickSubScope` s2 = s1
699 | s2 `isTickSubScope` s1 = s2
700 | otherwise = CombinedScope s1 s2