summaryrefslogtreecommitdiff
path: root/compiler/GHC/Cmm/Node.hs
blob: c809a99136d397da83369c3368f27a96e45203a9 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

-- CmmNode type for representation using Hoopl graphs.

module GHC.Cmm.Node (
     CmmNode(..), CmmFormal, CmmActual, CmmTickish,
     UpdFrameOffset, Convention(..),
     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
     CmmReturnInfo(..),
     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,

     -- * Tick scopes
     CmmTickScope(..), isTickSubScope, combineTickScopes,
  ) where

import GhcPrelude hiding (succ)

import GHC.Platform.Regs
import GHC.Cmm.Expr
import GHC.Cmm.Switch
import GHC.Driver.Session
import FastString
import ForeignCall
import Outputable
import GHC.Runtime.Heap.Layout
import GHC.Core (Tickish)
import qualified Unique as U

import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import Data.Maybe
import Data.List (tails,sortBy)
import Unique (nonDetCmpUnique)
import Util


------------------------
-- CmmNode

#define ULabel {-# UNPACK #-} !Label

data CmmNode e x where
  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O

  CmmComment :: FastString -> CmmNode O O

    -- Tick annotation, covering Cmm code in our tick scope. We only
    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
    -- See Note [CmmTick scoping details]
  CmmTick :: !CmmTickish -> CmmNode O O

    -- Unwind pseudo-instruction, encoding stack unwinding
    -- instructions for a debugger. This describes how to reconstruct
    -- the "old" value of a register if we want to navigate the stack
    -- up one frame. Having unwind information for @Sp@ will allow the
    -- debugger to "walk" the stack.
    --
    -- See Note [What is this unwinding business?] in Debug
  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O

  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
    -- Assign to register

  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
    -- Assign to memory location.  Size is
    -- given by cmmExprType of the rhs.

  CmmUnsafeForeignCall ::       -- An unsafe foreign call;
                                -- see Note [Foreign calls]
                                -- Like a "fat machine instruction"; can occur
                                -- in the middle of a block
      ForeignTarget ->          -- call target
      [CmmFormal] ->            -- zero or more results
      [CmmActual] ->            -- zero or more arguments
      CmmNode O O
      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
      -- See Note [Unsafe foreign calls clobber caller-save registers]
      --
      -- Invariant: the arguments and the ForeignTarget must not
      -- mention any registers for which GHC.Platform.callerSaves
      -- is True.  See Note [Register Parameter Passing].

  CmmBranch :: ULabel -> CmmNode O C
                                   -- Goto another block in the same procedure

  CmmCondBranch :: {                 -- conditional branch
      cml_pred :: CmmExpr,
      cml_true, cml_false :: ULabel,
      cml_likely :: Maybe Bool       -- likely result of the conditional,
                                     -- if known
  } -> CmmNode O C

  CmmSwitch
    :: CmmExpr       -- Scrutinee, of some integral type
    -> SwitchTargets -- Cases. See [Note SwitchTargets]
    -> CmmNode O C

  CmmCall :: {                -- A native call or tail call
      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!

      cml_cont :: Maybe Label,
          -- Label of continuation (Nothing for return or tail call)
          --
          -- Note [Continuation BlockIds]: these BlockIds are called
          -- Continuation BlockIds, and are the only BlockIds that can
          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
          -- (CmmStackSlot (Young b) _).

      cml_args_regs :: [GlobalReg],
          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
          -- to the call.  This is essential information for the
          -- native code generator's register allocator; without
          -- knowing which GlobalRegs are live it has to assume that
          -- they are all live.  This list should only include
          -- GlobalRegs that are mapped to real machine registers on
          -- the target platform.

      cml_args :: ByteOff,
          -- Byte offset, from the *old* end of the Area associated with
          -- the Label (if cml_cont = Nothing, then Old area), of
          -- youngest outgoing arg.  Set the stack pointer to this before
          -- transferring control.
          -- (NB: an update frame might also have been stored in the Old
          --      area, but it'll be in an older part than the args.)

      cml_ret_args :: ByteOff,
          -- For calls *only*, the byte offset for youngest returned value
          -- This is really needed at the *return* point rather than here
          -- at the call, but in practice it's convenient to record it here.

      cml_ret_off :: ByteOff
        -- For calls *only*, the byte offset of the base of the frame that
        -- must be described by the info table for the return point.
        -- The older words are an update frames, which have their own
        -- info-table and layout information

        -- From a liveness point of view, the stack words older than
        -- cml_ret_off are treated as live, even if the sequel of
        -- the call goes into a loop.
  } -> CmmNode O C

  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
                                -- Always the last node of a block
      tgt   :: ForeignTarget,   -- call target and convention
      res   :: [CmmFormal],     -- zero or more results
      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]
      succ  :: ULabel,          -- Label of continuation
      ret_args :: ByteOff,      -- same as cml_ret_args
      ret_off :: ByteOff,       -- same as cml_ret_off
      intrbl:: Bool             -- whether or not the call is interruptible
  } -> CmmNode O C

{- Note [Foreign calls]
~~~~~~~~~~~~~~~~~~~~~~~
A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
a CmmForeignCall call is used for *safe* foreign calls.

Unsafe ones are mostly easy: think of them as a "fat machine
instruction".  In particular, they do *not* kill all live registers,
just the registers they return to (there was a bit of code in GHC that
conservatively assumed otherwise.)  However, see [Register parameter passing].

Safe ones are trickier.  A safe foreign call
     r = f(x)
ultimately expands to
     push "return address"      -- Never used to return to;
                                -- just points an info table
     save registers into TSO
     call suspendThread
     r = f(x)                   -- Make the call
     call resumeThread
     restore registers
     pop "return address"
We cannot "lower" a safe foreign call to this sequence of Cmms, because
after we've saved Sp all the Cmm optimiser's assumptions are broken.

Note that a safe foreign call needs an info table.

So Safe Foreign Calls must remain as last nodes until the stack is
made manifest in GHC.Cmm.LayoutStack, where they are lowered into the above
sequence.
-}

{- Note [Unsafe foreign calls clobber caller-save registers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

A foreign call is defined to clobber any GlobalRegs that are mapped to
caller-saves machine registers (according to the prevailing C ABI).
GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves.

This is a design choice that makes it easier to generate code later.
We could instead choose to say that foreign calls do *not* clobber
caller-saves regs, but then we would have to figure out which regs
were live across the call later and insert some saves/restores.

Furthermore when we generate code we never have any GlobalRegs live
across a call, because they are always copied-in to LocalRegs and
copied-out again before making a call/jump.  So all we have to do is
avoid any code motion that would make a caller-saves GlobalReg live
across a foreign call during subsequent optimisations.
-}

{- Note [Register parameter passing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On certain architectures, some registers are utilized for parameter
passing in the C calling convention.  For example, in x86-64 Linux
convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
argument passing.  These are registers R3-R6, which our generated
code may also be using; as a result, it's necessary to save these
values before doing a foreign call.  This is done during initial
code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.  However,
one result of doing this is that the contents of these registers
may mysteriously change if referenced inside the arguments.  This
is dangerous, so you'll need to disable inlining much in the same
way is done in GHC.Cmm.Opt currently.  We should fix this!
-}

---------------------------------------------
-- Eq instance of CmmNode

deriving instance Eq (CmmNode e x)

----------------------------------------------
-- Hoopl instances of CmmNode

instance NonLocal CmmNode where
  entryLabel (CmmEntry l _) = l

  successors (CmmBranch l) = [l]
  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
  successors (CmmSwitch _ ids) = switchTargetsToList ids
  successors (CmmCall {cml_cont=l}) = maybeToList l
  successors (CmmForeignCall {succ=l}) = [l]


--------------------------------------------------
-- Various helper types

type CmmActual = CmmExpr
type CmmFormal = LocalReg

type UpdFrameOffset = ByteOff

-- | A convention maps a list of values (function arguments or return
-- values) to registers or stack locations.
data Convention
  = NativeDirectCall
       -- ^ top-level Haskell functions use @NativeDirectCall@, which
       -- maps arguments to registers starting with R2, according to
       -- how many registers are available on the platform.  This
       -- convention ignores R1, because for a top-level function call
       -- the function closure is implicit, and doesn't need to be passed.
  | NativeNodeCall
       -- ^ non-top-level Haskell functions, which pass the address of
       -- the function closure in R1 (regardless of whether R1 is a
       -- real register or not), and the rest of the arguments in
       -- registers or on the stack.
  | NativeReturn
       -- ^ a native return.  The convention for returns depends on
       -- how many values are returned: for just one value returned,
       -- the appropriate register is used (R1, F1, etc.). regardless
       -- of whether it is a real register or not.  For multiple
       -- values returned, they are mapped to registers or the stack.
  | Slow
       -- ^ Slow entry points: all args pushed on the stack
  | GC
       -- ^ Entry to the garbage collector: uses the node reg!
       -- (TODO: I don't think we need this --SDM)
  deriving( Eq )

data ForeignConvention
  = ForeignConvention
        CCallConv               -- Which foreign-call convention
        [ForeignHint]           -- Extra info about the args
        [ForeignHint]           -- Extra info about the result
        CmmReturnInfo
  deriving Eq

data CmmReturnInfo
  = CmmMayReturn
  | CmmNeverReturns
  deriving ( Eq )

data ForeignTarget        -- The target of a foreign call
  = ForeignTarget                -- A foreign procedure
        CmmExpr                  -- Its address
        ForeignConvention        -- Its calling convention
  | PrimTarget            -- A possibly-side-effecting machine operation
        CallishMachOp            -- Which one
  deriving Eq

foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints target
  = ( res_hints ++ repeat NoHint
    , arg_hints ++ repeat NoHint )
  where
    (res_hints, arg_hints) =
       case target of
          PrimTarget op -> callishMachOpHints op
          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
             (res_hints, arg_hints)

--------------------------------------------------
-- Instances of register and slot users / definers

instance UserOfRegs LocalReg (CmmNode e x) where
  foldRegsUsed dflags f !z n = case n of
    CmmAssign _ expr -> fold f z expr
    CmmStore addr rval -> fold f (fold f z addr) rval
    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
    CmmCondBranch expr _ _ _ -> fold f z expr
    CmmSwitch expr _ -> fold f z expr
    CmmCall {cml_target=tgt} -> fold f z tgt
    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
    _ -> z
    where fold :: forall a b. UserOfRegs LocalReg a
               => (b -> LocalReg -> b) -> b -> a -> b
          fold f z n = foldRegsUsed dflags f z n

instance UserOfRegs GlobalReg (CmmNode e x) where
  foldRegsUsed dflags f !z n = case n of
    CmmAssign _ expr -> fold f z expr
    CmmStore addr rval -> fold f (fold f z addr) rval
    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
    CmmCondBranch expr _ _ _ -> fold f z expr
    CmmSwitch expr _ -> fold f z expr
    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
    _ -> z
    where fold :: forall a b.  UserOfRegs GlobalReg a
               => (b -> GlobalReg -> b) -> b -> a -> b
          fold f z n = foldRegsUsed dflags f z n

instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
  -- The (Ord r) in the context is necessary here
  -- See Note [Recursive superclasses] in TcInstDcls
  foldRegsUsed _      _ !z (PrimTarget _)      = z
  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e

instance DefinerOfRegs LocalReg (CmmNode e x) where
  foldRegsDefd dflags f !z n = case n of
    CmmAssign lhs _ -> fold f z lhs
    CmmUnsafeForeignCall _ fs _ -> fold f z fs
    CmmForeignCall {res=res} -> fold f z res
    _ -> z
    where fold :: forall a b. DefinerOfRegs LocalReg a
               => (b -> LocalReg -> b) -> b -> a -> b
          fold f z n = foldRegsDefd dflags f z n

instance DefinerOfRegs GlobalReg (CmmNode e x) where
  foldRegsDefd dflags f !z n = case n of
    CmmAssign lhs _ -> fold f z lhs
    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
    CmmCall        {} -> fold f z activeRegs
    CmmForeignCall {} -> fold f z activeRegs
                      -- See Note [Safe foreign calls clobber STG registers]
    _ -> z
    where fold :: forall a b. DefinerOfRegs GlobalReg a
               => (b -> GlobalReg -> b) -> b -> a -> b
          fold f z n = foldRegsDefd dflags f z n

          platform = targetPlatform dflags
          activeRegs = activeStgRegs platform
          activeCallerSavesRegs = filter (callerSaves platform) activeRegs

          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
          foreignTargetRegs _ = activeCallerSavesRegs

-- Note [Safe foreign calls clobber STG registers]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- During stack layout phase every safe foreign call is expanded into a block
-- that contains unsafe foreign call (instead of safe foreign call) and ends
-- with a normal call (See Note [Foreign calls]). This means that we must
-- treat safe foreign call as if it was a normal call (because eventually it
-- will be). This is important if we try to run sinking pass before stack
-- layout phase. Consider this example of what might go wrong (this is cmm
-- code from stablename001 test). Here is code after common block elimination
-- (before stack layout):
--
--  c1q6:
--      _s1pf::P64 = R1;
--      _c1q8::I64 = performMajorGC;
--      I64[(young<c1q9> + 8)] = c1q9;
--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)
--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- If we run sinking pass now (still before stack layout) we will get this:
--
--  c1q6:
--      I64[(young<c1q9> + 8)] = c1q9;
--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)
--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
-- safe call to performMajorGC will be turned into:
--
--  c1q6:
--      _s1pc::P64 = P64[Sp + 8];
--      I64[Sp - 8] = c1q9;
--      Sp = Sp - 8;
--      I64[I64[CurrentTSO + 24] + 16] = Sp;
--      P64[CurrentNursery + 8] = Hp + 8;
--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]
--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);
--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();
--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]
--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);
--      BaseReg = _u1qJ::I64;
--      _u1qK::P64 = CurrentTSO;
--      _u1qL::P64 = I64[_u1qK::P64 + 24];
--      Sp = I64[_u1qL::P64 + 16];
--      SpLim = _u1qL::P64 + 192;
--      HpAlloc = 0;
--      Hp = I64[CurrentNursery + 8] - 8;
--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
--  c1q9:
--      I64[(young<c1qb> + 8)] = c1qb;
--      _s1pf::P64 = R1;         <------ INCORRECT!
--      R1 = _s1pc::P64;
--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
-- call is clearly incorrect. This is what would happen if we assumed that
-- safe foreign call has the same semantics as unsafe foreign call. To prevent
-- this we need to treat safe foreign call as if was normal call.

-----------------------------------
-- mapping Expr in GHC.Cmm.Node

mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
mapForeignTarget _   m@(PrimTarget _)      = m

wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
-- Take a transformer on expressions and apply it recursively.
-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
--                  then  uses f to rewrite the resulting expression
wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
wrapRecExp f e                    = f e

mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExp _ f@(CmmEntry{})                          = f
mapExp _ m@(CmmComment _)                        = m
mapExp _ m@(CmmTick _)                           = m
mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)
mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
mapExp _ l@(CmmBranch _)                         = l
mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l
mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids
mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}
mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl

mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep f = mapExp $ wrapRecExp f

------------------------------------------------------------------------
-- mapping Expr in GHC.Cmm.Node, but not performing allocation if no changes

mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
mapForeignTargetM _ (PrimTarget _)      = Nothing

wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
--                   then  gives f a chance to rewrite the resulting expression
wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)
wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
wrapRecExpM f e                    = f e

mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM _ (CmmEntry{})              = Nothing
mapExpM _ (CmmComment _)            = Nothing
mapExpM _ (CmmTick _)               = Nothing
mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs
mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
mapExpM _ (CmmBranch _)             = Nothing
mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e
mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
mapExpM f (CmmUnsafeForeignCall tgt fs as)
    = case mapForeignTargetM f tgt of
        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
    = case mapForeignTargetM f tgt of
        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as

-- share as much as possible
mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
mapListM f xs = let (b, r) = mapListT f xs
                in if b then Just r else Nothing

mapListJ :: (a -> Maybe a) -> [a] -> [a]
mapListJ f xs = snd (mapListT f xs)

mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)
          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)
          g (ys', _, Nothing) (False, _)  = (False, ys')
          g (_,   _, Just y)  (False, ys) = (True,  y:ys)

mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpDeepM f = mapExpM $ wrapRecExpM f

-----------------------------------
-- folding Expr in GHC.Cmm.Node

foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
foldExpForeignTarget _   (PrimTarget _)      z = z

-- Take a folder on expressions and apply it recursively.
-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
-- itself, delegating all the other CmmExpr forms to 'f'.
wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
wrapRecExpf f e                  z = f e z

foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp _ (CmmEntry {}) z                         = z
foldExp _ (CmmComment {}) z                       = z
foldExp _ (CmmTick {}) z                          = z
foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)
foldExp f (CmmAssign _ e) z                       = f e z
foldExp f (CmmStore addr e) z                     = f addr $ f e z
foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
foldExp _ (CmmBranch _) z                         = z
foldExp f (CmmCondBranch e _ _ _) z               = f e z
foldExp f (CmmSwitch e _) z                       = f e z
foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args

foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExpDeep f = foldExp (wrapRecExpf f)

-- -----------------------------------------------------------------------------

mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)
mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)
mapSuccessors _ n = n

mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
                     -> (CmmNode O C, [a])
mapCollectSuccessors f (CmmBranch bid)
  = let (bid', acc) = f bid in (CmmBranch bid', [acc])
mapCollectSuccessors f (CmmCondBranch p y n l)
  = let (bidt, acct) = f y
        (bidf, accf) = f n
    in  (CmmCondBranch p bidt bidf l, [accf, acct])
mapCollectSuccessors f (CmmSwitch e ids)
  = let lbls = switchTargetsToList ids :: [Label]
        lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)
    in ( CmmSwitch e
          (mapSwitchTargets
            (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)
          , map snd (mapElems lblMap)
        )
mapCollectSuccessors _ n = (n, [])

-- -----------------------------------------------------------------------------

-- | Tickish in Cmm context (annotations only)
type CmmTickish = Tickish ()

-- | Tick scope identifier, allowing us to reason about what
-- annotations in a Cmm block should scope over. We especially take
-- care to allow optimisations to reorganise blocks without losing
-- tick association in the process.
data CmmTickScope
  = GlobalScope
    -- ^ The global scope is the "root" of the scope graph. Every
    -- scope is a sub-scope of the global scope. It doesn't make sense
    -- to add ticks to this scope. On the other hand, this means that
    -- setting this scope on a block means no ticks apply to it.

  | SubScope !U.Unique CmmTickScope
    -- ^ Constructs a new sub-scope to an existing scope. This allows
    -- us to translate Core-style scoping rules (see @tickishScoped@)
    -- into the Cmm world. Suppose the following code:
    --
    --   tick<1> case ... of
    --             A -> tick<2> ...
    --             B -> tick<3> ...
    --
    -- We want the top-level tick annotation to apply to blocks
    -- generated for the A and B alternatives. We can achieve that by
    -- generating tick<1> into a block with scope a, while the code
    -- for alternatives A and B gets generated into sub-scopes a/b and
    -- a/c respectively.

  | CombinedScope CmmTickScope CmmTickScope
    -- ^ A combined scope scopes over everything that the two given
    -- scopes cover. It is therefore a sub-scope of either scope. This
    -- is required for optimisations. Consider common block elimination:
    --
    --   A -> tick<2> case ... of
    --     C -> [common]
    --   B -> tick<3> case ... of
    --     D -> [common]
    --
    -- We will generate code for the C and D alternatives, and figure
    -- out afterwards that it's actually common code. Scoping rules
    -- dictate that the resulting common block needs to be covered by
    -- both tick<2> and tick<3>, therefore we need to construct a
    -- scope that is a child to *both* scope. Now we can do that - if
    -- we assign the scopes a/c and b/d to the common-ed up blocks,
    -- the new block could have a combined tick scope a/c+b/d, which
    -- both tick<2> and tick<3> apply to.

-- Note [CmmTick scoping details]:
--
-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
-- same block. Note that as a result of this, optimisations making
-- tick scopes more specific can *reduce* the amount of code a tick
-- scopes over. Fixing this would require a separate @CmmTickScope@
-- field for @CmmTick@. Right now we do not do this simply because I
-- couldn't find an example where it actually mattered -- multiple
-- blocks within the same scope generally jump to each other, which
-- prevents common block elimination from happening in the first
-- place. But this is no strong reason, so if Cmm optimisations become
-- more involved in future this might have to be revisited.

-- | Output all scope paths.
scopeToPaths :: CmmTickScope -> [[U.Unique]]
scopeToPaths GlobalScope           = [[]]
scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)
scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2

-- | Returns the head uniques of the scopes. This is based on the
-- assumption that the @Unique@ of @SubScope@ identifies the
-- underlying super-scope. Used for efficient equality and comparison,
-- see below.
scopeUniques :: CmmTickScope -> [U.Unique]
scopeUniques GlobalScope           = []
scopeUniques (SubScope u _)        = [u]
scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2

-- Equality and order is based on the head uniques defined above. We
-- take care to short-cut the (extremely) common cases.
instance Eq CmmTickScope where
  GlobalScope    == GlobalScope     = True
  GlobalScope    == _               = False
  _              == GlobalScope     = False
  (SubScope u _) == (SubScope u' _) = u == u'
  (SubScope _ _) == _               = False
  _              == (SubScope _ _)  = False
  scope          == scope'          =
    sortBy nonDetCmpUnique (scopeUniques scope) ==
    sortBy nonDetCmpUnique (scopeUniques scope')
    -- This is still deterministic because
    -- the order is the same for equal lists

-- This is non-deterministic but we do not currently support deterministic
-- code-generation. See Note [Unique Determinism and code generation]
-- See Note [No Ord for Unique]
instance Ord CmmTickScope where
  compare GlobalScope    GlobalScope     = EQ
  compare GlobalScope    _               = LT
  compare _              GlobalScope     = GT
  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'
  compare scope scope'                   = cmpList nonDetCmpUnique
     (sortBy nonDetCmpUnique $ scopeUniques scope)
     (sortBy nonDetCmpUnique $ scopeUniques scope')

instance Outputable CmmTickScope where
  ppr GlobalScope     = text "global"
  ppr (SubScope us GlobalScope)
                      = ppr us
  ppr (SubScope us s) = ppr s <> char '/' <> ppr us
  ppr combined        = parens $ hcat $ punctuate (char '+') $
                        map (hcat . punctuate (char '/') . map ppr . reverse) $
                        scopeToPaths combined

-- | Checks whether two tick scopes are sub-scopes of each other. True
-- if the two scopes are equal.
isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
isTickSubScope = cmp
  where cmp _              GlobalScope             = True
        cmp GlobalScope    _                       = False
        cmp (CombinedScope s1 s2) s'               = cmp s1 s' && cmp s2 s'
        cmp s              (CombinedScope s1' s2') = cmp s s1' || cmp s s2'
        cmp (SubScope u s) s'@(SubScope u' _)      = u == u' || cmp s s'

-- | Combine two tick scopes. The new scope should be sub-scope of
-- both parameters. We simplify automatically if one tick scope is a
-- sub-scope of the other already.
combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
combineTickScopes s1 s2
  | s1 `isTickSubScope` s2 = s1
  | s2 `isTickSubScope` s1 = s2
  | otherwise              = CombinedScope s1 s2