{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CmmToAsm.Reg.Linear.JoinToTargets (joinToTargets) where
import GHC.Prelude
import GHC.CmmToAsm.Reg.Linear.State
import GHC.CmmToAsm.Reg.Linear.Base
import GHC.CmmToAsm.Reg.Linear.FreeRegs
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Types
import GHC.Platform.Reg
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Data.Graph.Directed
import GHC.Utils.Panic
import GHC.Utils.Monad (concatMapM)
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
joinToTargets
:: (FR freeRegs, Instruction instr)
=> BlockMap RegSet
-> BlockId
-> instr
-> RegM freeRegs ([NatBasicBlock instr]
, instr)
joinToTargets :: forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> BlockId -> instr -> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets BlockMap RegSet
block_live BlockId
id instr
instr
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall instr. Instruction instr => instr -> Bool
isJumpishInstr instr
instr
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], instr
instr)
| Bool
otherwise
= forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> [BlockId]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets' BlockMap RegSet
block_live [] BlockId
id instr
instr (forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr instr
instr)
joinToTargets'
:: (FR freeRegs, Instruction instr)
=> BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> [BlockId]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets' :: forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> [BlockId]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets' BlockMap RegSet
_ [NatBasicBlock instr]
new_blocks BlockId
_ instr
instr []
= forall (m :: * -> *) a. Monad m => a -> m a
return ([NatBasicBlock instr]
new_blocks, instr
instr)
joinToTargets' BlockMap RegSet
block_live [NatBasicBlock instr]
new_blocks BlockId
block_id instr
instr (BlockId
dest:[BlockId]
dests)
= do
BlockAssignment freeRegs
block_assig <- forall freeRegs. RegM freeRegs (BlockAssignment freeRegs)
getBlockAssigR
RegMap Loc
assig <- forall freeRegs. RegM freeRegs (RegMap Loc)
getAssigR
let Just RegSet
live_set = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
dest BlockMap RegSet
block_live
let still_live :: Unique -> Loc -> Bool
still_live Unique
uniq Loc
_ = Unique
uniq forall a. Unique -> UniqSet a -> Bool
`elemUniqSet_Directly` RegSet
live_set
let adjusted_assig :: RegMap Loc
adjusted_assig = forall elt key.
(Unique -> elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM_Directly Unique -> Loc -> Bool
still_live RegMap Loc
assig
let to_free :: [RealReg]
to_free =
[ RealReg
r | (Unique
reg, Loc
loc) <- forall key elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList RegMap Loc
assig
, Bool -> Bool
not (forall a. Unique -> UniqSet a -> Bool
elemUniqSet_Directly Unique
reg RegSet
live_set)
, RealReg
r <- Loc -> [RealReg]
regsOfLoc Loc
loc ]
case forall freeRegs.
BlockId -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc)
lookupBlockAssignment BlockId
dest BlockAssignment freeRegs
block_assig of
Maybe (freeRegs, RegMap Loc)
Nothing
-> forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> BlockId
-> [BlockId]
-> BlockAssignment freeRegs
-> RegMap Loc
-> [RealReg]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_first
BlockMap RegSet
block_live [NatBasicBlock instr]
new_blocks BlockId
block_id instr
instr BlockId
dest [BlockId]
dests
BlockAssignment freeRegs
block_assig RegMap Loc
adjusted_assig [RealReg]
to_free
Just (freeRegs
_, RegMap Loc
dest_assig)
-> forall instr freeRegs.
(Instruction instr, FR freeRegs) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> BlockId
-> [BlockId]
-> RegMap Loc
-> RegMap Loc
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_again
BlockMap RegSet
block_live [NatBasicBlock instr]
new_blocks BlockId
block_id instr
instr BlockId
dest [BlockId]
dests
RegMap Loc
adjusted_assig RegMap Loc
dest_assig
joinToTargets_first :: (FR freeRegs, Instruction instr)
=> BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> BlockId
-> [BlockId]
-> BlockAssignment freeRegs
-> RegMap Loc
-> [RealReg]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_first :: forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> BlockId
-> [BlockId]
-> BlockAssignment freeRegs
-> RegMap Loc
-> [RealReg]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_first BlockMap RegSet
block_live [NatBasicBlock instr]
new_blocks BlockId
block_id instr
instr BlockId
dest [BlockId]
dests
BlockAssignment freeRegs
block_assig RegMap Loc
src_assig
[RealReg]
to_free
= do NCGConfig
config <- forall a. RegM a NCGConfig
getConfig
let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
freeRegs
freeregs <- forall freeRegs. RegM freeRegs freeRegs
getFreeRegsR
let freeregs' :: freeRegs
freeregs' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall freeRegs.
FR freeRegs =>
Platform -> RealReg -> freeRegs -> freeRegs
frReleaseReg Platform
platform) freeRegs
freeregs [RealReg]
to_free
forall freeRegs. BlockAssignment freeRegs -> RegM freeRegs ()
setBlockAssigR (forall freeRegs.
BlockId
-> (freeRegs, RegMap Loc)
-> BlockAssignment freeRegs
-> BlockAssignment freeRegs
updateBlockAssignment BlockId
dest (freeRegs
freeregs', RegMap Loc
src_assig) BlockAssignment freeRegs
block_assig)
forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> [BlockId]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets' BlockMap RegSet
block_live [NatBasicBlock instr]
new_blocks BlockId
block_id instr
instr [BlockId]
dests
joinToTargets_again :: (Instruction instr, FR freeRegs)
=> BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> BlockId
-> [BlockId]
-> UniqFM Reg Loc
-> UniqFM Reg Loc
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_again :: forall instr freeRegs.
(Instruction instr, FR freeRegs) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> BlockId
-> [BlockId]
-> RegMap Loc
-> RegMap Loc
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets_again
BlockMap RegSet
block_live [NatBasicBlock instr]
new_blocks BlockId
block_id instr
instr BlockId
dest [BlockId]
dests
RegMap Loc
src_assig RegMap Loc
dest_assig
| forall key elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList RegMap Loc
dest_assig forall a. Eq a => a -> a -> Bool
== forall key elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList RegMap Loc
src_assig
= forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> [BlockId]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets' BlockMap RegSet
block_live [NatBasicBlock instr]
new_blocks BlockId
block_id instr
instr [BlockId]
dests
| Bool
otherwise
= do
let graph :: [Node Loc Unique]
graph = RegMap Loc -> RegMap Loc -> [Node Loc Unique]
makeRegMovementGraph RegMap Loc
src_assig RegMap Loc
dest_assig
let sccs :: [SCC (Node Loc Unique)]
sccs = forall key payload.
Ord key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesOrdR [Node Loc Unique]
graph
Int
delta <- forall freeRegs. RegM freeRegs Int
getDeltaR
[[instr]]
fixUpInstrs_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall instr freeRegs.
Instruction instr =>
Int -> instr -> SCC (Node Loc Unique) -> RegM freeRegs [instr]
handleComponent Int
delta instr
instr) [SCC (Node Loc Unique)]
sccs
let fixUpInstrs :: [instr]
fixUpInstrs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[instr]]
fixUpInstrs_
BlockId
fixup_block_id <- Unique -> BlockId
mkBlockId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall freeRegs. RegM freeRegs Unique
getUniqueR
let block :: NatBasicBlock instr
block = forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
fixup_block_id
forall a b. (a -> b) -> a -> b
$ [instr]
fixUpInstrs forall a. [a] -> [a] -> [a]
++ forall instr. Instruction instr => BlockId -> [instr]
mkJumpInstr BlockId
dest
case [instr]
fixUpInstrs of
[] -> forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> [BlockId]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets' BlockMap RegSet
block_live [NatBasicBlock instr]
new_blocks BlockId
block_id instr
instr [BlockId]
dests
[instr]
_ -> let instr' :: instr
instr' = forall instr.
Instruction instr =>
instr -> (BlockId -> BlockId) -> instr
patchJumpInstr instr
instr
(\BlockId
bid -> if BlockId
bid forall a. Eq a => a -> a -> Bool
== BlockId
dest
then BlockId
fixup_block_id
else BlockId
bid)
in do
forall freeRegs. BlockId -> BlockId -> BlockId -> RegM freeRegs ()
recordFixupBlock BlockId
block_id BlockId
fixup_block_id BlockId
dest
forall freeRegs instr.
(FR freeRegs, Instruction instr) =>
BlockMap RegSet
-> [NatBasicBlock instr]
-> BlockId
-> instr
-> [BlockId]
-> RegM freeRegs ([NatBasicBlock instr], instr)
joinToTargets' BlockMap RegSet
block_live (NatBasicBlock instr
block forall a. a -> [a] -> [a]
: [NatBasicBlock instr]
new_blocks)
BlockId
block_id instr
instr' [BlockId]
dests
makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique]
makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique]
makeRegMovementGraph RegMap Loc
adjusted_assig RegMap Loc
dest_assig
= [ Node Loc Unique
node | (Unique
vreg, Loc
src) <- forall key elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList RegMap Loc
adjusted_assig
, Just Loc
loc <- [forall key elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly RegMap Loc
dest_assig Unique
vreg]
, Node Loc Unique
node <- forall a. a -> Loc -> Loc -> [Node Loc a]
expandNode Unique
vreg Loc
src Loc
loc ]
expandNode
:: a
-> Loc
-> Loc
-> [Node Loc a ]
expandNode :: forall a. a -> Loc -> Loc -> [Node Loc a]
expandNode a
vreg loc :: Loc
loc@(InReg RealReg
src) (InBoth RealReg
dst Int
mem)
| RealReg
src forall a. Eq a => a -> a -> Bool
== RealReg
dst = [forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode a
vreg Loc
loc [Int -> Loc
InMem Int
mem]]
| Bool
otherwise = [forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode a
vreg Loc
loc [RealReg -> Loc
InReg RealReg
dst, Int -> Loc
InMem Int
mem]]
expandNode a
vreg loc :: Loc
loc@(InMem Int
src) (InBoth RealReg
dst Int
mem)
| Int
src forall a. Eq a => a -> a -> Bool
== Int
mem = [forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode a
vreg Loc
loc [RealReg -> Loc
InReg RealReg
dst]]
| Bool
otherwise = [forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode a
vreg Loc
loc [RealReg -> Loc
InReg RealReg
dst, Int -> Loc
InMem Int
mem]]
expandNode a
_ (InBoth RealReg
_ Int
src) (InMem Int
dst)
| Int
src forall a. Eq a => a -> a -> Bool
== Int
dst = []
expandNode a
_ (InBoth RealReg
src Int
_) (InReg RealReg
dst)
| RealReg
src forall a. Eq a => a -> a -> Bool
== RealReg
dst = []
expandNode a
vreg (InBoth RealReg
src Int
_) Loc
dst
= forall a. a -> Loc -> Loc -> [Node Loc a]
expandNode a
vreg (RealReg -> Loc
InReg RealReg
src) Loc
dst
expandNode a
vreg Loc
src Loc
dst
| Loc
src forall a. Eq a => a -> a -> Bool
== Loc
dst = []
| Bool
otherwise = [forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode a
vreg Loc
src [Loc
dst]]
handleComponent
:: Instruction instr
=> Int -> instr -> SCC (Node Loc Unique)
-> RegM freeRegs [instr]
handleComponent :: forall instr freeRegs.
Instruction instr =>
Int -> instr -> SCC (Node Loc Unique) -> RegM freeRegs [instr]
handleComponent Int
delta instr
_ (AcyclicSCC (DigraphNode Unique
vreg Loc
src [Loc]
dsts))
= forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (forall instr freeRegs.
Instruction instr =>
Int -> Unique -> Loc -> Loc -> RegM freeRegs [instr]
makeMove Int
delta Unique
vreg Loc
src) [Loc]
dsts
handleComponent Int
delta instr
instr
(CyclicSCC ((DigraphNode Unique
vreg (InReg RealReg
sreg) ((InReg RealReg
dreg: [Loc]
_))) : [Node Loc Unique]
rest))
= do
([instr]
instrSpill, Int
slot)
<- forall instr freeRegs.
Instruction instr =>
Reg -> Unique -> RegM freeRegs ([instr], Int)
spillR (RealReg -> Reg
RegReal RealReg
sreg) Unique
vreg
[instr]
instrLoad <- forall instr freeRegs.
Instruction instr =>
Reg -> Int -> RegM freeRegs [instr]
loadR (RealReg -> Reg
RegReal RealReg
dreg) Int
slot
[[instr]]
remainingFixUps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall instr freeRegs.
Instruction instr =>
Int -> instr -> SCC (Node Loc Unique) -> RegM freeRegs [instr]
handleComponent Int
delta instr
instr)
(forall key payload.
Ord key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesOrdR [Node Loc Unique]
rest)
forall (m :: * -> *) a. Monad m => a -> m a
return ([instr]
instrSpill forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[instr]]
remainingFixUps forall a. [a] -> [a] -> [a]
++ [instr]
instrLoad)
handleComponent Int
_ instr
_ (CyclicSCC [Node Loc Unique]
_)
= forall a. String -> a
panic String
"Register Allocator: handleComponent cyclic"
makeMove
:: Instruction instr
=> Int
-> Unique
-> Loc
-> Loc
-> RegM freeRegs [instr]
makeMove :: forall instr freeRegs.
Instruction instr =>
Int -> Unique -> Loc -> Loc -> RegM freeRegs [instr]
makeMove Int
delta Unique
vreg Loc
src Loc
dst
= do NCGConfig
config <- forall a. RegM a NCGConfig
getConfig
let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
case (Loc
src, Loc
dst) of
(InReg RealReg
s, InReg RealReg
d) ->
do forall freeRegs. SpillReason -> RegM freeRegs ()
recordSpill (Unique -> SpillReason
SpillJoinRR Unique
vreg)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform (RealReg -> Reg
RegReal RealReg
s) (RealReg -> Reg
RegReal RealReg
d)]
(InMem Int
s, InReg RealReg
d) ->
do forall freeRegs. SpillReason -> RegM freeRegs ()
recordSpill (Unique -> SpillReason
SpillJoinRM Unique
vreg)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall instr.
Instruction instr =>
NCGConfig -> Reg -> Int -> Int -> [instr]
mkLoadInstr NCGConfig
config (RealReg -> Reg
RegReal RealReg
d) Int
delta Int
s
(InReg RealReg
s, InMem Int
d) ->
do forall freeRegs. SpillReason -> RegM freeRegs ()
recordSpill (Unique -> SpillReason
SpillJoinRM Unique
vreg)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall instr.
Instruction instr =>
NCGConfig -> Reg -> Int -> Int -> [instr]
mkSpillInstr NCGConfig
config (RealReg -> Reg
RegReal RealReg
s) Int
delta Int
d
(Loc, Loc)
_ ->
forall a. String -> a
panic (String
"makeMove " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Unique
vreg forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Loc
src forall a. [a] -> [a] -> [a]
++ String
") ("
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Loc
dst forall a. [a] -> [a] -> [a]
++ String
")"
forall a. [a] -> [a] -> [a]
++ String
" we don't handle mem->mem moves.")