-- | When there aren't enough registers to hold all the vregs we have to spill
--   some of those vregs to slots on the stack. This module is used modify the
--   code to use those slots.
module GHC.CmmToAsm.Reg.Graph.Spill (
        regSpill,
        SpillStats(..),
        accSpillSL
) where
import GHC.Prelude

import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg
import GHC.Cmm hiding (RegSet)
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections

import GHC.Utils.Monad
import GHC.Utils.Monad.State
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Platform

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


-- | Spill all these virtual regs to stack slots.
--
--   Bumps the number of required stack slots if required.
--
--
--   TODO: See if we can split some of the live ranges instead of just globally
--         spilling the virtual reg. This might make the spill cleaner's job easier.
--
--   TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction
--         when making spills. If an instr is using a spilled virtual we may be able to
--         address the spill slot directly.
--
regSpill
        :: Instruction instr
        => Platform
        -> [LiveCmmDecl statics instr]  -- ^ the code
        -> UniqSet Int                  -- ^ available stack slots
        -> Int                          -- ^ current number of spill slots.
        -> UniqSet VirtualReg           -- ^ the regs to spill
        -> UniqSM
            ([LiveCmmDecl statics instr]
                 -- code with SPILL and RELOAD meta instructions added.
            , UniqSet Int               -- left over slots
            , Int                       -- slot count in use now.
            , SpillStats )              -- stats about what happened during spilling

regSpill :: Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqSM
     ([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
regSpill Platform
platform [LiveCmmDecl statics instr]
code UniqSet Int
slotsFree Int
slotCount UniqSet VirtualReg
regs

        -- Not enough slots to spill these regs.
        | UniqSet Int -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet Int
slotsFree Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord Int
< UniqSet VirtualReg -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet VirtualReg
regs
        = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $
          let slotsFree' :: UniqSet Int
slotsFree' = (UniqSet Int -> [Int] -> UniqSet Int
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
External instance of the constraint type Uniquable Int
addListToUniqSet UniqSet Int
slotsFree [Int
slotCountInt -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+Int
1 .. Int
slotCountInt -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+Int
512])
          in Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqSM
     ([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
forall instr statics.
Instruction instr =>
Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqSM
     ([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
Evidence bound by a type signature of the constraint type Instruction instr
regSpill Platform
platform [LiveCmmDecl statics instr]
code UniqSet Int
slotsFree' (Int
slotCountInt -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+Int
512) UniqSet VirtualReg
regs

        | Bool
otherwise
        = do
                -- Allocate a slot for each of the spilled regs.
                let slots :: [Int]
slots       = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (UniqSet VirtualReg -> Int
forall a. UniqSet a -> Int
sizeUniqSet UniqSet VirtualReg
regs) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ UniqSet Int -> [Int]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Int
slotsFree
                let regSlotMap :: UniqFM Int
regSlotMap  = [(VirtualReg, Int)] -> UniqFM Int
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
External instance of the constraint type Uniquable VirtualReg
listToUFM
                                ([(VirtualReg, Int)] -> UniqFM Int)
-> [(VirtualReg, Int)] -> UniqFM Int
forall a b. (a -> b) -> a -> b
$ [VirtualReg] -> [Int] -> [(VirtualReg, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (UniqSet VirtualReg -> [VirtualReg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet VirtualReg
regs) [Int]
slots
                    -- This is non-deterministic but we do not
                    -- currently support deterministic code-generation.
                    -- See Note [Unique Determinism and code generation]

                -- Grab the unique supply from the monad.
                UniqSupply
us      <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
External instance of the constraint type MonadUnique UniqSM
getUniqueSupplyM

                -- Run the spiller on all the blocks.
                let ([LiveCmmDecl statics instr]
code', SpillS
state')     =
                        State SpillS [LiveCmmDecl statics instr]
-> SpillS -> ([LiveCmmDecl statics instr], SpillS)
forall s a. State s a -> s -> (a, s)
runState ((LiveCmmDecl statics instr
 -> State SpillS (LiveCmmDecl statics instr))
-> [LiveCmmDecl statics instr]
-> State SpillS [LiveCmmDecl statics instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall s. Monad (State s)
External instance of the constraint type Traversable []
mapM (Platform
-> UniqFM Int
-> LiveCmmDecl statics instr
-> State SpillS (LiveCmmDecl statics instr)
forall instr statics.
Instruction instr =>
Platform
-> UniqFM Int
-> LiveCmmDecl statics instr
-> SpillM (LiveCmmDecl statics instr)
Evidence bound by a type signature of the constraint type Instruction instr
regSpill_top Platform
platform UniqFM Int
regSlotMap) [LiveCmmDecl statics instr]
code)
                                 (UniqSupply -> SpillS
initSpillS UniqSupply
us)

                ([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
-> UniqSM
     ([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad UniqSM
return  ( [LiveCmmDecl statics instr]
code'
                        , UniqSet Int -> UniqSet Int -> UniqSet Int
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet UniqSet Int
slotsFree ([Int] -> UniqSet Int
forall a. Uniquable a => [a] -> UniqSet a
External instance of the constraint type Uniquable Int
mkUniqSet [Int]
slots)
                        , Int
slotCount
                        , SpillS -> SpillStats
makeSpillStats SpillS
state')


-- | Spill some registers to stack slots in a top-level thing.
regSpill_top
        :: Instruction instr
        => Platform
        -> RegMap Int
                -- ^ map of vregs to slots they're being spilled to.
        -> LiveCmmDecl statics instr
                -- ^ the top level thing.
        -> SpillM (LiveCmmDecl statics instr)

regSpill_top :: Platform
-> UniqFM Int
-> LiveCmmDecl statics instr
-> SpillM (LiveCmmDecl statics instr)
regSpill_top Platform
platform UniqFM Int
regSlotMap LiveCmmDecl statics instr
cmm
 = case LiveCmmDecl statics instr
cmm of
        CmmData{}
         -> LiveCmmDecl statics instr -> SpillM (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return LiveCmmDecl statics instr
cmm

        CmmProc LiveInfo
info CLabel
label [GlobalReg]
live [SCC (LiveBasicBlock instr)]
sccs
         |  LiveInfo LabelMap RawCmmStatics
static [BlockId]
firstId BlockMap RegSet
liveVRegsOnEntry BlockMap IntSet
liveSlotsOnEntry <- LiveInfo
info
         -> do
                -- The liveVRegsOnEntry contains the set of vregs that are live
                -- on entry to each basic block. If we spill one of those vregs
                -- we remove it from that set and add the corresponding slot
                -- number to the liveSlotsOnEntry set. The spill cleaner needs
                -- this information to erase unneeded spill and reload instructions
                -- after we've done a successful allocation.
                let liveSlotsOnEntry' :: BlockMap IntSet
                    liveSlotsOnEntry' :: BlockMap IntSet
liveSlotsOnEntry'
                        = (BlockMap IntSet -> KeyOf LabelMap -> RegSet -> BlockMap IntSet)
-> BlockMap IntSet -> BlockMap RegSet -> BlockMap IntSet
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
External instance of the constraint type IsMap LabelMap
mapFoldlWithKey BlockMap IntSet -> KeyOf LabelMap -> RegSet -> BlockMap IntSet
BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
patchLiveSlot
                                          BlockMap IntSet
liveSlotsOnEntry BlockMap RegSet
liveVRegsOnEntry

                let info' :: LiveInfo
info'
                        = LabelMap RawCmmStatics
-> [BlockId] -> BlockMap RegSet -> BlockMap IntSet -> LiveInfo
LiveInfo LabelMap RawCmmStatics
static [BlockId]
firstId
                                BlockMap RegSet
liveVRegsOnEntry
                                BlockMap IntSet
liveSlotsOnEntry'

                -- Apply the spiller to all the basic blocks in the CmmProc.
                [SCC (LiveBasicBlock instr)]
sccs'   <- (SCC (LiveBasicBlock instr)
 -> State SpillS (SCC (LiveBasicBlock instr)))
-> [SCC (LiveBasicBlock instr)]
-> State SpillS [SCC (LiveBasicBlock instr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall s. Monad (State s)
External instance of the constraint type Traversable []
mapM ((LiveBasicBlock instr -> State SpillS (LiveBasicBlock instr))
-> SCC (LiveBasicBlock instr)
-> State SpillS (SCC (LiveBasicBlock instr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SCC a -> m (SCC b)
External instance of the constraint type forall s. Monad (State s)
mapSCCM (Platform
-> UniqFM Int
-> LiveBasicBlock instr
-> State SpillS (LiveBasicBlock instr)
forall instr.
Instruction instr =>
Platform
-> UniqFM Int
-> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr)
Evidence bound by a type signature of the constraint type Instruction instr
regSpill_block Platform
platform UniqFM Int
regSlotMap)) [SCC (LiveBasicBlock instr)]
sccs

                LiveCmmDecl statics instr -> SpillM (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return  (LiveCmmDecl statics instr -> SpillM (LiveCmmDecl statics instr))
-> LiveCmmDecl statics instr -> SpillM (LiveCmmDecl statics instr)
forall a b. (a -> b) -> a -> b
$ LiveInfo
-> CLabel
-> [GlobalReg]
-> [SCC (LiveBasicBlock instr)]
-> LiveCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LiveInfo
info' CLabel
label [GlobalReg]
live [SCC (LiveBasicBlock instr)]
sccs'

 where  -- Given a BlockId and the set of registers live in it,
        -- if registers in this block are being spilled to stack slots,
        -- then record the fact that these slots are now live in those blocks
        -- in the given slotmap.
        patchLiveSlot
                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet

        patchLiveSlot :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
patchLiveSlot BlockMap IntSet
slotMap BlockId
blockId RegSet
regsLive
         = let
                -- Slots that are already recorded as being live.
                curSlotsLive :: IntSet
curSlotsLive    = IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
IntSet.empty
                                (Maybe IntSet -> IntSet) -> Maybe IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> BlockMap IntSet -> Maybe IntSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
External instance of the constraint type IsMap LabelMap
mapLookup KeyOf LabelMap
BlockId
blockId BlockMap IntSet
slotMap

                moreSlotsLive :: IntSet
moreSlotsLive   = [Int] -> IntSet
IntSet.fromList
                                ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes
                                ([Maybe Int] -> [Int]) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Reg -> Maybe Int) -> [Reg] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map (UniqFM Int -> Reg -> Maybe Int
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
External instance of the constraint type Uniquable Reg
lookupUFM UniqFM Int
regSlotMap)
                                ([Reg] -> [Maybe Int]) -> [Reg] -> [Maybe Int]
forall a b. (a -> b) -> a -> b
$ RegSet -> [Reg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet RegSet
regsLive
                    -- See Note [Unique Determinism and code generation]

                slotMap' :: BlockMap IntSet
slotMap'
                 = KeyOf LabelMap -> IntSet -> BlockMap IntSet -> BlockMap IntSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
External instance of the constraint type IsMap LabelMap
mapInsert KeyOf LabelMap
BlockId
blockId (IntSet -> IntSet -> IntSet
IntSet.union IntSet
curSlotsLive IntSet
moreSlotsLive)
                             BlockMap IntSet
slotMap

           in   BlockMap IntSet
slotMap'


-- | Spill some registers to stack slots in a basic block.
regSpill_block
        :: Instruction instr
        => Platform
        -> UniqFM Int   -- ^ map of vregs to slots they're being spilled to.
        -> LiveBasicBlock instr
        -> SpillM (LiveBasicBlock instr)

regSpill_block :: Platform
-> UniqFM Int
-> LiveBasicBlock instr
-> SpillM (LiveBasicBlock instr)
regSpill_block Platform
platform UniqFM Int
regSlotMap (BasicBlock BlockId
i [LiveInstr instr]
instrs)
 = do   [[LiveInstr instr]]
instrss'        <- (LiveInstr instr -> State SpillS [LiveInstr instr])
-> [LiveInstr instr] -> State SpillS [[LiveInstr instr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall s. Monad (State s)
External instance of the constraint type Traversable []
mapM (Platform
-> UniqFM Int -> LiveInstr instr -> State SpillS [LiveInstr instr]
forall instr.
Instruction instr =>
Platform
-> UniqFM Int -> LiveInstr instr -> SpillM [LiveInstr instr]
Evidence bound by a type signature of the constraint type Instruction instr
regSpill_instr Platform
platform UniqFM Int
regSlotMap) [LiveInstr instr]
instrs
        LiveBasicBlock instr -> SpillM (LiveBasicBlock instr)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return  (LiveBasicBlock instr -> SpillM (LiveBasicBlock instr))
-> LiveBasicBlock instr -> SpillM (LiveBasicBlock instr)
forall a b. (a -> b) -> a -> b
$ BlockId -> [LiveInstr instr] -> LiveBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
i ([[LiveInstr instr]] -> [LiveInstr instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
External instance of the constraint type Foldable []
concat [[LiveInstr instr]]
instrss')


-- | Spill some registers to stack slots in a single instruction.
--   If the instruction uses registers that need to be spilled, then it is
--   prefixed (or postfixed) with the appropriate RELOAD or SPILL meta
--   instructions.
regSpill_instr
        :: Instruction instr
        => Platform
        -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
        -> LiveInstr instr
        -> SpillM [LiveInstr instr]

regSpill_instr :: Platform
-> UniqFM Int -> LiveInstr instr -> SpillM [LiveInstr instr]
regSpill_instr Platform
_ UniqFM Int
_ li :: LiveInstr instr
li@(LiveInstr InstrSR instr
_ Maybe Liveness
Nothing)
 = do   [LiveInstr instr] -> SpillM [LiveInstr instr]
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return [LiveInstr instr
li]

regSpill_instr Platform
platform UniqFM Int
regSlotMap
        (LiveInstr InstrSR instr
instr (Just Liveness
_))
 = do
        -- work out which regs are read and written in this instr
        let RU [Reg]
rlRead [Reg]
rlWritten = Platform -> InstrSR instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
External instance of the constraint type forall instr. Instruction instr => Instruction (InstrSR instr)
Evidence bound by a type signature of the constraint type Instruction instr
regUsageOfInstr Platform
platform InstrSR instr
instr

        -- sometimes a register is listed as being read more than once,
        --      nub this so we don't end up inserting two lots of spill code.
        let rsRead_ :: [Reg]
rsRead_             = [Reg] -> [Reg]
forall a. Eq a => [a] -> [a]
External instance of the constraint type Eq Reg
nub [Reg]
rlRead
        let rsWritten_ :: [Reg]
rsWritten_          = [Reg] -> [Reg]
forall a. Eq a => [a] -> [a]
External instance of the constraint type Eq Reg
nub [Reg]
rlWritten

        -- if a reg is modified, it appears in both lists, want to undo this..
        let rsRead :: [Reg]
rsRead              = [Reg]
rsRead_    [Reg] -> [Reg] -> [Reg]
forall a. Eq a => [a] -> [a] -> [a]
External instance of the constraint type Eq Reg
\\ [Reg]
rsWritten_
        let rsWritten :: [Reg]
rsWritten           = [Reg]
rsWritten_ [Reg] -> [Reg] -> [Reg]
forall a. Eq a => [a] -> [a] -> [a]
External instance of the constraint type Eq Reg
\\ [Reg]
rsRead_
        let rsModify :: [Reg]
rsModify            = [Reg] -> [Reg] -> [Reg]
forall a. Eq a => [a] -> [a] -> [a]
External instance of the constraint type Eq Reg
intersect [Reg]
rsRead_ [Reg]
rsWritten_

        -- work out if any of the regs being used are currently being spilled.
        let rsSpillRead :: [Reg]
rsSpillRead         = (Reg -> Bool) -> [Reg] -> [Reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Reg
r -> Reg -> UniqFM Int -> Bool
forall key elt. Uniquable key => key -> UniqFM elt -> Bool
External instance of the constraint type Uniquable Reg
elemUFM Reg
r UniqFM Int
regSlotMap) [Reg]
rsRead
        let rsSpillWritten :: [Reg]
rsSpillWritten      = (Reg -> Bool) -> [Reg] -> [Reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Reg
r -> Reg -> UniqFM Int -> Bool
forall key elt. Uniquable key => key -> UniqFM elt -> Bool
External instance of the constraint type Uniquable Reg
elemUFM Reg
r UniqFM Int
regSlotMap) [Reg]
rsWritten
        let rsSpillModify :: [Reg]
rsSpillModify       = (Reg -> Bool) -> [Reg] -> [Reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Reg
r -> Reg -> UniqFM Int -> Bool
forall key elt. Uniquable key => key -> UniqFM elt -> Bool
External instance of the constraint type Uniquable Reg
elemUFM Reg
r UniqFM Int
regSlotMap) [Reg]
rsModify

        -- rewrite the instr and work out spill code.
        (InstrSR instr
instr1, [([LiveInstr instr], [LiveInstr instr])]
prepost1)      <- (InstrSR instr
 -> Reg
 -> State
      SpillS (InstrSR instr, ([LiveInstr instr], [LiveInstr instr])))
-> InstrSR instr
-> [Reg]
-> State
     SpillS (InstrSR instr, [([LiveInstr instr], [LiveInstr instr])])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
External instance of the constraint type forall s. Monad (State s)
mapAccumLM (UniqFM Int
-> InstrSR instr
-> Reg
-> State
     SpillS (InstrSR instr, ([LiveInstr instr], [LiveInstr instr]))
forall instr instr'.
Instruction instr =>
UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
External instance of the constraint type forall instr. Instruction instr => Instruction (InstrSR instr)
Evidence bound by a type signature of the constraint type Instruction instr
spillRead   UniqFM Int
regSlotMap) InstrSR instr
instr  [Reg]
rsSpillRead
        (InstrSR instr
instr2, [([LiveInstr instr], [LiveInstr instr])]
prepost2)      <- (InstrSR instr
 -> Reg
 -> State
      SpillS (InstrSR instr, ([LiveInstr instr], [LiveInstr instr])))
-> InstrSR instr
-> [Reg]
-> State
     SpillS (InstrSR instr, [([LiveInstr instr], [LiveInstr instr])])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
External instance of the constraint type forall s. Monad (State s)
mapAccumLM (UniqFM Int
-> InstrSR instr
-> Reg
-> State
     SpillS (InstrSR instr, ([LiveInstr instr], [LiveInstr instr]))
forall instr instr'.
Instruction instr =>
UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
External instance of the constraint type forall instr. Instruction instr => Instruction (InstrSR instr)
Evidence bound by a type signature of the constraint type Instruction instr
spillWrite  UniqFM Int
regSlotMap) InstrSR instr
instr1 [Reg]
rsSpillWritten
        (InstrSR instr
instr3, [([LiveInstr instr], [LiveInstr instr])]
prepost3)      <- (InstrSR instr
 -> Reg
 -> State
      SpillS (InstrSR instr, ([LiveInstr instr], [LiveInstr instr])))
-> InstrSR instr
-> [Reg]
-> State
     SpillS (InstrSR instr, [([LiveInstr instr], [LiveInstr instr])])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
External instance of the constraint type forall s. Monad (State s)
mapAccumLM (UniqFM Int
-> InstrSR instr
-> Reg
-> State
     SpillS (InstrSR instr, ([LiveInstr instr], [LiveInstr instr]))
forall instr instr'.
Instruction instr =>
UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
External instance of the constraint type forall instr. Instruction instr => Instruction (InstrSR instr)
Evidence bound by a type signature of the constraint type Instruction instr
spillModify UniqFM Int
regSlotMap) InstrSR instr
instr2 [Reg]
rsSpillModify

        let ([[LiveInstr instr]]
mPrefixes, [[LiveInstr instr]]
mPostfixes)     = [([LiveInstr instr], [LiveInstr instr])]
-> ([[LiveInstr instr]], [[LiveInstr instr]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([LiveInstr instr], [LiveInstr instr])]
prepost1 [([LiveInstr instr], [LiveInstr instr])]
-> [([LiveInstr instr], [LiveInstr instr])]
-> [([LiveInstr instr], [LiveInstr instr])]
forall a. [a] -> [a] -> [a]
++ [([LiveInstr instr], [LiveInstr instr])]
prepost2 [([LiveInstr instr], [LiveInstr instr])]
-> [([LiveInstr instr], [LiveInstr instr])]
-> [([LiveInstr instr], [LiveInstr instr])]
forall a. [a] -> [a] -> [a]
++ [([LiveInstr instr], [LiveInstr instr])]
prepost3)
        let prefixes :: [LiveInstr instr]
prefixes                    = [[LiveInstr instr]] -> [LiveInstr instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
External instance of the constraint type Foldable []
concat [[LiveInstr instr]]
mPrefixes
        let postfixes :: [LiveInstr instr]
postfixes                   = [[LiveInstr instr]] -> [LiveInstr instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
External instance of the constraint type Foldable []
concat [[LiveInstr instr]]
mPostfixes

        -- final code
        let instrs' :: [LiveInstr instr]
instrs'     =  [LiveInstr instr]
prefixes
                        [LiveInstr instr] -> [LiveInstr instr] -> [LiveInstr instr]
forall a. [a] -> [a] -> [a]
++ [InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr3 Maybe Liveness
forall a. Maybe a
Nothing]
                        [LiveInstr instr] -> [LiveInstr instr] -> [LiveInstr instr]
forall a. [a] -> [a] -> [a]
++ [LiveInstr instr]
postfixes

        [LiveInstr instr] -> SpillM [LiveInstr instr]
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return ([LiveInstr instr] -> SpillM [LiveInstr instr])
-> [LiveInstr instr] -> SpillM [LiveInstr instr]
forall a b. (a -> b) -> a -> b
$ [LiveInstr instr]
instrs'


-- | Add a RELOAD met a instruction to load a value for an instruction that
--   writes to a vreg that is being spilled.
spillRead
        :: Instruction instr
        => UniqFM Int
        -> instr
        -> Reg
        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))

spillRead :: UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillRead UniqFM Int
regSlotMap instr
instr Reg
reg
 | Just Int
slot     <- UniqFM Int -> Reg -> Maybe Int
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
External instance of the constraint type Uniquable Reg
lookupUFM UniqFM Int
regSlotMap Reg
reg
 = do    (instr
instr', Reg
nReg)  <- Reg -> instr -> SpillM (instr, Reg)
forall instr.
Instruction instr =>
Reg -> instr -> SpillM (instr, Reg)
Evidence bound by a type signature of the constraint type Instruction instr
patchInstr Reg
reg instr
instr

         (SpillS -> SpillS) -> State SpillS ()
forall s. (s -> s) -> State s ()
modify ((SpillS -> SpillS) -> State SpillS ())
-> (SpillS -> SpillS) -> State SpillS ()
forall a b. (a -> b) -> a -> b
$ \SpillS
s -> SpillS
s
                { stateSpillSL :: UniqFM (Reg, Int, Int)
stateSpillSL  = ((Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int))
-> UniqFM (Reg, Int, Int)
-> Reg
-> (Reg, Int, Int)
-> UniqFM (Reg, Int, Int)
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
External instance of the constraint type Uniquable Reg
addToUFM_C (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
accSpillSL (SpillS -> UniqFM (Reg, Int, Int)
stateSpillSL SpillS
s) Reg
reg (Reg
reg, Int
0, Int
1) }

         (instr, ([LiveInstr instr'], [LiveInstr instr']))
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return  ( instr
instr'
                 , ( [InstrSR instr' -> Maybe Liveness -> LiveInstr instr'
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (Int -> Reg -> InstrSR instr'
forall instr. Int -> Reg -> InstrSR instr
RELOAD Int
slot Reg
nReg) Maybe Liveness
forall a. Maybe a
Nothing]
                 , []) )

 | Bool
otherwise     = String -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall a. String -> a
panic String
"RegSpill.spillRead: no slot defined for spilled reg"


-- | Add a SPILL meta instruction to store a value for an instruction that
--   writes to a vreg that is being spilled.
spillWrite
        :: Instruction instr
        => UniqFM Int
        -> instr
        -> Reg
        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))

spillWrite :: UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillWrite UniqFM Int
regSlotMap instr
instr Reg
reg
 | Just Int
slot     <- UniqFM Int -> Reg -> Maybe Int
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
External instance of the constraint type Uniquable Reg
lookupUFM UniqFM Int
regSlotMap Reg
reg
 = do    (instr
instr', Reg
nReg)  <- Reg -> instr -> SpillM (instr, Reg)
forall instr.
Instruction instr =>
Reg -> instr -> SpillM (instr, Reg)
Evidence bound by a type signature of the constraint type Instruction instr
patchInstr Reg
reg instr
instr

         (SpillS -> SpillS) -> State SpillS ()
forall s. (s -> s) -> State s ()
modify ((SpillS -> SpillS) -> State SpillS ())
-> (SpillS -> SpillS) -> State SpillS ()
forall a b. (a -> b) -> a -> b
$ \SpillS
s -> SpillS
s
                { stateSpillSL :: UniqFM (Reg, Int, Int)
stateSpillSL  = ((Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int))
-> UniqFM (Reg, Int, Int)
-> Reg
-> (Reg, Int, Int)
-> UniqFM (Reg, Int, Int)
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
External instance of the constraint type Uniquable Reg
addToUFM_C (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
accSpillSL (SpillS -> UniqFM (Reg, Int, Int)
stateSpillSL SpillS
s) Reg
reg (Reg
reg, Int
1, Int
0) }

         (instr, ([LiveInstr instr'], [LiveInstr instr']))
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return  ( instr
instr'
                 , ( []
                   , [InstrSR instr' -> Maybe Liveness -> LiveInstr instr'
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (Reg -> Int -> InstrSR instr'
forall instr. Reg -> Int -> InstrSR instr
SPILL Reg
nReg Int
slot) Maybe Liveness
forall a. Maybe a
Nothing]))

 | Bool
otherwise     = String -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall a. String -> a
panic String
"RegSpill.spillWrite: no slot defined for spilled reg"


-- | Add both RELOAD and SPILL meta instructions for an instruction that
--   both reads and writes to a vreg that is being spilled.
spillModify
        :: Instruction instr
        => UniqFM Int
        -> instr
        -> Reg
        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))

spillModify :: UniqFM Int
-> instr
-> Reg
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillModify UniqFM Int
regSlotMap instr
instr Reg
reg
 | Just Int
slot     <- UniqFM Int -> Reg -> Maybe Int
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
External instance of the constraint type Uniquable Reg
lookupUFM UniqFM Int
regSlotMap Reg
reg
 = do    (instr
instr', Reg
nReg)  <- Reg -> instr -> SpillM (instr, Reg)
forall instr.
Instruction instr =>
Reg -> instr -> SpillM (instr, Reg)
Evidence bound by a type signature of the constraint type Instruction instr
patchInstr Reg
reg instr
instr

         (SpillS -> SpillS) -> State SpillS ()
forall s. (s -> s) -> State s ()
modify ((SpillS -> SpillS) -> State SpillS ())
-> (SpillS -> SpillS) -> State SpillS ()
forall a b. (a -> b) -> a -> b
$ \SpillS
s -> SpillS
s
                { stateSpillSL :: UniqFM (Reg, Int, Int)
stateSpillSL  = ((Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int))
-> UniqFM (Reg, Int, Int)
-> Reg
-> (Reg, Int, Int)
-> UniqFM (Reg, Int, Int)
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
External instance of the constraint type Uniquable Reg
addToUFM_C (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
accSpillSL (SpillS -> UniqFM (Reg, Int, Int)
stateSpillSL SpillS
s) Reg
reg (Reg
reg, Int
1, Int
1) }

         (instr, ([LiveInstr instr'], [LiveInstr instr']))
-> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return  ( instr
instr'
                 , ( [InstrSR instr' -> Maybe Liveness -> LiveInstr instr'
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (Int -> Reg -> InstrSR instr'
forall instr. Int -> Reg -> InstrSR instr
RELOAD Int
slot Reg
nReg) Maybe Liveness
forall a. Maybe a
Nothing]
                   , [InstrSR instr' -> Maybe Liveness -> LiveInstr instr'
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (Reg -> Int -> InstrSR instr'
forall instr. Reg -> Int -> InstrSR instr
SPILL Reg
nReg Int
slot) Maybe Liveness
forall a. Maybe a
Nothing]))

 | Bool
otherwise     = String -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
forall a. String -> a
panic String
"RegSpill.spillModify: no slot defined for spilled reg"


-- | Rewrite uses of this virtual reg in an instr to use a different
--   virtual reg.
patchInstr
        :: Instruction instr
        => Reg -> instr -> SpillM (instr, Reg)

patchInstr :: Reg -> instr -> SpillM (instr, Reg)
patchInstr Reg
reg instr
instr
 = do   Unique
nUnique         <- SpillM Unique
newUnique

        -- The register we're rewriting is supposed to be virtual.
        -- If it's not then something has gone horribly wrong.
        let nReg :: Reg
nReg
             = case Reg
reg of
                RegVirtual VirtualReg
vr
                 -> VirtualReg -> Reg
RegVirtual (Unique -> VirtualReg -> VirtualReg
renameVirtualReg Unique
nUnique VirtualReg
vr)

                RegReal{}
                 -> String -> Reg
forall a. String -> a
panic String
"RegAlloc.Graph.Spill.patchIntr: not patching real reg"

        let instr' :: instr
instr'      = Reg -> Reg -> instr -> instr
forall instr. Instruction instr => Reg -> Reg -> instr -> instr
Evidence bound by a type signature of the constraint type Instruction instr
patchReg1 Reg
reg Reg
nReg instr
instr
        (instr, Reg) -> SpillM (instr, Reg)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return          (instr
instr', Reg
nReg)


patchReg1
        :: Instruction instr
        => Reg -> Reg -> instr -> instr

patchReg1 :: Reg -> Reg -> instr -> instr
patchReg1 Reg
old Reg
new instr
instr
 = let  patchF :: Reg -> Reg
patchF Reg
r
                | Reg
r Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Reg
== Reg
old      = Reg
new
                | Bool
otherwise     = Reg
r
   in   instr -> (Reg -> Reg) -> instr
forall instr. Instruction instr => instr -> (Reg -> Reg) -> instr
Evidence bound by a type signature of the constraint type Instruction instr
patchRegsOfInstr instr
instr Reg -> Reg
patchF


-- Spiller monad --------------------------------------------------------------
-- | State monad for the spill code generator.
type SpillM a
        = State SpillS a

-- | Spill code generator state.
data SpillS
        = SpillS
        { -- | Unique supply for generating fresh vregs.
          SpillS -> UniqSupply
stateUS       :: UniqSupply

          -- | Spilled vreg vs the number of times it was loaded, stored.
        , SpillS -> UniqFM (Reg, Int, Int)
stateSpillSL  :: UniqFM (Reg, Int, Int) }


-- | Create a new spiller state.
initSpillS :: UniqSupply -> SpillS
initSpillS :: UniqSupply -> SpillS
initSpillS UniqSupply
uniqueSupply
        = SpillS :: UniqSupply -> UniqFM (Reg, Int, Int) -> SpillS
SpillS
        { stateUS :: UniqSupply
stateUS       = UniqSupply
uniqueSupply
        , stateSpillSL :: UniqFM (Reg, Int, Int)
stateSpillSL  = UniqFM (Reg, Int, Int)
forall elt. UniqFM elt
emptyUFM }


-- | Allocate a new unique in the spiller monad.
newUnique :: SpillM Unique
newUnique :: SpillM Unique
newUnique
 = do   UniqSupply
us      <- (SpillS -> UniqSupply) -> State SpillS UniqSupply
forall s a. (s -> a) -> State s a
gets SpillS -> UniqSupply
stateUS
        case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us of
         (Unique
uniq, UniqSupply
us')
          -> do (SpillS -> SpillS) -> State SpillS ()
forall s. (s -> s) -> State s ()
modify ((SpillS -> SpillS) -> State SpillS ())
-> (SpillS -> SpillS) -> State SpillS ()
forall a b. (a -> b) -> a -> b
$ \SpillS
s -> SpillS
s { stateUS :: UniqSupply
stateUS = UniqSupply
us' }
                Unique -> SpillM Unique
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall s. Monad (State s)
return Unique
uniq


-- | Add a spill/reload count to a stats record for a register.
accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
accSpillSL (Reg
r1, Int
s1, Int
l1) (Reg
_, Int
s2, Int
l2)
        = (Reg
r1, Int
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ Int
s2, Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ Int
l2)


-- Spiller stats --------------------------------------------------------------
-- | Spiller statistics.
--   Tells us what registers were spilled.
data SpillStats
        = SpillStats
        { SpillStats -> UniqFM (Reg, Int, Int)
spillStoreLoad        :: UniqFM (Reg, Int, Int) }


-- | Extract spiller statistics from the spiller state.
makeSpillStats :: SpillS -> SpillStats
makeSpillStats :: SpillS -> SpillStats
makeSpillStats SpillS
s
        = SpillStats :: UniqFM (Reg, Int, Int) -> SpillStats
SpillStats
        { spillStoreLoad :: UniqFM (Reg, Int, Int)
spillStoreLoad        = SpillS -> UniqFM (Reg, Int, Int)
stateSpillSL SpillS
s }


instance Outputable SpillStats where
 ppr :: SpillStats -> SDoc
ppr SpillStats
stats
        = UniqFM (Reg, Int, Int) -> ([(Reg, Int, Int)] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM (SpillStats -> UniqFM (Reg, Int, Int)
spillStoreLoad SpillStats
stats)
                 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc)
-> ([(Reg, Int, Int)] -> [SDoc]) -> [(Reg, Int, Int)] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Reg, Int, Int) -> SDoc) -> [(Reg, Int, Int)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Reg
r, Int
s, Int
l) -> Reg -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Reg
ppr Reg
r SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
s SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
l))