{-# LANGUAGE GADTs #-}
module CmmSink (
     cmmSink
  ) where

import GhcPrelude

import Cmm
import CmmOpt
import CmmLive
import CmmUtils
import Hoopl.Block
import Hoopl.Label
import Hoopl.Collections
import Hoopl.Graph
import CodeGen.Platform
import Platform (isARM, platformArch)

import DynFlags
import Unique
import UniqFM
import PprCmm ()

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 l :: LocalReg
l = Key -> LRegSet -> LRegSet
IntSet.insert (Unique -> Key
getKey (LocalReg -> Unique
forall a. Uniquable a => a -> Unique
getUnique LocalReg
l))

elemLRegSet :: LocalReg -> LRegSet -> Bool
elemLRegSet :: LocalReg -> LRegSet -> Bool
elemLRegSet l :: LocalReg
l = Key -> LRegSet -> Bool
IntSet.member (Unique -> Key
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 on Trac.
--
-- -----------
-- (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 dflags :: DynFlags
dflags graph :: CmmGraph
graph = BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (CmmGraph -> BlockId
forall (n :: * -> * -> *). 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 l :: 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 Key
join_pts = [CmmBlock] -> LabelMap Key
findJoinPoints [CmmBlock]
blocks

  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink _ [] = []
  sink sunk :: LabelMap Assignments
sunk (b :: CmmBlock
b:bs :: [CmmBlock]
bs) =
    -- pprTrace "sink" (ppr lbl) $
    CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: * -> * -> *).
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
      lbl :: BlockId
lbl = CmmBlock -> BlockId
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
b
      (first :: CmmNode C O
first, middle :: Block CmmNode O O
middle, last :: CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
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 :: * -> * -> *) e.
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 :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
middle)

      -- Now sink and inline in this block
      (middle' :: Block CmmNode O O
middle', assigs :: 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 = DynFlags -> CmmNode O C -> CmmNode O C
forall e x. DynFlags -> CmmNode e x -> CmmNode e x
constantFoldNode DynFlags
dflags CmmNode O C
last
      (final_last :: CmmNode O C
final_last, assigs' :: Assignments
assigs') = DynFlags
-> Set LocalReg
-> CmmNode O C
-> Assignments
-> (CmmNode O C, Assignments)
forall x.
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.
      (joins :: [BlockId]
joins, nonjoins :: [BlockId]
nonjoins) = (BlockId -> Bool) -> [BlockId] -> ([BlockId], [BlockId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (KeyOf LabelMap -> LabelMap Key -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
`mapMember` LabelMap Key
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 live_sets :: [Set a]
live_sets r :: 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
           (_one :: Set a
_one:_two :: Set a
_two:_) -> Bool
True
           _ -> Bool
False

      -- Now, drop any assignments that we will not sink any further.
      (dropped_last :: [CmmNode O O]
dropped_last, assigs'' :: 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@(r :: LocalReg
r,rhs :: CmmExpr
rhs,_) live_sets :: [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. 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 :: 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 :: * -> * -> *) e. 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 _ (CmmReg (CmmLocal _)) = Bool
True
isTrivial dflags :: DynFlags
dflags (CmmReg (CmmGlobal r :: 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 _ (CmmLit _) = Bool
True
isTrivial _ _          = 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 dflags :: DynFlags
dflags live :: Set LocalReg
live nodes :: [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 n :: CmmNode O O
n (live :: Set LocalReg
live,nodes :: [(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 Key
findJoinPoints blocks :: [CmmBlock]
blocks = (Key -> Bool) -> LabelMap Key -> LabelMap Key
forall (map :: * -> *) a.
IsMap map =>
(a -> Bool) -> map a -> map a
mapFilter (Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
>1) LabelMap Key
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 :: * -> * -> *) e.
NonLocal thing =>
thing e C -> [BlockId]
successors [CmmBlock]
blocks

  succ_counts :: LabelMap Int
  succ_counts :: LabelMap Key
succ_counts = (BlockId -> LabelMap Key -> LabelMap Key)
-> LabelMap Key -> [BlockId] -> LabelMap Key
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\l :: BlockId
l -> (Key -> Key -> Key)
-> KeyOf LabelMap -> Key -> LabelMap Key -> LabelMap Key
forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith Key -> Key -> Key
forall a. Num a => a -> a -> a
(+) KeyOf LabelMap
BlockId
l 1) LabelMap Key
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 dflags :: DynFlags
dflags live :: Set LocalReg
live assigs :: Assignments
assigs = Assignments -> Assignments
forall a. [a] -> [a]
reverse (Assignments -> Assignments -> Assignments
go Assignments
assigs [])
  where go :: Assignments -> Assignments -> Assignments
go []             kept :: Assignments
kept = Assignments
kept
        go (a :: Assignment
a@(r :: LocalReg
r,_,_):as :: Assignments
as) kept :: 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. 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 dflags :: DynFlags
dflags nodes :: [(Set LocalReg, CmmNode O O)]
nodes assigs :: 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 :: * -> * -> *). 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 :: Block CmmNode O O
block as :: Assignments
as = (Block CmmNode O O
block, Assignments
as)
   go ((live :: Set LocalReg
live,node :: CmmNode O O
node):ns :: [(Set LocalReg, CmmNode O O)]
ns) block :: Block CmmNode O O
block as :: Assignments
as
    | CmmNode O O -> Set LocalReg -> Bool
forall e x. 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 a :: Assignment
a <- DynFlags -> CmmNode O O -> Maybe Assignment
forall e x. DynFlags -> CmmNode e x -> Maybe Assignment
shouldSink DynFlags
dflags 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
      node1 :: CmmNode O O
node1 = DynFlags -> CmmNode O O -> CmmNode O O
forall e x. DynFlags -> CmmNode e x -> CmmNode e x
constantFoldNode DynFlags
dflags CmmNode O O
node

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

      (dropped :: [CmmNode O O]
dropped, as' :: Assignments
as') = DynFlags
-> (Assignment -> Bool)
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignmentsSimple DynFlags
dflags
                          (\a :: Assignment
a -> DynFlags -> Assignment -> CmmNode O O -> Bool
forall x. 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 :: * -> * -> *) e. 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 :: * -> * -> *) e. 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 :: DynFlags -> CmmNode e x -> Maybe Assignment
shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment
shouldSink dflags :: DynFlags
dflags (CmmAssign (CmmLocal r :: LocalReg
r) e :: CmmExpr
e) | Bool
no_local_regs = Assignment -> Maybe Assignment
forall a. a -> Maybe a
Just (LocalReg
r, CmmExpr
e, DynFlags -> CmmExpr -> AbsMem
exprMem DynFlags
dflags CmmExpr
e)
  where no_local_regs :: Bool
no_local_regs = Bool
True -- foldRegsUsed (\_ _ -> False) True e
shouldSink _ _other :: 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 :: CmmNode e x -> Set LocalReg -> Bool
shouldDiscard node :: CmmNode e x
node live :: Set LocalReg
live
   = case CmmNode e x
node of
       CmmAssign r :: CmmReg
r (CmmReg r' :: CmmReg
r') | CmmReg
r CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== CmmReg
r' -> Bool
True
       CmmAssign (CmmLocal r :: LocalReg
r) _ -> Bool -> Bool
not (LocalReg
r LocalReg -> Set LocalReg -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set LocalReg
live)
       _otherwise :: CmmNode e x
_otherwise -> Bool
False


toNode :: Assignment -> CmmNode O O
toNode :: Assignment -> CmmNode O O
toNode (r :: LocalReg
r,rhs :: CmmExpr
rhs,_) = 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 dflags :: DynFlags
dflags f :: 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 (\a :: Assignment
a _ -> (Assignment -> Bool
f Assignment
a, ())) ()

dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
                -> ([CmmNode O O], Assignments)
dropAssignments :: DynFlags
-> (Assignment -> s -> (Bool, s))
-> s
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignments dflags :: DynFlags
dflags should_drop :: Assignment -> s -> (Bool, s)
should_drop state :: s
state assigs :: Assignments
assigs
 = ([CmmNode O O]
dropped, Assignments -> Assignments
forall a. [a] -> [a]
reverse Assignments
kept)
 where
   (dropped :: [CmmNode O O]
dropped,kept :: 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 _ []             dropped :: [CmmNode O O]
dropped kept :: Assignments
kept = ([CmmNode O O]
dropped, Assignments
kept)
   go state :: s
state (assig :: Assignment
assig : rest :: Assignments
rest) dropped :: [CmmNode O O]
dropped kept :: 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
        (dropit :: Bool
dropit, state' :: 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. 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 :: DynFlags
-> Set LocalReg
-> CmmNode O x
-> Assignments
-> (CmmNode O x, Assignments)
tryToInline dflags :: DynFlags
dflags live :: Set LocalReg
live node :: CmmNode O x
node assigs :: Assignments
assigs = UniqFM Key
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM Key
usages CmmNode O x
node LRegSet
emptyLRegSet Assignments
assigs
 where
  usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used
  usages :: UniqFM Key
usages = DynFlags
-> (UniqFM Key -> LocalReg -> UniqFM Key)
-> UniqFM Key
-> CmmNode O x
-> UniqFM Key
forall a b.
UserOfRegs LocalReg a =>
DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed DynFlags
dflags UniqFM Key -> LocalReg -> UniqFM Key
addUsage UniqFM Key
forall elt. UniqFM elt
emptyUFM CmmNode O x
node

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

  go usages :: UniqFM Key
usages node :: CmmNode O x
node skipped :: LRegSet
skipped (a :: Assignment
a@(l :: LocalReg
l,rhs :: CmmExpr
rhs,_) : rest :: 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
        inline_and_discard :: (CmmNode O x, Assignments)
inline_and_discard = UniqFM Key
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM Key
usages' CmmNode O x
inl_node LRegSet
skipped Assignments
rest
          where usages' :: UniqFM Key
usages' = DynFlags
-> (UniqFM Key -> LocalReg -> UniqFM Key)
-> UniqFM Key
-> CmmExpr
-> UniqFM Key
forall a b.
UserOfRegs LocalReg a =>
DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed DynFlags
dflags UniqFM Key -> LocalReg -> UniqFM Key
addUsage UniqFM Key
usages CmmExpr
rhs

        discard :: (CmmNode O x, Assignments)
discard = UniqFM Key
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM Key
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 node' :: CmmNode O x
node' = (CmmNode O x
final_node, Assignment
a Assignment -> Assignments -> Assignments
forall a. a -> [a] -> [a]
: Assignments
rest')
          where (final_node :: CmmNode O x
final_node, rest' :: Assignments
rest') = UniqFM Key
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM Key
usages' CmmNode O x
node' (LocalReg -> LRegSet -> LRegSet
insertLRegSet LocalReg
l LRegSet
skipped) Assignments
rest
                usages' :: UniqFM Key
usages' = DynFlags
-> (UniqFM Key -> LocalReg -> UniqFM Key)
-> UniqFM Key
-> CmmExpr
-> UniqFM Key
forall a b.
UserOfRegs LocalReg a =>
DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed DynFlags
dflags (\m :: UniqFM Key
m r :: LocalReg
r -> UniqFM Key -> LocalReg -> Key -> UniqFM Key
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM Key
m LocalReg
r 2)
                                            UniqFM Key
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 x. DynFlags -> CmmExpr -> CmmNode e x -> Bool
okToInline DynFlags
dflags CmmExpr
rhs CmmNode O x
node)

        l_usages :: Maybe Key
l_usages = UniqFM Key -> LocalReg -> Maybe Key
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM Key
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 Key
l_usages Maybe Key -> Maybe Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key -> Maybe Key
forall a. a -> Maybe a
Just 1
        occurs_none :: Bool
occurs_none = Bool -> Bool
not Bool
l_live Bool -> Bool -> Bool
&& Maybe Key
l_usages Maybe Key -> Maybe Key -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Key
forall a. Maybe a
Nothing

        inl_node :: CmmNode O x
inl_node = CmmNode O x -> CmmNode O x
forall x. CmmNode O x -> CmmNode O x
improveConditional ((CmmExpr -> CmmExpr) -> CmmNode O x -> CmmNode O x
forall e x. (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 l' :: LocalReg
l'))     | LocalReg
l LocalReg -> LocalReg -> Bool
forall a. Eq a => a -> a -> Bool
== LocalReg
l' = CmmExpr
rhs
        inl_exp (CmmRegOff (CmmLocal l' :: LocalReg
l') off :: Key
off) | LocalReg
l LocalReg -> LocalReg -> Bool
forall a. Eq a => a -> a -> Bool
== LocalReg
l'
                    = DynFlags -> CmmExpr -> Key -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
rhs Key
off
                    -- re-constant fold after inlining
        inl_exp (CmmMachOp op :: MachOp
op args :: [CmmExpr]
args) = DynFlags -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold DynFlags
dflags MachOp
op [CmmExpr]
args
        inl_exp other :: 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
CmmContFlowOpt), so instead we carefully look for just the cases where
we can eliminate a comparison.
-}
improveConditional :: CmmNode O x -> CmmNode O x
improveConditional :: CmmNode O x -> CmmNode O x
improveConditional
  (CmmCondBranch (CmmMachOp mop :: MachOp
mop [x :: CmmExpr
x, CmmLit (CmmInt 1 _)]) t :: BlockId
t f :: BlockId
f l :: 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 _) = Bool
True
    neLike (MO_U_Lt _) = Bool
True   -- (x<y) < 1 behaves like (x<y) != 1
    neLike (MO_S_Lt _) = Bool
True   -- (x<y) < 1 behaves like (x<y) != 1
    neLike _ = Bool
False
improveConditional other :: 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 Int -> LocalReg -> UniqFM Int
addUsage :: UniqFM Key -> LocalReg -> UniqFM Key
addUsage m :: UniqFM Key
m r :: LocalReg
r = (Key -> Key -> Key) -> UniqFM Key -> LocalReg -> Key -> UniqFM Key
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
addToUFM_C Key -> Key -> Key
forall a. Num a => a -> a -> a
(+) UniqFM Key
m LocalReg
r 1

regsUsedIn :: LRegSet -> CmmExpr -> Bool
regsUsedIn :: LRegSet -> CmmExpr -> Bool
regsUsedIn ls :: LRegSet
ls _ | LRegSet -> Bool
nullLRegSet LRegSet
ls = Bool
False
regsUsedIn ls :: LRegSet
ls e :: 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 l :: LocalReg
l))      _ | LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
ls = Bool
True
        f (CmmRegOff (CmmLocal l :: LocalReg
l) _) _ | LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
ls = Bool
True
        f _ z :: 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 StgCmmForeign:load_args_into_temps.
okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
okToInline dflags :: DynFlags
dflags expr :: CmmExpr
expr node :: CmmNode e x
node@(CmmUnsafeForeignCall{}) =
    Bool -> Bool
not (DynFlags -> CmmExpr -> CmmNode e x -> Bool
forall e x. DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict DynFlags
dflags CmmExpr
expr CmmNode e x
node)
okToInline _ _ _ = 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 :: DynFlags -> Assignment -> CmmNode O x -> Bool
conflicts dflags :: DynFlags
dflags (r :: LocalReg
r, rhs :: CmmExpr
rhs, addr :: AbsMem
addr) node :: 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 x. 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 x. 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 (\b :: Bool
b r' :: 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 addr' :: CmmExpr
addr' e :: CmmExpr
e <- CmmNode O x
node
  , AbsMem -> AbsMem -> Bool
memConflicts AbsMem
addr (DynFlags -> CmmExpr -> Width -> AbsMem
loadAddr DynFlags
dflags CmmExpr
addr' (DynFlags -> CmmExpr -> Width
cmmExprWidth DynFlags
dflags CmmExpr
e)) = Bool
True

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

-- Returns True if node defines any global registers that are used in the
-- Cmm expression
globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict dflags :: DynFlags
dflags expr :: CmmExpr
expr node :: 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 (\b :: Bool
b r :: GlobalReg
r -> Bool
b Bool -> Bool -> Bool
|| DynFlags -> CmmReg -> CmmExpr -> Bool
regUsedIn 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 :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict dflags :: DynFlags
dflags expr :: CmmExpr
expr node :: 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 (\b :: Bool
b r :: LocalReg
r -> Bool
b Bool -> Bool -> Bool
|| DynFlags -> CmmReg -> CmmExpr -> Bool
regUsedIn 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 NoMem    x :: AbsMem
x         = AbsMem
x
bothMems x :: AbsMem
x        NoMem     = AbsMem
x
bothMems HeapMem  HeapMem   = AbsMem
HeapMem
bothMems StackMem StackMem     = AbsMem
StackMem
bothMems (SpMem o1 :: Key
o1 w1 :: Key
w1) (SpMem o2 :: Key
o2 w2 :: Key
w2)
  | Key
o1 Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
o2  = Key -> Key -> AbsMem
SpMem Key
o1 (Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
w1 Key
w2)
  | Bool
otherwise = AbsMem
StackMem
bothMems SpMem{}  StackMem  = AbsMem
StackMem
bothMems StackMem SpMem{}   = AbsMem
StackMem
bothMems _         _        = AbsMem
AnyMem

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

exprMem :: DynFlags -> CmmExpr -> AbsMem
exprMem :: DynFlags -> CmmExpr -> AbsMem
exprMem dflags :: DynFlags
dflags (CmmLoad addr :: CmmExpr
addr w :: CmmType
w)  = AbsMem -> AbsMem -> AbsMem
bothMems (DynFlags -> CmmExpr -> Width -> AbsMem
loadAddr DynFlags
dflags CmmExpr
addr (CmmType -> Width
typeWidth CmmType
w)) (DynFlags -> CmmExpr -> AbsMem
exprMem DynFlags
dflags CmmExpr
addr)
exprMem dflags :: DynFlags
dflags (CmmMachOp _ es :: [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 (DynFlags -> CmmExpr -> AbsMem
exprMem DynFlags
dflags) [CmmExpr]
es)
exprMem _      _                 = AbsMem
NoMem

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

regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
regAddr :: DynFlags -> CmmReg -> Key -> Width -> AbsMem
regAddr _      (CmmGlobal Sp) i :: Key
i w :: Width
w = Key -> Key -> AbsMem
SpMem Key
i (Width -> Key
widthInBytes Width
w)
regAddr _      (CmmGlobal Hp) _ _ = AbsMem
HeapMem
regAddr _      (CmmGlobal CurrentTSO) _ _ = AbsMem
HeapMem -- important for PrimOps
regAddr dflags :: DynFlags
dflags r :: CmmReg
r _ _ | CmmType -> Bool
isGcPtrType (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
r) = AbsMem
HeapMem -- yay! GCPtr pays for itself
regAddr _      _ _ _ = 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));
-}