{-# LANGUAGE GADTs #-}
module GHC.Cmm.Sink (
     cmmSink
  ) where

import GHC.Prelude

import GHC.Cmm
import GHC.Cmm.Opt
import GHC.Cmm.Liveness
import GHC.Cmm.Utils
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Platform.Regs

import GHC.Platform
import GHC.Driver.Session
import GHC.Types.Unique
import GHC.Types.Unique.FM

import qualified Data.IntSet as IntSet
import Data.List (partition)
import qualified Data.Set as Set
import Data.Maybe

-- Compact sets for membership tests of local variables.

type LRegSet = IntSet.IntSet

emptyLRegSet :: LRegSet
emptyLRegSet :: LRegSet
emptyLRegSet = LRegSet
IntSet.empty

nullLRegSet :: LRegSet -> Bool
nullLRegSet :: LRegSet -> Bool
nullLRegSet = LRegSet -> Bool
IntSet.null

insertLRegSet :: LocalReg -> LRegSet -> LRegSet
insertLRegSet :: LocalReg -> LRegSet -> LRegSet
insertLRegSet LocalReg
l = Int -> LRegSet -> LRegSet
IntSet.insert (Unique -> Int
getKey (LocalReg -> Unique
forall a. Uniquable a => a -> Unique
getUnique LocalReg
l))

elemLRegSet :: LocalReg -> LRegSet -> Bool
elemLRegSet :: LocalReg -> LRegSet -> Bool
elemLRegSet LocalReg
l = Int -> LRegSet -> Bool
IntSet.member (Unique -> Int
getKey (LocalReg -> Unique
forall a. Uniquable a => a -> Unique
getUnique LocalReg
l))

-- -----------------------------------------------------------------------------
-- Sinking and inlining

-- This is an optimisation pass that
--  (a) moves assignments closer to their uses, to reduce register pressure
--  (b) pushes assignments into a single branch of a conditional if possible
--  (c) inlines assignments to registers that are mentioned only once
--  (d) discards dead assignments
--
-- This tightens up lots of register-heavy code.  It is particularly
-- helpful in the Cmm generated by the Stg->Cmm code generator, in
-- which every function starts with a copyIn sequence like:
--
--    x1 = R1
--    x2 = Sp[8]
--    x3 = Sp[16]
--    if (Sp - 32 < SpLim) then L1 else L2
--
-- we really want to push the x1..x3 assignments into the L2 branch.
--
-- Algorithm:
--
--  * Start by doing liveness analysis.
--
--  * Keep a list of assignments A; earlier ones may refer to later ones.
--    Currently we only sink assignments to local registers, because we don't
--    have liveness information about global registers.
--
--  * Walk forwards through the graph, look at each node N:
--
--    * If it is a dead assignment, i.e. assignment to a register that is
--      not used after N, discard it.
--
--    * Try to inline based on current list of assignments
--      * If any assignments in A (1) occur only once in N, and (2) are
--        not live after N, inline the assignment and remove it
--        from A.
--
--      * If an assignment in A is cheap (RHS is local register), then
--        inline the assignment and keep it in A in case it is used afterwards.
--
--      * Otherwise don't inline.
--
--    * If N is assignment to a local register pick up the assignment
--      and add it to A.
--
--    * If N is not an assignment to a local register:
--      * remove any assignments from A that conflict with N, and
--        place them before N in the current block.  We call this
--        "dropping" the assignments.
--
--      * An assignment conflicts with N if it:
--        - assigns to a register mentioned in N
--        - mentions a register assigned by N
--        - reads from memory written by N
--      * do this recursively, dropping dependent assignments
--
--    * At an exit node:
--      * drop any assignments that are live on more than one successor
--        and are not trivial
--      * if any successor has more than one predecessor (a join-point),
--        drop everything live in that successor. Since we only propagate
--        assignments that are not dead at the successor, we will therefore
--        eliminate all assignments dead at this point. Thus analysis of a
--        join-point will always begin with an empty list of assignments.
--
--
-- As a result of above algorithm, sinking deletes some dead assignments
-- (transitively, even).  This isn't as good as removeDeadAssignments,
-- but it's much cheaper.

-- -----------------------------------------------------------------------------
-- things that we aren't optimising very well yet.
--
-- -----------
-- (1) From GHC's FastString.hashStr:
--
--  s2ay:
--      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;
--  c2gn:
--      R1 = _s2au::I64;
--      call (I64[Sp])(R1) args: 8, res: 0, upd: 8;
--  c2gp:
--      _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128,
--                                 4091);
--      _s2an::I64 = _s2an::I64 + 1;
--      _s2au::I64 = _s2cO::I64;
--      goto s2ay;
--
-- a nice loop, but we didn't eliminate the silly assignment at the end.
-- See Note [dependent assignments], which would probably fix this.
-- This is #8336.
--
-- -----------
-- (2) From stg_atomically_frame in PrimOps.cmm
--
-- We have a diamond control flow:
--
--     x = ...
--       |
--      / \
--     A   B
--      \ /
--       |
--    use of x
--
-- Now x won't be sunk down to its use, because we won't push it into
-- both branches of the conditional.  We certainly do have to check
-- that we can sink it past all the code in both A and B, but having
-- discovered that, we could sink it to its use.
--

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

type Assignment = (LocalReg, CmmExpr, AbsMem)
  -- Assignment caches AbsMem, an abstraction of the memory read by
  -- the RHS of the assignment.

type Assignments = [Assignment]
  -- A sequence of assignments; kept in *reverse* order
  -- So the list [ x=e1, y=e2 ] means the sequence of assignments
  --     y = e2
  --     x = e1

cmmSink :: DynFlags -> CmmGraph -> CmmGraph
cmmSink :: DynFlags -> CmmGraph -> CmmGraph
cmmSink DynFlags
dflags CmmGraph
graph = BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
graph) ([CmmBlock] -> CmmGraph) -> [CmmBlock] -> CmmGraph
forall a b. (a -> b) -> a -> b
$ LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink LabelMap Assignments
forall (map :: * -> *) a. IsMap map => map a
mapEmpty ([CmmBlock] -> [CmmBlock]) -> [CmmBlock] -> [CmmBlock]
forall a b. (a -> b) -> a -> b
$ [CmmBlock]
blocks
  where
  liveness :: BlockEntryLiveness LocalReg
liveness = DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness DynFlags
dflags CmmGraph
graph
  getLive :: BlockId -> Set LocalReg
getLive BlockId
l = Set LocalReg
-> KeyOf LabelMap -> BlockEntryLiveness LocalReg -> Set LocalReg
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault Set LocalReg
forall a. Set a
Set.empty KeyOf LabelMap
BlockId
l BlockEntryLiveness LocalReg
liveness

  blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
graph

  join_pts :: LabelMap Int
join_pts = [CmmBlock] -> LabelMap Int
findJoinPoints [CmmBlock]
blocks

  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink LabelMap Assignments
_ [] = []
  sink LabelMap Assignments
sunk (CmmBlock
b:[CmmBlock]
bs) =
    -- pprTrace "sink" (ppr lbl) $
    CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin CmmNode C O
first Block CmmNode O O
final_middle CmmNode O C
final_last CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink LabelMap Assignments
sunk' [CmmBlock]
bs
    where
      platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      lbl :: BlockId
lbl = CmmBlock -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
b
      (CmmNode C O
first, Block CmmNode O O
middle, CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
b

      succs :: [BlockId]
succs = CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last

      -- Annotate the middle nodes with the registers live *after*
      -- the node.  This will help us decide whether we can inline
      -- an assignment in the current node or not.
      live :: Set LocalReg
live = [Set LocalReg] -> Set LocalReg
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((BlockId -> Set LocalReg) -> [BlockId] -> [Set LocalReg]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> Set LocalReg
getLive [BlockId]
succs)
      live_middle :: Set LocalReg
live_middle = DynFlags -> CmmNode O C -> Set LocalReg -> Set LocalReg
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill DynFlags
dflags CmmNode O C
last Set LocalReg
live
      ann_middles :: [(Set LocalReg, CmmNode O O)]
ann_middles = DynFlags
-> Set LocalReg -> [CmmNode O O] -> [(Set LocalReg, CmmNode O O)]
annotate DynFlags
dflags Set LocalReg
live_middle (Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
middle)

      -- Now sink and inline in this block
      (Block CmmNode O O
middle', Assignments
assigs) = DynFlags
-> [(Set LocalReg, CmmNode O O)]
-> Assignments
-> (Block CmmNode O O, Assignments)
walk DynFlags
dflags [(Set LocalReg, CmmNode O O)]
ann_middles (Assignments
-> KeyOf LabelMap -> LabelMap Assignments -> Assignments
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault [] KeyOf LabelMap
BlockId
lbl LabelMap Assignments
sunk)
      fold_last :: CmmNode O C
fold_last = Platform -> CmmNode O C -> CmmNode O C
forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> CmmNode e x
constantFoldNode Platform
platform CmmNode O C
last
      (CmmNode O C
final_last, Assignments
assigs') = DynFlags
-> Set LocalReg
-> CmmNode O C
-> Assignments
-> (CmmNode O C, Assignments)
forall (x :: Extensibility).
DynFlags
-> Set LocalReg
-> CmmNode O x
-> Assignments
-> (CmmNode O x, Assignments)
tryToInline DynFlags
dflags Set LocalReg
live CmmNode O C
fold_last Assignments
assigs

      -- We cannot sink into join points (successors with more than
      -- one predecessor), so identify the join points and the set
      -- of registers live in them.
      ([BlockId]
joins, [BlockId]
nonjoins) = (BlockId -> Bool) -> [BlockId] -> ([BlockId], [BlockId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (KeyOf LabelMap -> LabelMap Int -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
`mapMember` LabelMap Int
join_pts) [BlockId]
succs
      live_in_joins :: Set LocalReg
live_in_joins = [Set LocalReg] -> Set LocalReg
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((BlockId -> Set LocalReg) -> [BlockId] -> [Set LocalReg]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> Set LocalReg
getLive [BlockId]
joins)

      -- We do not want to sink an assignment into multiple branches,
      -- so identify the set of registers live in multiple successors.
      -- This is made more complicated because when we sink an assignment
      -- into one branch, this might change the set of registers that are
      -- now live in multiple branches.
      init_live_sets :: [Set LocalReg]
init_live_sets = (BlockId -> Set LocalReg) -> [BlockId] -> [Set LocalReg]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> Set LocalReg
getLive [BlockId]
nonjoins
      live_in_multi :: [Set a] -> a -> Bool
live_in_multi [Set a]
live_sets a
r =
         case (Set a -> Bool) -> [Set a] -> [Set a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
r) [Set a]
live_sets of
           (Set a
_one:Set a
_two:[Set a]
_) -> Bool
True
           [Set a]
_ -> Bool
False

      -- Now, drop any assignments that we will not sink any further.
      ([CmmNode O O]
dropped_last, Assignments
assigs'') = DynFlags
-> (Assignment -> [Set LocalReg] -> (Bool, [Set LocalReg]))
-> [Set LocalReg]
-> Assignments
-> ([CmmNode O O], Assignments)
forall s.
DynFlags
-> (Assignment -> s -> (Bool, s))
-> s
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignments DynFlags
dflags Assignment -> [Set LocalReg] -> (Bool, [Set LocalReg])
drop_if [Set LocalReg]
init_live_sets Assignments
assigs'

      drop_if :: Assignment -> [Set LocalReg] -> (Bool, [Set LocalReg])
drop_if a :: Assignment
a@(LocalReg
r,CmmExpr
rhs,AbsMem
_) [Set LocalReg]
live_sets = (Bool
should_drop, [Set LocalReg]
live_sets')
          where
            should_drop :: Bool
should_drop =  DynFlags -> Assignment -> CmmNode O C -> Bool
forall (x :: Extensibility).
DynFlags -> Assignment -> CmmNode O x -> Bool
conflicts DynFlags
dflags Assignment
a CmmNode O C
final_last
                        Bool -> Bool -> Bool
|| Bool -> Bool
not (DynFlags -> CmmExpr -> Bool
isTrivial DynFlags
dflags CmmExpr
rhs) Bool -> Bool -> Bool
&& [Set LocalReg] -> LocalReg -> Bool
forall {a}. Ord a => [Set a] -> a -> Bool
live_in_multi [Set LocalReg]
live_sets LocalReg
r
                        Bool -> Bool -> Bool
|| LocalReg
r LocalReg -> Set LocalReg -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set LocalReg
live_in_joins

            live_sets' :: [Set LocalReg]
live_sets' | Bool
should_drop = [Set LocalReg]
live_sets
                       | Bool
otherwise   = (Set LocalReg -> Set LocalReg) -> [Set LocalReg] -> [Set LocalReg]
forall a b. (a -> b) -> [a] -> [b]
map Set LocalReg -> Set LocalReg
upd [Set LocalReg]
live_sets

            upd :: Set LocalReg -> Set LocalReg
upd Set LocalReg
set | LocalReg
r LocalReg -> Set LocalReg -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set LocalReg
set = Set LocalReg
set Set LocalReg -> Set LocalReg -> Set LocalReg
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set LocalReg
live_rhs
                    | Bool
otherwise          = Set LocalReg
set

            live_rhs :: Set LocalReg
live_rhs = DynFlags
-> (Set LocalReg -> LocalReg -> Set LocalReg)
-> Set LocalReg
-> CmmExpr
-> Set LocalReg
forall r a b.
UserOfRegs r a =>
DynFlags -> (b -> r -> b) -> b -> a -> b
foldRegsUsed DynFlags
dflags Set LocalReg -> LocalReg -> Set LocalReg
forall r. Ord r => RegSet r -> r -> RegSet r
extendRegSet Set LocalReg
forall a. Set a
emptyRegSet CmmExpr
rhs

      final_middle :: Block CmmNode O O
final_middle = (Block CmmNode O O -> CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> [CmmNode O O] -> Block CmmNode O O
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
blockSnoc Block CmmNode O O
middle' [CmmNode O O]
dropped_last

      sunk' :: LabelMap Assignments
sunk' = LabelMap Assignments
-> LabelMap Assignments -> LabelMap Assignments
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
mapUnion LabelMap Assignments
sunk (LabelMap Assignments -> LabelMap Assignments)
-> LabelMap Assignments -> LabelMap Assignments
forall a b. (a -> b) -> a -> b
$
                 [(KeyOf LabelMap, Assignments)] -> LabelMap Assignments
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
BlockId
l, DynFlags -> Set LocalReg -> Assignments -> Assignments
filterAssignments DynFlags
dflags (BlockId -> Set LocalReg
getLive BlockId
l) Assignments
assigs'')
                             | BlockId
l <- [BlockId]
succs ]

{- TODO: enable this later, when we have some good tests in place to
   measure the effect and tune it.

-- small: an expression we don't mind duplicating
isSmall :: CmmExpr -> Bool
isSmall (CmmReg (CmmLocal _)) = True  --
isSmall (CmmLit _) = True
isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y
isSmall (CmmRegOff (CmmLocal _) _) = True
isSmall _ = False
-}

--
-- We allow duplication of trivial expressions: registers (both local and
-- global) and literals.
--
isTrivial :: DynFlags -> CmmExpr -> Bool
isTrivial :: DynFlags -> CmmExpr -> Bool
isTrivial DynFlags
_ (CmmReg (CmmLocal LocalReg
_)) = Bool
True
isTrivial DynFlags
dflags (CmmReg (CmmGlobal GlobalReg
r)) = -- see Note [Inline GlobalRegs?]
  if Arch -> Bool
isARM (Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags))
  then Bool
True -- CodeGen.Platform.ARM does not have globalRegMaybe
  else Maybe RealReg -> Bool
forall a. Maybe a -> Bool
isJust (Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe (DynFlags -> Platform
targetPlatform DynFlags
dflags) GlobalReg
r)
  -- GlobalRegs that are loads from BaseReg are not trivial
isTrivial DynFlags
_ (CmmLit CmmLit
_) = Bool
True
isTrivial DynFlags
_ CmmExpr
_          = Bool
False

--
-- annotate each node with the set of registers live *after* the node
--
annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]
annotate :: DynFlags
-> Set LocalReg -> [CmmNode O O] -> [(Set LocalReg, CmmNode O O)]
annotate DynFlags
dflags Set LocalReg
live [CmmNode O O]
nodes = (Set LocalReg, [(Set LocalReg, CmmNode O O)])
-> [(Set LocalReg, CmmNode O O)]
forall a b. (a, b) -> b
snd ((Set LocalReg, [(Set LocalReg, CmmNode O O)])
 -> [(Set LocalReg, CmmNode O O)])
-> (Set LocalReg, [(Set LocalReg, CmmNode O O)])
-> [(Set LocalReg, CmmNode O O)]
forall a b. (a -> b) -> a -> b
$ (CmmNode O O
 -> (Set LocalReg, [(Set LocalReg, CmmNode O O)])
 -> (Set LocalReg, [(Set LocalReg, CmmNode O O)]))
-> (Set LocalReg, [(Set LocalReg, CmmNode O O)])
-> [CmmNode O O]
-> (Set LocalReg, [(Set LocalReg, CmmNode O O)])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmNode O O
-> (Set LocalReg, [(Set LocalReg, CmmNode O O)])
-> (Set LocalReg, [(Set LocalReg, CmmNode O O)])
ann (Set LocalReg
live,[]) [CmmNode O O]
nodes
  where ann :: CmmNode O O
-> (Set LocalReg, [(Set LocalReg, CmmNode O O)])
-> (Set LocalReg, [(Set LocalReg, CmmNode O O)])
ann CmmNode O O
n (Set LocalReg
live,[(Set LocalReg, CmmNode O O)]
nodes) = (DynFlags -> CmmNode O O -> Set LocalReg -> Set LocalReg
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill DynFlags
dflags CmmNode O O
n Set LocalReg
live, (Set LocalReg
live,CmmNode O O
n) (Set LocalReg, CmmNode O O)
-> [(Set LocalReg, CmmNode O O)] -> [(Set LocalReg, CmmNode O O)]
forall a. a -> [a] -> [a]
: [(Set LocalReg, CmmNode O O)]
nodes)

--
-- Find the blocks that have multiple successors (join points)
--
findJoinPoints :: [CmmBlock] -> LabelMap Int
findJoinPoints :: [CmmBlock] -> LabelMap Int
findJoinPoints [CmmBlock]
blocks = (Int -> Bool) -> LabelMap Int -> LabelMap Int
forall (map :: * -> *) a.
IsMap map =>
(a -> Bool) -> map a -> map a
mapFilter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1) LabelMap Int
succ_counts
 where
  all_succs :: [BlockId]
all_succs = (CmmBlock -> [BlockId]) -> [CmmBlock] -> [BlockId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CmmBlock -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors [CmmBlock]
blocks

  succ_counts :: LabelMap Int
  succ_counts :: LabelMap Int
succ_counts = (BlockId -> LabelMap Int -> LabelMap Int)
-> LabelMap Int -> [BlockId] -> LabelMap Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\BlockId
l -> (Int -> Int -> Int)
-> KeyOf LabelMap -> Int -> LabelMap Int -> LabelMap Int
forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) KeyOf LabelMap
BlockId
l Int
1) LabelMap Int
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [BlockId]
all_succs

--
-- filter the list of assignments to remove any assignments that
-- are not live in a continuation.
--
filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments
filterAssignments :: DynFlags -> Set LocalReg -> Assignments -> Assignments
filterAssignments DynFlags
dflags Set LocalReg
live Assignments
assigs = Assignments -> Assignments
forall a. [a] -> [a]
reverse (Assignments -> Assignments -> Assignments
go Assignments
assigs [])
  where go :: Assignments -> Assignments -> Assignments
go []             Assignments
kept = Assignments
kept
        go (a :: Assignment
a@(LocalReg
r,CmmExpr
_,AbsMem
_):Assignments
as) Assignments
kept | Bool
needed    = Assignments -> Assignments -> Assignments
go Assignments
as (Assignment
aAssignment -> Assignments -> Assignments
forall a. a -> [a] -> [a]
:Assignments
kept)
                               | Bool
otherwise = Assignments -> Assignments -> Assignments
go Assignments
as Assignments
kept
           where
              needed :: Bool
needed = LocalReg
r LocalReg -> Set LocalReg -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set LocalReg
live
                       Bool -> Bool -> Bool
|| (CmmNode O O -> Bool) -> [CmmNode O O] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (DynFlags -> Assignment -> CmmNode O O -> Bool
forall (x :: Extensibility).
DynFlags -> Assignment -> CmmNode O x -> Bool
conflicts DynFlags
dflags Assignment
a) ((Assignment -> CmmNode O O) -> Assignments -> [CmmNode O O]
forall a b. (a -> b) -> [a] -> [b]
map Assignment -> CmmNode O O
toNode Assignments
kept)
                       --  Note that we must keep assignments that are
                       -- referred to by other assignments we have
                       -- already kept.

-- -----------------------------------------------------------------------------
-- Walk through the nodes of a block, sinking and inlining assignments
-- as we go.
--
-- On input we pass in a:
--    * list of nodes in the block
--    * a list of assignments that appeared *before* this block and
--      that are being sunk.
--
-- On output we get:
--    * a new block
--    * a list of assignments that will be placed *after* that block.
--

walk :: DynFlags
     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with
                                        -- the set of registers live *after*
                                        -- this node.

     -> Assignments                     -- The current list of
                                        -- assignments we are sinking.
                                        -- Earlier assignments may refer
                                        -- to later ones.

     -> ( Block CmmNode O O             -- The new block
        , Assignments                   -- Assignments to sink further
        )

walk :: DynFlags
-> [(Set LocalReg, CmmNode O O)]
-> Assignments
-> (Block CmmNode O O, Assignments)
walk DynFlags
dflags [(Set LocalReg, CmmNode O O)]
nodes Assignments
assigs = [(Set LocalReg, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [(Set LocalReg, CmmNode O O)]
nodes Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock Assignments
assigs
 where
   go :: [(Set LocalReg, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go []               Block CmmNode O O
block Assignments
as = (Block CmmNode O O
block, Assignments
as)
   go ((Set LocalReg
live,CmmNode O O
node):[(Set LocalReg, CmmNode O O)]
ns) Block CmmNode O O
block Assignments
as
    | CmmNode O O -> Set LocalReg -> Bool
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Set LocalReg -> Bool
shouldDiscard CmmNode O O
node Set LocalReg
live             = [(Set LocalReg, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [(Set LocalReg, CmmNode O O)]
ns Block CmmNode O O
block Assignments
as
       -- discard dead assignment
    | Just Assignment
a <- Platform -> CmmNode O O -> Maybe Assignment
forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> Maybe Assignment
shouldSink Platform
platform CmmNode O O
node2 = [(Set LocalReg, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [(Set LocalReg, CmmNode O O)]
ns Block CmmNode O O
block (Assignment
a Assignment -> Assignments -> Assignments
forall a. a -> [a] -> [a]
: Assignments
as1)
    | Bool
otherwise                           = [(Set LocalReg, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [(Set LocalReg, CmmNode O O)]
ns Block CmmNode O O
block' Assignments
as'
    where
      platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      node1 :: CmmNode O O
node1 = Platform -> CmmNode O O -> CmmNode O O
forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> CmmNode e x
constantFoldNode Platform
platform CmmNode O O
node

      (CmmNode O O
node2, Assignments
as1) = DynFlags
-> Set LocalReg
-> CmmNode O O
-> Assignments
-> (CmmNode O O, Assignments)
forall (x :: Extensibility).
DynFlags
-> Set LocalReg
-> CmmNode O x
-> Assignments
-> (CmmNode O x, Assignments)
tryToInline DynFlags
dflags Set LocalReg
live CmmNode O O
node1 Assignments
as

      ([CmmNode O O]
dropped, Assignments
as') = DynFlags
-> (Assignment -> Bool)
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignmentsSimple DynFlags
dflags
                          (\Assignment
a -> DynFlags -> Assignment -> CmmNode O O -> Bool
forall (x :: Extensibility).
DynFlags -> Assignment -> CmmNode O x -> Bool
conflicts DynFlags
dflags Assignment
a CmmNode O O
node2) Assignments
as1

      block' :: Block CmmNode O O
block' = (Block CmmNode O O -> CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> [CmmNode O O] -> Block CmmNode O O
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
blockSnoc Block CmmNode O O
block [CmmNode O O]
dropped Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` CmmNode O O
node2


--
-- Heuristic to decide whether to pick up and sink an assignment
-- Currently we pick up all assignments to local registers.  It might
-- be profitable to sink assignments to global regs too, but the
-- liveness analysis doesn't track those (yet) so we can't.
--
shouldSink :: Platform -> CmmNode e x -> Maybe Assignment
shouldSink :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> Maybe Assignment
shouldSink Platform
platform (CmmAssign (CmmLocal LocalReg
r) CmmExpr
e) | Bool
no_local_regs = Assignment -> Maybe Assignment
forall a. a -> Maybe a
Just (LocalReg
r, CmmExpr
e, Platform -> CmmExpr -> AbsMem
exprMem Platform
platform CmmExpr
e)
  where no_local_regs :: Bool
no_local_regs = Bool
True -- foldRegsUsed (\_ _ -> False) True e
shouldSink Platform
_ CmmNode e x
_other = Maybe Assignment
forall a. Maybe a
Nothing

--
-- discard dead assignments.  This doesn't do as good a job as
-- removeDeadAssignments, because it would need multiple passes
-- to get all the dead code, but it catches the common case of
-- superfluous reloads from the stack that the stack allocator
-- leaves behind.
--
-- Also we catch "r = r" here.  You might think it would fall
-- out of inlining, but the inliner will see that r is live
-- after the instruction and choose not to inline r in the rhs.
--
shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool
shouldDiscard :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Set LocalReg -> Bool
shouldDiscard CmmNode e x
node Set LocalReg
live
   = case CmmNode e x
node of
       CmmAssign CmmReg
r (CmmReg CmmReg
r') | CmmReg
r CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== CmmReg
r' -> Bool
True
       CmmAssign (CmmLocal LocalReg
r) CmmExpr
_ -> Bool -> Bool
not (LocalReg
r LocalReg -> Set LocalReg -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set LocalReg
live)
       CmmNode e x
_otherwise -> Bool
False


toNode :: Assignment -> CmmNode O O
toNode :: Assignment -> CmmNode O O
toNode (LocalReg
r,CmmExpr
rhs,AbsMem
_) = CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (LocalReg -> CmmReg
CmmLocal LocalReg
r) CmmExpr
rhs

dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments
                      -> ([CmmNode O O], Assignments)
dropAssignmentsSimple :: DynFlags
-> (Assignment -> Bool)
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignmentsSimple DynFlags
dflags Assignment -> Bool
f = DynFlags
-> (Assignment -> () -> (Bool, ()))
-> ()
-> Assignments
-> ([CmmNode O O], Assignments)
forall s.
DynFlags
-> (Assignment -> s -> (Bool, s))
-> s
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignments DynFlags
dflags (\Assignment
a ()
_ -> (Assignment -> Bool
f Assignment
a, ())) ()

dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
                -> ([CmmNode O O], Assignments)
dropAssignments :: forall s.
DynFlags
-> (Assignment -> s -> (Bool, s))
-> s
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignments DynFlags
dflags Assignment -> s -> (Bool, s)
should_drop s
state Assignments
assigs
 = ([CmmNode O O]
dropped, Assignments -> Assignments
forall a. [a] -> [a]
reverse Assignments
kept)
 where
   ([CmmNode O O]
dropped,Assignments
kept) = s
-> Assignments
-> [CmmNode O O]
-> Assignments
-> ([CmmNode O O], Assignments)
go s
state Assignments
assigs [] []

   go :: s
-> Assignments
-> [CmmNode O O]
-> Assignments
-> ([CmmNode O O], Assignments)
go s
_ []             [CmmNode O O]
dropped Assignments
kept = ([CmmNode O O]
dropped, Assignments
kept)
   go s
state (Assignment
assig : Assignments
rest) [CmmNode O O]
dropped Assignments
kept
      | Bool
conflict  = s
-> Assignments
-> [CmmNode O O]
-> Assignments
-> ([CmmNode O O], Assignments)
go s
state' Assignments
rest (Assignment -> CmmNode O O
toNode Assignment
assig CmmNode O O -> [CmmNode O O] -> [CmmNode O O]
forall a. a -> [a] -> [a]
: [CmmNode O O]
dropped) Assignments
kept
      | Bool
otherwise = s
-> Assignments
-> [CmmNode O O]
-> Assignments
-> ([CmmNode O O], Assignments)
go s
state' Assignments
rest [CmmNode O O]
dropped (Assignment
assigAssignment -> Assignments -> Assignments
forall a. a -> [a] -> [a]
:Assignments
kept)
      where
        (Bool
dropit, s
state') = Assignment -> s -> (Bool, s)
should_drop Assignment
assig s
state
        conflict :: Bool
conflict = Bool
dropit Bool -> Bool -> Bool
|| (CmmNode O O -> Bool) -> [CmmNode O O] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (DynFlags -> Assignment -> CmmNode O O -> Bool
forall (x :: Extensibility).
DynFlags -> Assignment -> CmmNode O x -> Bool
conflicts DynFlags
dflags Assignment
assig) [CmmNode O O]
dropped


-- -----------------------------------------------------------------------------
-- Try to inline assignments into a node.
-- This also does constant folding for primpops, since
-- inlining opens up opportunities for doing so.

tryToInline
   :: DynFlags
   -> LocalRegSet               -- set of registers live after this
                                -- node.  We cannot inline anything
                                -- that is live after the node, unless
                                -- it is small enough to duplicate.
   -> CmmNode O x               -- The node to inline into
   -> Assignments               -- Assignments to inline
   -> (
        CmmNode O x             -- New node
      , Assignments             -- Remaining assignments
      )

tryToInline :: forall (x :: Extensibility).
DynFlags
-> Set LocalReg
-> CmmNode O x
-> Assignments
-> (CmmNode O x, Assignments)
tryToInline DynFlags
dflags Set LocalReg
live CmmNode O x
node Assignments
assigs = UniqFM LocalReg Int
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
usages CmmNode O x
node LRegSet
emptyLRegSet Assignments
assigs
 where
  usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used
  usages :: UniqFM LocalReg Int
usages = DynFlags
-> (UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int)
-> UniqFM LocalReg Int
-> CmmNode O x
-> UniqFM LocalReg Int
forall a b.
UserOfRegs LocalReg a =>
DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed DynFlags
dflags UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage UniqFM LocalReg Int
forall key elt. UniqFM key elt
emptyUFM CmmNode O x
node

  go :: UniqFM LocalReg Int
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
_usages CmmNode O x
node LRegSet
_skipped [] = (CmmNode O x
node, [])

  go UniqFM LocalReg Int
usages CmmNode O x
node LRegSet
skipped (a :: Assignment
a@(LocalReg
l,CmmExpr
rhs,AbsMem
_) : Assignments
rest)
   | Bool
cannot_inline           = (CmmNode O x, Assignments)
dont_inline
   | Bool
occurs_none             = (CmmNode O x, Assignments)
discard  -- Note [discard during inlining]
   | Bool
occurs_once             = (CmmNode O x, Assignments)
inline_and_discard
   | DynFlags -> CmmExpr -> Bool
isTrivial DynFlags
dflags CmmExpr
rhs    = (CmmNode O x, Assignments)
inline_and_keep
   | Bool
otherwise               = (CmmNode O x, Assignments)
dont_inline
   where
        platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        inline_and_discard :: (CmmNode O x, Assignments)
inline_and_discard = UniqFM LocalReg Int
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
usages' CmmNode O x
inl_node LRegSet
skipped Assignments
rest
          where usages' :: UniqFM LocalReg Int
usages' = DynFlags
-> (UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int)
-> UniqFM LocalReg Int
-> CmmExpr
-> UniqFM LocalReg Int
forall a b.
UserOfRegs LocalReg a =>
DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed DynFlags
dflags UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage UniqFM LocalReg Int
usages CmmExpr
rhs

        discard :: (CmmNode O x, Assignments)
discard = UniqFM LocalReg Int
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
usages CmmNode O x
node LRegSet
skipped Assignments
rest

        dont_inline :: (CmmNode O x, Assignments)
dont_inline        = CmmNode O x -> (CmmNode O x, Assignments)
keep CmmNode O x
node  -- don't inline the assignment, keep it
        inline_and_keep :: (CmmNode O x, Assignments)
inline_and_keep    = CmmNode O x -> (CmmNode O x, Assignments)
keep CmmNode O x
inl_node -- inline the assignment, keep it

        keep :: CmmNode O x -> (CmmNode O x, Assignments)
keep CmmNode O x
node' = (CmmNode O x
final_node, Assignment
a Assignment -> Assignments -> Assignments
forall a. a -> [a] -> [a]
: Assignments
rest')
          where (CmmNode O x
final_node, Assignments
rest') = UniqFM LocalReg Int
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
usages' CmmNode O x
node' (LocalReg -> LRegSet -> LRegSet
insertLRegSet LocalReg
l LRegSet
skipped) Assignments
rest
                usages' :: UniqFM LocalReg Int
usages' = DynFlags
-> (UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int)
-> UniqFM LocalReg Int
-> CmmExpr
-> UniqFM LocalReg Int
forall a b.
UserOfRegs LocalReg a =>
DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed DynFlags
dflags (\UniqFM LocalReg Int
m LocalReg
r -> UniqFM LocalReg Int -> LocalReg -> Int -> UniqFM LocalReg Int
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM LocalReg Int
m LocalReg
r Int
2)
                                            UniqFM LocalReg Int
usages CmmExpr
rhs
                -- we must not inline anything that is mentioned in the RHS
                -- of a binding that we have already skipped, so we set the
                -- usages of the regs on the RHS to 2.

        cannot_inline :: Bool
cannot_inline = LRegSet
skipped LRegSet -> CmmExpr -> Bool
`regsUsedIn` CmmExpr
rhs -- Note [dependent assignments]
                        Bool -> Bool -> Bool
|| LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
skipped
                        Bool -> Bool -> Bool
|| Bool -> Bool
not (DynFlags -> CmmExpr -> CmmNode O x -> Bool
forall (e :: Extensibility) (x :: Extensibility).
DynFlags -> CmmExpr -> CmmNode e x -> Bool
okToInline DynFlags
dflags CmmExpr
rhs CmmNode O x
node)

        l_usages :: Maybe Int
l_usages = UniqFM LocalReg Int -> LocalReg -> Maybe Int
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM LocalReg Int
usages LocalReg
l
        l_live :: Bool
l_live   = LocalReg
l LocalReg -> Set LocalReg -> Bool
forall a. Ord a => a -> Set a -> Bool
`elemRegSet` Set LocalReg
live

        occurs_once :: Bool
occurs_once = Bool -> Bool
not Bool
l_live Bool -> Bool -> Bool
&& Maybe Int
l_usages Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
        occurs_none :: Bool
occurs_none = Bool -> Bool
not Bool
l_live Bool -> Bool -> Bool
&& Maybe Int
l_usages Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing

        inl_node :: CmmNode O x
inl_node = CmmNode O x -> CmmNode O x
forall (x :: Extensibility). CmmNode O x -> CmmNode O x
improveConditional ((CmmExpr -> CmmExpr) -> CmmNode O x -> CmmNode O x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep CmmExpr -> CmmExpr
inl_exp CmmNode O x
node)

        inl_exp :: CmmExpr -> CmmExpr
        -- inl_exp is where the inlining actually takes place!
        inl_exp :: CmmExpr -> CmmExpr
inl_exp (CmmReg    (CmmLocal LocalReg
l'))     | LocalReg
l LocalReg -> LocalReg -> Bool
forall a. Eq a => a -> a -> Bool
== LocalReg
l' = CmmExpr
rhs
        inl_exp (CmmRegOff (CmmLocal LocalReg
l') Int
off) | LocalReg
l LocalReg -> LocalReg -> Bool
forall a. Eq a => a -> a -> Bool
== LocalReg
l'
                    = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
rhs Int
off
                    -- re-constant fold after inlining
        inl_exp (CmmMachOp MachOp
op [CmmExpr]
args) = Platform -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold Platform
platform MachOp
op [CmmExpr]
args
        inl_exp CmmExpr
other = CmmExpr
other


{- Note [improveConditional]

cmmMachOpFold tries to simplify conditionals to turn things like
  (a == b) != 1
into
  (a != b)
but there's one case it can't handle: when the comparison is over
floating-point values, we can't invert it, because floating-point
comparisons aren't invertible (because of NaNs).

But we *can* optimise this conditional by swapping the true and false
branches. Given
  CmmCondBranch ((a >## b) != 1) t f
we can turn it into
  CmmCondBranch (a >## b) f t

So here we catch conditionals that weren't optimised by cmmMachOpFold,
and apply above transformation to eliminate the comparison against 1.

It's tempting to just turn every != into == and then let cmmMachOpFold
do its thing, but that risks changing a nice fall-through conditional
into one that requires two jumps. (see swapcond_last in
GHC.Cmm.ContFlowOpt), so instead we carefully look for just the cases where
we can eliminate a comparison.
-}
improveConditional :: CmmNode O x -> CmmNode O x
improveConditional :: forall (x :: Extensibility). CmmNode O x -> CmmNode O x
improveConditional
  (CmmCondBranch (CmmMachOp MachOp
mop [CmmExpr
x, CmmLit (CmmInt Integer
1 Width
_)]) BlockId
t BlockId
f Maybe Bool
l)
  | MachOp -> Bool
neLike MachOp
mop, CmmExpr -> Bool
isComparisonExpr CmmExpr
x
  = CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
x BlockId
f BlockId
t ((Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not Maybe Bool
l)
  where
    neLike :: MachOp -> Bool
neLike (MO_Ne Width
_) = Bool
True
    neLike (MO_U_Lt Width
_) = Bool
True   -- (x<y) < 1 behaves like (x<y) != 1
    neLike (MO_S_Lt Width
_) = Bool
True   -- (x<y) < 1 behaves like (x<y) != 1
    neLike MachOp
_ = Bool
False
improveConditional CmmNode O x
other = CmmNode O x
other

-- Note [dependent assignments]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- If our assignment list looks like
--
--    [ y = e,  x = ... y ... ]
--
-- We cannot inline x.  Remember this list is really in reverse order,
-- so it means  x = ... y ...; y = e
--
-- Hence if we inline x, the outer assignment to y will capture the
-- reference in x's right hand side.
--
-- In this case we should rename the y in x's right-hand side,
-- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ]
-- Now we can go ahead and inline x.
--
-- For now we do nothing, because this would require putting
-- everything inside UniqSM.
--
-- One more variant of this (#7366):
--
--   [ y = e, y = z ]
--
-- If we don't want to inline y = e, because y is used many times, we
-- might still be tempted to inline y = z (because we always inline
-- trivial rhs's).  But of course we can't, because y is equal to e,
-- not z.

-- Note [discard during inlining]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Opportunities to discard assignments sometimes appear after we've
-- done some inlining.  Here's an example:
--
--      x = R1;
--      y = P64[x + 7];
--      z = P64[x + 15];
--      /* z is dead */
--      R1 = y & (-8);
--
-- The x assignment is trivial, so we inline it in the RHS of y, and
-- keep both x and y.  z gets dropped because it is dead, then we
-- inline y, and we have a dead assignment to x.  If we don't notice
-- that x is dead in tryToInline, we end up retaining it.

addUsage :: UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage :: UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage UniqFM LocalReg Int
m LocalReg
r = (Int -> Int -> Int)
-> UniqFM LocalReg Int -> LocalReg -> Int -> UniqFM LocalReg Int
forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) UniqFM LocalReg Int
m LocalReg
r Int
1

regsUsedIn :: LRegSet -> CmmExpr -> Bool
regsUsedIn :: LRegSet -> CmmExpr -> Bool
regsUsedIn LRegSet
ls CmmExpr
_ | LRegSet -> Bool
nullLRegSet LRegSet
ls = Bool
False
regsUsedIn LRegSet
ls CmmExpr
e = (CmmExpr -> Bool -> Bool) -> CmmExpr -> Bool -> Bool
forall z. (CmmExpr -> z -> z) -> CmmExpr -> z -> z
wrapRecExpf CmmExpr -> Bool -> Bool
f CmmExpr
e Bool
False
  where f :: CmmExpr -> Bool -> Bool
f (CmmReg (CmmLocal LocalReg
l))      Bool
_ | LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
ls = Bool
True
        f (CmmRegOff (CmmLocal LocalReg
l) Int
_) Bool
_ | LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
ls = Bool
True
        f CmmExpr
_ Bool
z = Bool
z

-- we don't inline into CmmUnsafeForeignCall if the expression refers
-- to global registers.  This is a HACK to avoid global registers
-- clashing with C argument-passing registers, really the back-end
-- ought to be able to handle it properly, but currently neither PprC
-- nor the NCG can do it.  See Note [Register parameter passing]
-- See also GHC.StgToCmm.Foreign.load_args_into_temps.
okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
okToInline :: forall (e :: Extensibility) (x :: Extensibility).
DynFlags -> CmmExpr -> CmmNode e x -> Bool
okToInline DynFlags
dflags CmmExpr
expr node :: CmmNode e x
node@(CmmUnsafeForeignCall{}) =
    Bool -> Bool
not (DynFlags -> CmmExpr -> CmmNode e x -> Bool
forall (e :: Extensibility) (x :: Extensibility).
DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict DynFlags
dflags CmmExpr
expr CmmNode e x
node)
okToInline DynFlags
_ CmmExpr
_ CmmNode e x
_ = Bool
True

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

-- | @conflicts (r,e) node@ is @False@ if and only if the assignment
-- @r = e@ can be safely commuted past statement @node@.
conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool
conflicts :: forall (x :: Extensibility).
DynFlags -> Assignment -> CmmNode O x -> Bool
conflicts DynFlags
dflags (LocalReg
r, CmmExpr
rhs, AbsMem
addr) CmmNode O x
node

  -- (1) node defines registers used by rhs of assignment. This catches
  -- assignments and all three kinds of calls. See Note [Sinking and calls]
  | DynFlags -> CmmExpr -> CmmNode O x -> Bool
forall (e :: Extensibility) (x :: Extensibility).
DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict DynFlags
dflags CmmExpr
rhs CmmNode O x
node                       = Bool
True
  | DynFlags -> CmmExpr -> CmmNode O x -> Bool
forall (e :: Extensibility) (x :: Extensibility).
DynFlags -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict  DynFlags
dflags CmmExpr
rhs CmmNode O x
node                       = Bool
True

  -- (2) node uses register defined by assignment
  | DynFlags
-> (Bool -> LocalReg -> Bool) -> Bool -> CmmNode O x -> Bool
forall r a b.
UserOfRegs r a =>
DynFlags -> (b -> r -> b) -> b -> a -> b
foldRegsUsed DynFlags
dflags (\Bool
b LocalReg
r' -> LocalReg
r LocalReg -> LocalReg -> Bool
forall a. Eq a => a -> a -> Bool
== LocalReg
r' Bool -> Bool -> Bool
|| Bool
b) Bool
False CmmNode O x
node        = Bool
True

  -- (3) a store to an address conflicts with a read of the same memory
  | CmmStore CmmExpr
addr' CmmExpr
e <- CmmNode O x
node
  , AbsMem -> AbsMem -> Bool
memConflicts AbsMem
addr (Platform -> CmmExpr -> Width -> AbsMem
loadAddr Platform
platform CmmExpr
addr' (Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
e)) = Bool
True

  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively
  | AbsMem
HeapMem    <- AbsMem
addr, CmmAssign (CmmGlobal GlobalReg
Hp) CmmExpr
_ <- CmmNode O x
node        = Bool
True
  | AbsMem
StackMem   <- AbsMem
addr, CmmAssign (CmmGlobal GlobalReg
Sp) CmmExpr
_ <- CmmNode O x
node        = Bool
True
  | SpMem{}    <- AbsMem
addr, CmmAssign (CmmGlobal GlobalReg
Sp) CmmExpr
_ <- CmmNode O x
node        = Bool
True

  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]
  | CmmUnsafeForeignCall{} <- CmmNode O x
node, AbsMem -> AbsMem -> Bool
memConflicts AbsMem
addr AbsMem
AnyMem      = Bool
True

  -- (6) native calls clobber any memory
  | CmmCall{} <- CmmNode O x
node, AbsMem -> AbsMem -> Bool
memConflicts AbsMem
addr AbsMem
AnyMem                   = Bool
True

  -- (7) otherwise, no conflict
  | Bool
otherwise = Bool
False
  where
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

-- Returns True if node defines any global registers that are used in the
-- Cmm expression
globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict :: forall (e :: Extensibility) (x :: Extensibility).
DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict DynFlags
dflags CmmExpr
expr CmmNode e x
node =
    DynFlags
-> (Bool -> GlobalReg -> Bool) -> Bool -> CmmNode e x -> Bool
forall r a b.
DefinerOfRegs r a =>
DynFlags -> (b -> r -> b) -> b -> a -> b
foldRegsDefd DynFlags
dflags (\Bool
b GlobalReg
r -> Bool
b Bool -> Bool -> Bool
|| Platform -> CmmReg -> CmmExpr -> Bool
regUsedIn (DynFlags -> Platform
targetPlatform DynFlags
dflags) (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r) CmmExpr
expr)
                 Bool
False CmmNode e x
node

-- Returns True if node defines any local registers that are used in the
-- Cmm expression
localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict :: forall (e :: Extensibility) (x :: Extensibility).
DynFlags -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict DynFlags
dflags CmmExpr
expr CmmNode e x
node =
    DynFlags
-> (Bool -> LocalReg -> Bool) -> Bool -> CmmNode e x -> Bool
forall r a b.
DefinerOfRegs r a =>
DynFlags -> (b -> r -> b) -> b -> a -> b
foldRegsDefd DynFlags
dflags (\Bool
b LocalReg
r -> Bool
b Bool -> Bool -> Bool
|| Platform -> CmmReg -> CmmExpr -> Bool
regUsedIn (DynFlags -> Platform
targetPlatform DynFlags
dflags) (LocalReg -> CmmReg
CmmLocal  LocalReg
r) CmmExpr
expr)
                 Bool
False CmmNode e x
node

-- Note [Sinking and calls]
-- ~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)
-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after
-- stack layout (see Note [Sinking after stack layout]) which leads to two
-- invariants related to calls:
--
--   a) during stack layout phase all safe foreign calls are turned into
--      unsafe foreign calls (see Note [Lower safe foreign calls]). This
--      means that we will never encounter CmmForeignCall node when running
--      sinking after stack layout
--
--   b) stack layout saves all variables live across a call on the stack
--      just before making a call (remember we are not sinking assignments to
--      stack):
--
--       L1:
--          x = R1
--          P64[Sp - 16] = L2
--          P64[Sp - 8]  = x
--          Sp = Sp - 16
--          call f() returns L2
--       L2:
--
--      We will attempt to sink { x = R1 } but we will detect conflict with
--      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even
--      checking whether it conflicts with { call f() }. In this way we will
--      never need to check any assignment conflicts with CmmCall. Remember
--      that we still need to check for potential memory conflicts.
--
-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes
-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).
-- This assumption holds only when we do sinking after stack layout. If we run
-- it before stack layout we need to check for possible conflicts with all three
-- kinds of calls. Our `conflicts` function does that by using a generic
-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and
-- UserOfRegs typeclasses.
--

-- An abstraction of memory read or written.
data AbsMem
  = NoMem            -- no memory accessed
  | AnyMem           -- arbitrary memory
  | HeapMem          -- definitely heap memory
  | StackMem         -- definitely stack memory
  | SpMem            -- <size>[Sp+n]
       {-# UNPACK #-} !Int
       {-# UNPACK #-} !Int

-- Having SpMem is important because it lets us float loads from Sp
-- past stores to Sp as long as they don't overlap, and this helps to
-- unravel some long sequences of
--    x1 = [Sp + 8]
--    x2 = [Sp + 16]
--    ...
--    [Sp + 8]  = xi
--    [Sp + 16] = xj
--
-- Note that SpMem is invalidated if Sp is changed, but the definition
-- of 'conflicts' above handles that.

-- ToDo: this won't currently fix the following commonly occurring code:
--    x1 = [R1 + 8]
--    x2 = [R1 + 16]
--    ..
--    [Hp - 8] = x1
--    [Hp - 16] = x2
--    ..

-- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that
-- assignments to [Hp + n] do not conflict with any other heap memory,
-- but this is tricky to nail down.  What if we had
--
--   x = Hp + n
--   [x] = ...
--
--  the store to [x] should be "new heap", not "old heap".
--  Furthermore, you could imagine that if we started inlining
--  functions in Cmm then there might well be reads of heap memory
--  that was written in the same basic block.  To take advantage of
--  non-aliasing of heap memory we will have to be more clever.

-- Note [Foreign calls clobber heap]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- It is tempting to say that foreign calls clobber only
-- non-heap/stack memory, but unfortunately we break this invariant in
-- the RTS.  For example, in stg_catch_retry_frame we call
-- stmCommitNestedTransaction() which modifies the contents of the
-- TRec it is passed (this actually caused incorrect code to be
-- generated).
--
-- Since the invariant is true for the majority of foreign calls,
-- perhaps we ought to have a special annotation for calls that can
-- modify heap/stack memory.  For now we just use the conservative
-- definition here.
--
-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and
-- therefore we should never float any memory operations across one of
-- these calls.


bothMems :: AbsMem -> AbsMem -> AbsMem
bothMems :: AbsMem -> AbsMem -> AbsMem
bothMems AbsMem
NoMem    AbsMem
x         = AbsMem
x
bothMems AbsMem
x        AbsMem
NoMem     = AbsMem
x
bothMems AbsMem
HeapMem  AbsMem
HeapMem   = AbsMem
HeapMem
bothMems AbsMem
StackMem AbsMem
StackMem     = AbsMem
StackMem
bothMems (SpMem Int
o1 Int
w1) (SpMem Int
o2 Int
w2)
  | Int
o1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
o2  = Int -> Int -> AbsMem
SpMem Int
o1 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
w1 Int
w2)
  | Bool
otherwise = AbsMem
StackMem
bothMems SpMem{}  AbsMem
StackMem  = AbsMem
StackMem
bothMems AbsMem
StackMem SpMem{}   = AbsMem
StackMem
bothMems AbsMem
_         AbsMem
_        = AbsMem
AnyMem

memConflicts :: AbsMem -> AbsMem -> Bool
memConflicts :: AbsMem -> AbsMem -> Bool
memConflicts AbsMem
NoMem      AbsMem
_          = Bool
False
memConflicts AbsMem
_          AbsMem
NoMem      = Bool
False
memConflicts AbsMem
HeapMem    AbsMem
StackMem   = Bool
False
memConflicts AbsMem
StackMem   AbsMem
HeapMem    = Bool
False
memConflicts SpMem{}    AbsMem
HeapMem    = Bool
False
memConflicts AbsMem
HeapMem    SpMem{}    = Bool
False
memConflicts (SpMem Int
o1 Int
w1) (SpMem Int
o2 Int
w2)
  | Int
o1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
o2   = Int
o1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
o2
  | Bool
otherwise = Int
o2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
o1
memConflicts AbsMem
_         AbsMem
_         = Bool
True

exprMem :: Platform -> CmmExpr -> AbsMem
exprMem :: Platform -> CmmExpr -> AbsMem
exprMem Platform
platform (CmmLoad CmmExpr
addr CmmType
w)  = AbsMem -> AbsMem -> AbsMem
bothMems (Platform -> CmmExpr -> Width -> AbsMem
loadAddr Platform
platform CmmExpr
addr (CmmType -> Width
typeWidth CmmType
w)) (Platform -> CmmExpr -> AbsMem
exprMem Platform
platform CmmExpr
addr)
exprMem Platform
platform (CmmMachOp MachOp
_ [CmmExpr]
es)  = (AbsMem -> AbsMem -> AbsMem) -> AbsMem -> [AbsMem] -> AbsMem
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AbsMem -> AbsMem -> AbsMem
bothMems AbsMem
NoMem ((CmmExpr -> AbsMem) -> [CmmExpr] -> [AbsMem]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> AbsMem
exprMem Platform
platform) [CmmExpr]
es)
exprMem Platform
_        CmmExpr
_                 = AbsMem
NoMem

loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
loadAddr Platform
platform CmmExpr
e Width
w =
  case CmmExpr
e of
   CmmReg CmmReg
r       -> Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr Platform
platform CmmReg
r Int
0 Width
w
   CmmRegOff CmmReg
r Int
i  -> Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr Platform
platform CmmReg
r Int
i Width
w
   CmmExpr
_other | Platform -> CmmReg -> CmmExpr -> Bool
regUsedIn Platform
platform CmmReg
spReg CmmExpr
e -> AbsMem
StackMem
          | Bool
otherwise                  -> AbsMem
AnyMem

regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr Platform
_      (CmmGlobal GlobalReg
Sp) Int
i Width
w = Int -> Int -> AbsMem
SpMem Int
i (Width -> Int
widthInBytes Width
w)
regAddr Platform
_      (CmmGlobal GlobalReg
Hp) Int
_ Width
_ = AbsMem
HeapMem
regAddr Platform
_      (CmmGlobal GlobalReg
CurrentTSO) Int
_ Width
_ = AbsMem
HeapMem -- important for PrimOps
regAddr Platform
platform CmmReg
r Int
_ Width
_ | CmmType -> Bool
isGcPtrType (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
r) = AbsMem
HeapMem -- yay! GCPtr pays for itself
regAddr Platform
_      CmmReg
_ Int
_ Width
_ = AbsMem
AnyMem

{-
Note [Inline GlobalRegs?]
~~~~~~~~~~~~~~~~~~~~~~~~~

Should we freely inline GlobalRegs?

Actually it doesn't make a huge amount of difference either way, so we
*do* currently treat GlobalRegs as "trivial" and inline them
everywhere, but for what it's worth, here is what I discovered when I
(SimonM) looked into this:

Common sense says we should not inline GlobalRegs, because when we
have

  x = R1

the register allocator will coalesce this assignment, generating no
code, and simply record the fact that x is bound to $rbx (or
whatever).  Furthermore, if we were to sink this assignment, then the
range of code over which R1 is live increases, and the range of code
over which x is live decreases.  All things being equal, it is better
for x to be live than R1, because R1 is a fixed register whereas x can
live in any register.  So we should neither sink nor inline 'x = R1'.

However, not inlining GlobalRegs can have surprising
consequences. e.g. (cgrun020)

  c3EN:
      _s3DB::P64 = R1;
      _c3ES::P64 = _s3DB::P64 & 7;
      if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;
  c3EU:
      _s3DD::P64 = P64[_s3DB::P64 + 6];
      _s3DE::P64 = P64[_s3DB::P64 + 14];
      I64[Sp - 8] = c3F0;
      R1 = _s3DE::P64;
      P64[Sp] = _s3DD::P64;

inlining the GlobalReg gives:

  c3EN:
      if (R1 & 7 >= 2) goto c3EU; else goto c3EV;
  c3EU:
      I64[Sp - 8] = c3F0;
      _s3DD::P64 = P64[R1 + 6];
      R1 = P64[R1 + 14];
      P64[Sp] = _s3DD::P64;

but if we don't inline the GlobalReg, instead we get:

      _s3DB::P64 = R1;
      if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;
  c3EU:
      I64[Sp - 8] = c3F0;
      R1 = P64[_s3DB::P64 + 14];
      P64[Sp] = P64[_s3DB::P64 + 6];

This looks better - we managed to inline _s3DD - but in fact it
generates an extra reg-reg move:

.Lc3EU:
        movq $c3F0_info,-8(%rbp)
        movq %rbx,%rax
        movq 14(%rbx),%rbx
        movq 6(%rax),%rax
        movq %rax,(%rbp)

because _s3DB is now live across the R1 assignment, we lost the
benefit of coalescing.

Who is at fault here?  Perhaps if we knew that _s3DB was an alias for
R1, then we would not sink a reference to _s3DB past the R1
assignment.  Or perhaps we *should* do that - we might gain by sinking
it, despite losing the coalescing opportunity.

Sometimes not inlining global registers wins by virtue of the rule
about not inlining into arguments of a foreign call, e.g. (T7163) this
is what happens when we inlined F1:

      _s3L2::F32 = F1;
      _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);
      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(_c3O3::F32);

but if we don't inline F1:

      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,
                                                                                            10.0 :: W32));
-}