{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Clean out unneeded spill\/reload instructions.
--
--   Handling of join points
--   ~~~~~~~~~~~~~~~~~~~~~~~
--
--   @
--   B1:                          B2:
--    ...                          ...
--       RELOAD SLOT(0), %r1          RELOAD SLOT(0), %r1
--       ... A ...                    ... B ...
--       jump B3                      jump B3
--
--                B3: ... C ...
--                    RELOAD SLOT(0), %r1
--                    ...
--   @
--
--   The Plan
--   ~~~~~~~~
--
--   As long as %r1 hasn't been written to in A, B or C then we don't need
--   the reload in B3.
--
--   What we really care about here is that on the entry to B3, %r1 will
--   always have the same value that is in SLOT(0) (ie, %r1 is _valid_)
--
--   This also works if the reloads in B1\/B2 were spills instead, because
--   spilling %r1 to a slot makes that slot have the same value as %r1.
--
module GHC.CmmToAsm.Reg.Graph.SpillClean (
        cleanSpills
) where
import GHC.Prelude

import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg

import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import GHC.Types.Unique
import GHC.Builtin.Uniques
import GHC.Utils.Monad.State
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Cmm.Dataflow.Collections

import Data.List (nub, foldl1', find)
import Data.Maybe
import Data.IntSet              (IntSet)
import qualified Data.IntSet    as IntSet


-- | The identification number of a spill slot.
--   A value is stored in a spill slot when we don't have a free
--   register to hold it.
type Slot = Int


-- | Clean out unneeded spill\/reloads from this top level thing.
cleanSpills
        :: Instruction instr
        => Platform
        -> LiveCmmDecl statics instr
        -> LiveCmmDecl statics instr

cleanSpills :: forall instr statics.
Instruction instr =>
Platform -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
cleanSpills Platform
platform LiveCmmDecl statics instr
cmm
        = forall s a. State s a -> s -> a
evalState (forall instr statics.
Instruction instr =>
Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin Platform
platform Int
0 LiveCmmDecl statics instr
cmm) CleanS
initCleanS


-- | Do one pass of cleaning.
cleanSpin
        :: Instruction instr
        => Platform
        -> Int                              -- ^ Iteration number for the cleaner.
        -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.
        -> CleanM (LiveCmmDecl statics instr)

cleanSpin :: forall instr statics.
Instruction instr =>
Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin Platform
platform Int
spinCount LiveCmmDecl statics instr
code
 = do
        -- Initialise count of cleaned spill and reload instructions.
        forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
                { sCleanedSpillsAcc :: Int
sCleanedSpillsAcc     = Int
0
                , sCleanedReloadsAcc :: Int
sCleanedReloadsAcc    = Int
0
                , sReloadedBy :: UniqFM Store [BlockId]
sReloadedBy           = forall key elt. UniqFM key elt
emptyUFM }

        LiveCmmDecl statics instr
code_forward    <- forall (m :: * -> *) instr statics.
Monad m =>
(LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM (forall instr.
Instruction instr =>
Platform -> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockForward Platform
platform) LiveCmmDecl statics instr
code
        LiveCmmDecl statics instr
code_backward   <- forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
cleanTopBackward LiveCmmDecl statics instr
code_forward

        -- During the cleaning of each block we collected information about
        -- what regs were valid across each jump. Based on this, work out
        -- whether it will be safe to erase reloads after join points for
        -- the next pass.
        State CleanS ()
collateJoinPoints

        -- Remember how many spill and reload instructions we cleaned in this pass.
        Int
spills          <- forall s a. (s -> a) -> State s a
gets CleanS -> Int
sCleanedSpillsAcc
        Int
reloads         <- forall s a. (s -> a) -> State s a
gets CleanS -> Int
sCleanedReloadsAcc
        forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
                { sCleanedCount :: [(Int, Int)]
sCleanedCount = (Int
spills, Int
reloads) forall a. a -> [a] -> [a]
: CleanS -> [(Int, Int)]
sCleanedCount CleanS
s }

        -- If nothing was cleaned in this pass or the last one
        --      then we're done and it's time to bail out.
        [(Int, Int)]
cleanedCount    <- forall s a. (s -> a) -> State s a
gets CleanS -> [(Int, Int)]
sCleanedCount
        if forall a. Int -> [a] -> [a]
take Int
2 [(Int, Int)]
cleanedCount forall a. Eq a => a -> a -> Bool
== [(Int
0, Int
0), (Int
0, Int
0)]
           then forall (m :: * -> *) a. Monad m => a -> m a
return LiveCmmDecl statics instr
code

        -- otherwise go around again
           else forall instr statics.
Instruction instr =>
Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin Platform
platform (Int
spinCount forall a. Num a => a -> a -> a
+ Int
1) LiveCmmDecl statics instr
code_backward


-------------------------------------------------------------------------------
-- | Clean out unneeded reload instructions,
--   while walking forward over the code.
cleanBlockForward
        :: Instruction instr
        => Platform
        -> LiveBasicBlock instr
        -> CleanM (LiveBasicBlock instr)

cleanBlockForward :: forall instr.
Instruction instr =>
Platform -> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockForward Platform
platform (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
 = do
        -- See if we have a valid association for the entry to this block.
        UniqFM BlockId (Assoc Store)
jumpValid       <- forall s a. (s -> a) -> State s a
gets CleanS -> UniqFM BlockId (Assoc Store)
sJumpValid
        let assoc :: Assoc Store
assoc       = case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM BlockId (Assoc Store)
jumpValid BlockId
blockId of
                                Just Assoc Store
assoc      -> Assoc Store
assoc
                                Maybe (Assoc Store)
Nothing         -> forall a. Assoc a
emptyAssoc

        [LiveInstr instr]
instrs_reload   <- forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [] [LiveInstr instr]
instrs
        forall (m :: * -> *) a. Monad m => a -> m a
return  forall a b. (a -> b) -> a -> b
$ forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
blockId [LiveInstr instr]
instrs_reload



-- | Clean out unneeded reload instructions.
--
--   Walking forwards across the code
--     On a reload, if we know a reg already has the same value as a slot
--     then we don't need to do the reload.
--
cleanForward
        :: Instruction instr
        => Platform
        -> BlockId                  -- ^ the block that we're currently in
        -> Assoc Store              -- ^ two store locations are associated if
                                    --     they have the same value
        -> [LiveInstr instr]        -- ^ acc
        -> [LiveInstr instr]        -- ^ instrs to clean (in backwards order)
        -> CleanM [LiveInstr instr] -- ^ cleaned instrs  (in forward   order)

cleanForward :: forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
_ BlockId
_ Assoc Store
_ [LiveInstr instr]
acc []
        = forall (m :: * -> *) a. Monad m => a -> m a
return [LiveInstr instr]
acc

-- Rewrite live range joins via spill slots to just a spill and a reg-reg move
-- hopefully the spill will be also be cleaned in the next pass
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc (LiveInstr instr
li1 : LiveInstr instr
li2 : [LiveInstr instr]
instrs)

        | LiveInstr (SPILL  Reg
reg1  Int
slot1) Maybe Liveness
_      <- LiveInstr instr
li1
        , LiveInstr (RELOAD Int
slot2 Reg
reg2)  Maybe Liveness
_      <- LiveInstr instr
li2
        , Int
slot1 forall a. Eq a => a -> a -> Bool
== Int
slot2
        = do
                forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
                forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc
                 forall a b. (a -> b) -> a -> b
$ LiveInstr instr
li1 forall a. a -> [a] -> [a]
: forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform Reg
reg1 Reg
reg2) forall a. Maybe a
Nothing
                       forall a. a -> [a] -> [a]
: [LiveInstr instr]
instrs

cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc (li :: LiveInstr instr
li@(LiveInstr InstrSR instr
i1 Maybe Liveness
_) : [LiveInstr instr]
instrs)
        | Just (Reg
r1, Reg
r2) <- forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr InstrSR instr
i1
        = if Reg
r1 forall a. Eq a => a -> a -> Bool
== Reg
r2
                -- Erase any left over nop reg reg moves while we're here
                -- this will also catch any nop moves that the previous case
                -- happens to add.
                then forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc [LiveInstr instr]
instrs

                -- If r1 has the same value as some slots and we copy r1 to r2,
                --      then r2 is now associated with those slots instead
                else do let assoc' :: Assoc Store
assoc'      = Store -> Store -> Assoc Store -> Assoc Store
addAssoc (Reg -> Store
SReg Reg
r1) (Reg -> Store
SReg Reg
r2)
                                        forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
delAssoc (Reg -> Store
SReg Reg
r2)
                                        forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc

                        forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs


cleanForward Platform
platform BlockId
blockId Assoc Store
assoc [LiveInstr instr]
acc (LiveInstr instr
li : [LiveInstr instr]
instrs)

        -- Update association due to the spill.
        | LiveInstr (SPILL Reg
reg Int
slot) Maybe Liveness
_  <- LiveInstr instr
li
        = let   assoc' :: Assoc Store
assoc'  = Store -> Store -> Assoc Store -> Assoc Store
addAssoc (Reg -> Store
SReg Reg
reg)  (Int -> Store
SSlot Int
slot)
                        forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
delAssoc (Int -> Store
SSlot Int
slot)
                        forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
          in    forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs

        -- Clean a reload instr.
        | LiveInstr (RELOAD{}) Maybe Liveness
_        <- LiveInstr instr
li
        = do    (Assoc Store
assoc', Maybe (LiveInstr instr)
mli)   <- forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
cleanReload Platform
platform BlockId
blockId Assoc Store
assoc LiveInstr instr
li
                case Maybe (LiveInstr instr)
mli of
                 Maybe (LiveInstr instr)
Nothing        -> forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' [LiveInstr instr]
acc
                                                [LiveInstr instr]
instrs

                 Just LiveInstr instr
li'       -> forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' (LiveInstr instr
li' forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc)
                                                [LiveInstr instr]
instrs

        -- Remember the association over a jump.
        | LiveInstr InstrSR instr
instr Maybe Liveness
_     <- LiveInstr instr
li
        , [BlockId]
targets               <- forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
instr
        , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
targets
        = do    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Assoc Store -> BlockId -> State CleanS ()
accJumpValid Assoc Store
assoc) [BlockId]
targets
                forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs

        -- Writing to a reg changes its value.
        | LiveInstr InstrSR instr
instr Maybe Liveness
_     <- LiveInstr instr
li
        , RU [Reg]
_ [Reg]
written          <- forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr
        = let assoc' :: Assoc Store
assoc'    = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Store -> Assoc Store -> Assoc Store
delAssoc Assoc Store
assoc (forall a b. (a -> b) -> [a] -> [b]
map Reg -> Store
SReg forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [Reg]
written)
          in  forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
platform BlockId
blockId Assoc Store
assoc' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs



-- | Try and rewrite a reload instruction to something more pleasing
cleanReload
        :: Instruction instr
        => Platform
        -> BlockId
        -> Assoc Store
        -> LiveInstr instr
        -> CleanM (Assoc Store, Maybe (LiveInstr instr))

cleanReload :: forall instr.
Instruction instr =>
Platform
-> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
cleanReload Platform
platform BlockId
blockId Assoc Store
assoc li :: LiveInstr instr
li@(LiveInstr (RELOAD Int
slot Reg
reg) Maybe Liveness
_)

        -- If the reg we're reloading already has the same value as the slot
        --      then we can erase the instruction outright.
        | Store -> Store -> Assoc Store -> Bool
elemAssoc (Int -> Store
SSlot Int
slot) (Reg -> Store
SReg Reg
reg) Assoc Store
assoc
        = do    forall s. (s -> s) -> State s ()
modify  forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
                forall (m :: * -> *) a. Monad m => a -> m a
return  (Assoc Store
assoc, forall a. Maybe a
Nothing)

        -- If we can find another reg with the same value as this slot then
        --      do a move instead of a reload.
        | Just Reg
reg2     <- Assoc Store -> Int -> Maybe Reg
findRegOfSlot Assoc Store
assoc Int
slot
        = do    forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }

                let assoc' :: Assoc Store
assoc'      = Store -> Store -> Assoc Store -> Assoc Store
addAssoc (Reg -> Store
SReg Reg
reg) (Reg -> Store
SReg Reg
reg2)
                                forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
delAssoc (Reg -> Store
SReg Reg
reg)
                                forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc

                forall (m :: * -> *) a. Monad m => a -> m a
return  ( Assoc Store
assoc'
                        , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform Reg
reg2 Reg
reg) forall a. Maybe a
Nothing)

        -- Gotta keep this instr.
        | Bool
otherwise
        = do    -- Update the association.
                let assoc' :: Assoc Store
assoc'
                        = Store -> Store -> Assoc Store -> Assoc Store
addAssoc (Reg -> Store
SReg Reg
reg)  (Int -> Store
SSlot Int
slot)
                                -- doing the reload makes reg and slot the same value
                        forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
delAssoc (Reg -> Store
SReg Reg
reg)
                                -- reg value changes on reload
                        forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc

                -- Remember that this block reloads from this slot.
                BlockId -> Int -> State CleanS ()
accBlockReloadsSlot BlockId
blockId Int
slot

                forall (m :: * -> *) a. Monad m => a -> m a
return  (Assoc Store
assoc', forall a. a -> Maybe a
Just LiveInstr instr
li)

cleanReload Platform
_ BlockId
_ Assoc Store
_ LiveInstr instr
_
        = forall a. String -> a
panic String
"RegSpillClean.cleanReload: unhandled instr"


-------------------------------------------------------------------------------
-- | Clean out unneeded spill instructions,
--   while walking backwards over the code.
--
--      If there were no reloads from a slot between a spill and the last one
--      then the slot was never read and we don't need the spill.
--
--      SPILL   r0 -> s1
--      RELOAD  s1 -> r2
--      SPILL   r3 -> s1        <--- don't need this spill
--      SPILL   r4 -> s1
--      RELOAD  s1 -> r5
--
--      Maintain a set of
--              "slots which were spilled to but not reloaded from yet"
--
--      Walking backwards across the code:
--       a) On a reload from a slot, remove it from the set.
--
--       a) On a spill from a slot
--              If the slot is in set then we can erase the spill,
--               because it won't be reloaded from until after the next spill.
--
--              otherwise
--               keep the spill and add the slot to the set
--
-- TODO: This is mostly inter-block
--       we should really be updating the noReloads set as we cross jumps also.
--
-- TODO: generate noReloads from liveSlotsOnEntry
--
cleanTopBackward
        :: Instruction instr
        => LiveCmmDecl statics instr
        -> CleanM (LiveCmmDecl statics instr)

cleanTopBackward :: forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
cleanTopBackward LiveCmmDecl statics instr
cmm
 = case LiveCmmDecl statics instr
cmm of
        CmmData{}
         -> forall (m :: * -> *) a. Monad m => a -> m a
return LiveCmmDecl statics instr
cmm

        CmmProc LiveInfo
info CLabel
label [GlobalReg]
live [SCC (LiveBasicBlock instr)]
sccs
         | LiveInfo LabelMap RawCmmStatics
_ [BlockId]
_ BlockMap RegSet
_ BlockMap IntSet
liveSlotsOnEntry <- LiveInfo
info
         -> do  [SCC (LiveBasicBlock instr)]
sccs'   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SCC a -> m (SCC b)
mapSCCM (forall instr.
Instruction instr =>
BlockMap IntSet
-> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockBackward BlockMap IntSet
liveSlotsOnEntry)) [SCC (LiveBasicBlock instr)]
sccs
                forall (m :: * -> *) a. Monad m => a -> m a
return  forall a b. (a -> b) -> a -> b
$ forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LiveInfo
info CLabel
label [GlobalReg]
live [SCC (LiveBasicBlock instr)]
sccs'


cleanBlockBackward
        :: Instruction instr
        => BlockMap IntSet
        -> LiveBasicBlock instr
        -> CleanM (LiveBasicBlock instr)

cleanBlockBackward :: forall instr.
Instruction instr =>
BlockMap IntSet
-> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockBackward BlockMap IntSet
liveSlotsOnEntry (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
 = do   [LiveInstr instr]
instrs_spill    <- forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry  forall a. UniqSet a
emptyUniqSet  [] [LiveInstr instr]
instrs
        forall (m :: * -> *) a. Monad m => a -> m a
return  forall a b. (a -> b) -> a -> b
$ forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
blockId [LiveInstr instr]
instrs_spill



cleanBackward
        :: Instruction instr
        => BlockMap IntSet          -- ^ Slots live on entry to each block
        -> UniqSet Int              -- ^ Slots that have been spilled, but not reloaded from
        -> [LiveInstr instr]        -- ^ acc
        -> [LiveInstr instr]        -- ^ Instrs to clean (in forwards order)
        -> CleanM [LiveInstr instr] -- ^ Cleaned instrs  (in backwards order)

cleanBackward :: forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
lis
 = do   UniqFM Store [BlockId]
reloadedBy      <- forall s a. (s -> a) -> State s a
gets CleanS -> UniqFM Store [BlockId]
sReloadedBy
        forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqFM Store [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
cleanBackward' BlockMap IntSet
liveSlotsOnEntry UniqFM Store [BlockId]
reloadedBy UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
lis


cleanBackward'
        :: Instruction instr
        => BlockMap IntSet
        -> UniqFM Store [BlockId]
        -> UniqSet Int
        -> [LiveInstr instr]
        -> [LiveInstr instr]
        -> State CleanS [LiveInstr instr]

cleanBackward' :: forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqFM Store [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
cleanBackward' BlockMap IntSet
_ UniqFM Store [BlockId]
_ UniqSet Int
_      [LiveInstr instr]
acc []
        = forall (m :: * -> *) a. Monad m => a -> m a
return  [LiveInstr instr]
acc

cleanBackward' BlockMap IntSet
liveSlotsOnEntry UniqFM Store [BlockId]
reloadedBy UniqSet Int
noReloads [LiveInstr instr]
acc (LiveInstr instr
li : [LiveInstr instr]
instrs)

        -- If nothing ever reloads from this slot then we don't need the spill.
        | LiveInstr (SPILL Reg
_ Int
slot) Maybe Liveness
_    <- LiveInstr instr
li
        , Maybe [BlockId]
Nothing       <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Store [BlockId]
reloadedBy (Int -> Store
SSlot Int
slot)
        = do    forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = CleanS -> Int
sCleanedSpillsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
                forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
instrs

        | LiveInstr (SPILL Reg
_ Int
slot) Maybe Liveness
_    <- LiveInstr instr
li
        = if forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Int
slot UniqSet Int
noReloads

           -- We can erase this spill because the slot won't be read until
           -- after the next one
           then do
                forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = CleanS -> Int
sCleanedSpillsAcc CleanS
s forall a. Num a => a -> a -> a
+ Int
1 }
                forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
instrs

           else do
                -- This slot is being spilled to, but we haven't seen any reloads yet.
                let noReloads' :: UniqSet Int
noReloads'  = forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Int
noReloads Int
slot
                forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs

        -- if we reload from a slot then it's no longer unused
        | LiveInstr (RELOAD Int
slot Reg
_) Maybe Liveness
_   <- LiveInstr instr
li
        , UniqSet Int
noReloads'            <- forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet Int
noReloads Int
slot
        = forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs

        -- If a slot is live in a jump target then assume it's reloaded there.
        --
        -- TODO: A real dataflow analysis would do a better job here.
        --       If the target block _ever_ used the slot then we assume
        --       it always does, but if those reloads are cleaned the slot
        --       liveness map doesn't get updated.
        | LiveInstr InstrSR instr
instr Maybe Liveness
_     <- LiveInstr instr
li
        , [BlockId]
targets               <- forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
instr
        = do
                let slotsReloadedByTargets :: IntSet
slotsReloadedByTargets
                        = forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions
                        forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
                        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockMap IntSet
liveSlotsOnEntry)
                        forall a b. (a -> b) -> a -> b
$ [BlockId]
targets

                let noReloads' :: UniqSet Int
noReloads'
                        = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet Int
noReloads
                        forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IntSet.toList IntSet
slotsReloadedByTargets

                forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
noReloads' (LiveInstr instr
li forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs

#if __GLASGOW_HASKELL__ <= 810
        -- some other instruction
        | otherwise
        = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs
#endif


-- | Combine the associations from all the inward control flow edges.
--
collateJoinPoints :: CleanM ()
collateJoinPoints :: State CleanS ()
collateJoinPoints
 = forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
        { sJumpValid :: UniqFM BlockId (Assoc Store)
sJumpValid    = forall elt1 elt2 key.
(elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapUFM [Assoc Store] -> Assoc Store
intersects (CleanS -> UniqFM BlockId [Assoc Store]
sJumpValidAcc CleanS
s)
        , sJumpValidAcc :: UniqFM BlockId [Assoc Store]
sJumpValidAcc = forall key elt. UniqFM key elt
emptyUFM }

intersects :: [Assoc Store]     -> Assoc Store
intersects :: [Assoc Store] -> Assoc Store
intersects []           = forall a. Assoc a
emptyAssoc
intersects [Assoc Store]
assocs       = forall a. (a -> a -> a) -> [a] -> a
foldl1' Assoc Store -> Assoc Store -> Assoc Store
intersectAssoc [Assoc Store]
assocs


-- | See if we have a reg with the same value as this slot in the association table.
findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
findRegOfSlot Assoc Store
assoc Int
slot
        | UniqSet Store
close                 <- Store -> Assoc Store -> UniqSet Store
closeAssoc (Int -> Store
SSlot Int
slot) Assoc Store
assoc
        , Just (SReg Reg
reg)       <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Store -> Bool
isStoreReg forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Store
close
           -- See Note [Unique Determinism and code generation]
        = forall a. a -> Maybe a
Just Reg
reg

        | Bool
otherwise
        = forall a. Maybe a
Nothing


-------------------------------------------------------------------------------
-- | Cleaner monad.
type CleanM
        = State CleanS

-- | Cleaner state.
data CleanS
        = CleanS
        { -- | Regs which are valid at the start of each block.
          CleanS -> UniqFM BlockId (Assoc Store)
sJumpValid            :: UniqFM BlockId (Assoc Store)

          -- | Collecting up what regs were valid across each jump.
          --    in the next pass we can collate these and write the results
          --    to sJumpValid.
        , CleanS -> UniqFM BlockId [Assoc Store]
sJumpValidAcc         :: UniqFM BlockId [Assoc Store]

          -- | Map of (slot -> blocks which reload from this slot)
          --    used to decide if whether slot spilled to will ever be
          --    reloaded from on this path.
        , CleanS -> UniqFM Store [BlockId]
sReloadedBy           :: UniqFM Store [BlockId]

          -- | Spills and reloads cleaned each pass (latest at front)
        , CleanS -> [(Int, Int)]
sCleanedCount         :: [(Int, Int)]

          -- | Spills and reloads that have been cleaned in this pass so far.
        , CleanS -> Int
sCleanedSpillsAcc     :: Int
        , CleanS -> Int
sCleanedReloadsAcc    :: Int }


-- | Construct the initial cleaner state.
initCleanS :: CleanS
initCleanS :: CleanS
initCleanS
        = CleanS
        { sJumpValid :: UniqFM BlockId (Assoc Store)
sJumpValid            = forall key elt. UniqFM key elt
emptyUFM
        , sJumpValidAcc :: UniqFM BlockId [Assoc Store]
sJumpValidAcc         = forall key elt. UniqFM key elt
emptyUFM

        , sReloadedBy :: UniqFM Store [BlockId]
sReloadedBy           = forall key elt. UniqFM key elt
emptyUFM

        , sCleanedCount :: [(Int, Int)]
sCleanedCount         = []

        , sCleanedSpillsAcc :: Int
sCleanedSpillsAcc     = Int
0
        , sCleanedReloadsAcc :: Int
sCleanedReloadsAcc    = Int
0 }


-- | Remember the associations before a jump.
accJumpValid :: Assoc Store -> BlockId -> CleanM ()
accJumpValid :: Assoc Store -> BlockId -> State CleanS ()
accJumpValid Assoc Store
assocs BlockId
target
 = forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s {
        sJumpValidAcc :: UniqFM BlockId [Assoc Store]
sJumpValidAcc = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. [a] -> [a] -> [a]
(++)
                                (CleanS -> UniqFM BlockId [Assoc Store]
sJumpValidAcc CleanS
s)
                                BlockId
target
                                [Assoc Store
assocs] }


accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
accBlockReloadsSlot :: BlockId -> Int -> State CleanS ()
accBlockReloadsSlot BlockId
blockId Int
slot
 = forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s {
        sReloadedBy :: UniqFM Store [BlockId]
sReloadedBy = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. [a] -> [a] -> [a]
(++)
                                (CleanS -> UniqFM Store [BlockId]
sReloadedBy CleanS
s)
                                (Int -> Store
SSlot Int
slot)
                                [BlockId
blockId] }


-------------------------------------------------------------------------------
-- A store location can be a stack slot or a register
data Store
        = SSlot Int
        | SReg  Reg


-- | Check if this is a reg store.
isStoreReg :: Store -> Bool
isStoreReg :: Store -> Bool
isStoreReg Store
ss
 = case Store
ss of
        SSlot Int
_ -> Bool
False
        SReg  Reg
_ -> Bool
True


-- Spill cleaning is only done once all virtuals have been allocated to realRegs
instance Uniquable Store where
    getUnique :: Store -> Unique
getUnique (SReg  Reg
r)
        | RegReal (RealRegSingle Int
i)     <- Reg
r
        = Int -> Unique
mkRegSingleUnique Int
i

        | RegReal (RealRegPair Int
r1 Int
r2)   <- Reg
r
        = Int -> Unique
mkRegPairUnique (Int
r1 forall a. Num a => a -> a -> a
* Int
65535 forall a. Num a => a -> a -> a
+ Int
r2)

        | Bool
otherwise
        = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"RegSpillClean.getUnique: found virtual reg during spill clean,"
                forall a. [a] -> [a] -> [a]
++ String
"only real regs expected."

    getUnique (SSlot Int
i) = Int -> Unique
mkRegSubUnique Int
i    -- [SLPJ] I hope "SubUnique" is ok


instance Outputable Store where
        ppr :: Store -> SDoc
ppr (SSlot Int
i)   = String -> SDoc
text String
"slot" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i
        ppr (SReg  Reg
r)   = forall a. Outputable a => a -> SDoc
ppr Reg
r


-------------------------------------------------------------------------------
-- Association graphs.
-- In the spill cleaner, two store locations are associated if they are known
-- to hold the same value.
--
-- TODO: Monomorphize: I think we only ever use this with a ~ Store
type Assoc a    = UniqFM a (UniqSet a)

-- | An empty association
emptyAssoc :: Assoc a
emptyAssoc :: forall a. Assoc a
emptyAssoc      = forall key elt. UniqFM key elt
emptyUFM


-- | Add an association between these two things.
-- addAssoc :: Uniquable a
--          => a -> a -> Assoc a -> Assoc a
addAssoc :: Store -> Store -> Assoc Store -> Assoc Store

addAssoc :: Store -> Store -> Assoc Store -> Assoc Store
addAssoc Store
a Store
b Assoc Store
m
 = let  m1 :: Assoc Store
m1      = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets Assoc Store
m  Store
a (forall a. Uniquable a => a -> UniqSet a
unitUniqSet Store
b)
        m2 :: Assoc Store
m2      = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets Assoc Store
m1 Store
b (forall a. Uniquable a => a -> UniqSet a
unitUniqSet Store
a)
   in   Assoc Store
m2


-- | Delete all associations to a node.
delAssoc :: Store -> Assoc Store -> Assoc Store
delAssoc :: Store -> Assoc Store -> Assoc Store
delAssoc Store
a Assoc Store
m
        | Just UniqSet Store
aSet     <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM  Assoc Store
m Store
a
        , Assoc Store
m1            <- forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM Assoc Store
m Store
a
        = forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet (\Store
x Assoc Store
m -> Store -> Store -> Assoc Store -> Assoc Store
delAssoc1 Store
x Store
a Assoc Store
m) Assoc Store
m1 UniqSet Store
aSet
          -- It's OK to use a non-deterministic fold here because deletion is
          -- commutative

        | Bool
otherwise     = Assoc Store
m


-- | Delete a single association edge (a -> b).
delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store
delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store
delAssoc1 Store
a Store
b Assoc Store
m
        | Just UniqSet Store
aSet     <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM Assoc Store
m Store
a
        = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM Assoc Store
m Store
a (forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet Store
aSet Store
b)

        | Bool
otherwise     = Assoc Store
m


-- | Check if these two things are associated.
elemAssoc :: Store -> Store -> Assoc Store -> Bool

elemAssoc :: Store -> Store -> Assoc Store -> Bool
elemAssoc Store
a Store
b Assoc Store
m
        = forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Store
b (Store -> Assoc Store -> UniqSet Store
closeAssoc Store
a Assoc Store
m)


-- | Find the refl. trans. closure of the association from this point.
closeAssoc :: Store -> Assoc Store -> UniqSet Store
closeAssoc :: Store -> Assoc Store -> UniqSet Store
closeAssoc Store
a Assoc Store
assoc
 =      forall {key}.
Uniquable key =>
UniqFM key (UniqSet key)
-> UniqSet key -> UniqSet key -> UniqSet key
closeAssoc' Assoc Store
assoc forall a. UniqSet a
emptyUniqSet (forall a. Uniquable a => a -> UniqSet a
unitUniqSet Store
a)
 where
        closeAssoc' :: UniqFM key (UniqSet key)
-> UniqSet key -> UniqSet key -> UniqSet key
closeAssoc' UniqFM key (UniqSet key)
assoc UniqSet key
visited UniqSet key
toVisit
         = case forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet key
toVisit of
             -- See Note [Unique Determinism and code generation]

                -- nothing else to visit, we're done
                []      -> UniqSet key
visited

                (key
x:[key]
_)
                 -- we've already seen this node
                 |  forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet key
x UniqSet key
visited
                 -> UniqFM key (UniqSet key)
-> UniqSet key -> UniqSet key -> UniqSet key
closeAssoc' UniqFM key (UniqSet key)
assoc UniqSet key
visited (forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet key
toVisit key
x)

                 -- haven't seen this node before,
                 --     remember to visit all its neighbors
                 |  Bool
otherwise
                 -> let neighbors :: UniqSet key
neighbors
                         = case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM key (UniqSet key)
assoc key
x of
                                Maybe (UniqSet key)
Nothing         -> forall a. UniqSet a
emptyUniqSet
                                Just UniqSet key
set        -> UniqSet key
set

                   in UniqFM key (UniqSet key)
-> UniqSet key -> UniqSet key -> UniqSet key
closeAssoc' UniqFM key (UniqSet key)
assoc
                        (forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet key
visited key
x)
                        (forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets   UniqSet key
toVisit UniqSet key
neighbors)

-- | Intersect two associations.
intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store
intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store
intersectAssoc Assoc Store
a Assoc Store
b
        = forall elt1 elt2 elt3 key.
(elt1 -> elt2 -> elt3)
-> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt3
intersectUFM_C (forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets) Assoc Store
a Assoc Store
b