module RegAlloc.Graph.SpillClean (
cleanSpills
) where
import GhcPrelude
import RegAlloc.Liveness
import Instruction
import Reg
import BlockId
import Cmm
import UniqSet
import UniqFM
import Unique
import State
import Outputable
import GHC.Platform
import Hoopl.Collections
import Data.List
import Data.Maybe
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
type Slot = Int
cleanSpills
:: Instruction instr
=> Platform
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
cleanSpills :: Platform -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
cleanSpills Platform
platform LiveCmmDecl statics instr
cmm
= State CleanS (LiveCmmDecl statics instr)
-> CleanS -> LiveCmmDecl statics instr
forall s a. State s a -> s -> a
evalState (Platform
-> Int
-> LiveCmmDecl statics instr
-> State CleanS (LiveCmmDecl statics instr)
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
cleanSpin
:: Instruction instr
=> Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin :: Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin Platform
platform Int
spinCount LiveCmmDecl statics instr
code
= do
(CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
{ sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = Int
0
, sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = Int
0
, sReloadedBy :: UniqFM [BlockId]
sReloadedBy = UniqFM [BlockId]
forall elt. UniqFM elt
emptyUFM }
LiveCmmDecl statics instr
code_forward <- (LiveBasicBlock instr -> State CleanS (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
forall (m :: * -> *) instr statics.
Monad m =>
(LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM (Platform
-> LiveBasicBlock instr -> State CleanS (LiveBasicBlock instr)
forall instr.
Instruction instr =>
Platform -> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockForward Platform
platform) LiveCmmDecl statics instr
code
LiveCmmDecl statics instr
code_backward <- LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
cleanTopBackward LiveCmmDecl statics instr
code_forward
State CleanS ()
collateJoinPoints
Int
spills <- (CleanS -> Int) -> State CleanS Int
forall s a. (s -> a) -> State s a
gets CleanS -> Int
sCleanedSpillsAcc
Int
reloads <- (CleanS -> Int) -> State CleanS Int
forall s a. (s -> a) -> State s a
gets CleanS -> Int
sCleanedReloadsAcc
(CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
{ sCleanedCount :: [(Int, Int)]
sCleanedCount = (Int
spills, Int
reloads) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
: CleanS -> [(Int, Int)]
sCleanedCount CleanS
s }
[(Int, Int)]
cleanedCount <- (CleanS -> [(Int, Int)]) -> State CleanS [(Int, Int)]
forall s a. (s -> a) -> State s a
gets CleanS -> [(Int, Int)]
sCleanedCount
if Int -> [(Int, Int)] -> [(Int, Int)]
forall a. Int -> [a] -> [a]
take Int
2 [(Int, Int)]
cleanedCount [(Int, Int)] -> [(Int, Int)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Int
0, Int
0), (Int
0, Int
0)]
then LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
return LiveCmmDecl statics instr
code
else Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
forall instr statics.
Instruction instr =>
Platform
-> Int
-> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanSpin Platform
platform (Int
spinCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) LiveCmmDecl statics instr
code_backward
cleanBlockForward
:: Instruction instr
=> Platform
-> LiveBasicBlock instr
-> CleanM (LiveBasicBlock instr)
cleanBlockForward :: Platform -> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockForward Platform
platform (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
= do
UniqFM (Assoc Store)
jumpValid <- (CleanS -> UniqFM (Assoc Store))
-> State CleanS (UniqFM (Assoc Store))
forall s a. (s -> a) -> State s a
gets CleanS -> UniqFM (Assoc Store)
sJumpValid
let assoc :: Assoc Store
assoc = case UniqFM (Assoc Store) -> BlockId -> Maybe (Assoc Store)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (Assoc Store)
jumpValid BlockId
blockId of
Just Assoc Store
assoc -> Assoc Store
assoc
Maybe (Assoc Store)
Nothing -> Assoc Store
forall a. Assoc a
emptyAssoc
[LiveInstr instr]
instrs_reload <- Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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
LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LiveBasicBlock instr -> CleanM (LiveBasicBlock instr))
-> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
forall a b. (a -> b) -> a -> b
$ BlockId -> [LiveInstr instr] -> LiveBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
blockId [LiveInstr instr]
instrs_reload
cleanForward
:: Instruction instr
=> Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward :: Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanForward Platform
_ BlockId
_ Assoc Store
_ [LiveInstr instr]
acc []
= [LiveInstr instr] -> CleanM [LiveInstr instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [LiveInstr instr]
acc
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
slot2
= do
(CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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] -> CleanM [LiveInstr instr])
-> [LiveInstr instr] -> CleanM [LiveInstr instr]
forall a b. (a -> b) -> a -> b
$ LiveInstr instr
li1 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 (Platform -> Reg -> Reg -> InstrSR instr
forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform Reg
reg1 Reg
reg2) Maybe Liveness
forall a. Maybe a
Nothing
LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
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) <- InstrSR instr -> Maybe (Reg, Reg)
forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr InstrSR instr
i1
= if Reg
r1 Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r2
then Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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
else do let assoc' :: Assoc Store
assoc' = Store -> Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> a -> Assoc a -> Assoc a
addAssoc (Reg -> Store
SReg Reg
r1) (Reg -> Store
SReg Reg
r2)
(Assoc Store -> Assoc Store) -> Assoc Store -> Assoc Store
forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> Assoc a -> Assoc a
delAssoc (Reg -> Store
SReg Reg
r2)
(Assoc Store -> Assoc Store) -> Assoc Store -> Assoc Store
forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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 LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
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)
| LiveInstr (SPILL Reg
reg Int
slot) Maybe Liveness
_ <- LiveInstr instr
li
= let assoc' :: Assoc Store
assoc' = Store -> Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> a -> Assoc a -> Assoc a
addAssoc (Reg -> Store
SReg Reg
reg) (Int -> Store
SSlot Int
slot)
(Assoc Store -> Assoc Store) -> Assoc Store -> Assoc Store
forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> Assoc a -> Assoc a
delAssoc (Int -> Store
SSlot Int
slot)
(Assoc Store -> Assoc Store) -> Assoc Store -> Assoc Store
forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
in Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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 LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| LiveInstr (RELOAD{}) Maybe Liveness
_ <- LiveInstr instr
li
= do (Assoc Store
assoc', Maybe (LiveInstr instr)
mli) <- Platform
-> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
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 -> Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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' -> Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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' LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc)
[LiveInstr instr]
instrs
| LiveInstr InstrSR instr
instr Maybe Liveness
_ <- LiveInstr instr
li
, [BlockId]
targets <- InstrSR instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
instr
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
targets
= do (BlockId -> State CleanS ()) -> [BlockId] -> State CleanS ()
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
Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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 LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| LiveInstr InstrSR instr
instr Maybe Liveness
_ <- LiveInstr instr
li
, RU [Reg]
_ [Reg]
written <- Platform -> InstrSR instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr
= let assoc' :: Assoc Store
assoc' = (Store -> Assoc Store -> Assoc Store)
-> Assoc Store -> [Store] -> Assoc Store
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> Assoc a -> Assoc a
delAssoc Assoc Store
assoc ((Reg -> Store) -> [Reg] -> [Store]
forall a b. (a -> b) -> [a] -> [b]
map Reg -> Store
SReg ([Reg] -> [Store]) -> [Reg] -> [Store]
forall a b. (a -> b) -> a -> b
$ [Reg] -> [Reg]
forall a. Eq a => [a] -> [a]
nub [Reg]
written)
in Platform
-> BlockId
-> Assoc Store
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
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 LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
cleanReload
:: Instruction instr
=> Platform
-> BlockId
-> Assoc Store
-> LiveInstr instr
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
cleanReload :: 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
_)
| Store -> Store -> Assoc Store -> Bool
forall a. Uniquable a => a -> a -> Assoc a -> Bool
elemAssoc (Int -> Store
SSlot Int
slot) (Reg -> Store
SReg Reg
reg) Assoc Store
assoc
= do (CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
(Assoc Store, Maybe (LiveInstr instr))
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Assoc Store
assoc, Maybe (LiveInstr instr)
forall a. Maybe a
Nothing)
| Just Reg
reg2 <- Assoc Store -> Int -> Maybe Reg
findRegOfSlot Assoc Store
assoc Int
slot
= do (CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = CleanS -> Int
sCleanedReloadsAcc CleanS
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
let assoc' :: Assoc Store
assoc' = Store -> Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> a -> Assoc a -> Assoc a
addAssoc (Reg -> Store
SReg Reg
reg) (Reg -> Store
SReg Reg
reg2)
(Assoc Store -> Assoc Store) -> Assoc Store -> Assoc Store
forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> Assoc a -> Assoc a
delAssoc (Reg -> Store
SReg Reg
reg)
(Assoc Store -> Assoc Store) -> Assoc Store -> Assoc Store
forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
(Assoc Store, Maybe (LiveInstr instr))
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
forall (m :: * -> *) a. Monad m => a -> m a
return ( Assoc Store
assoc'
, LiveInstr instr -> Maybe (LiveInstr instr)
forall a. a -> Maybe a
Just (LiveInstr instr -> Maybe (LiveInstr instr))
-> LiveInstr instr -> Maybe (LiveInstr instr)
forall a b. (a -> b) -> a -> b
$ InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (Platform -> Reg -> Reg -> InstrSR instr
forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform Reg
reg2 Reg
reg) Maybe Liveness
forall a. Maybe a
Nothing)
| Bool
otherwise
= do
let assoc' :: Assoc Store
assoc'
= Store -> Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> a -> Assoc a -> Assoc a
addAssoc (Reg -> Store
SReg Reg
reg) (Int -> Store
SSlot Int
slot)
(Assoc Store -> Assoc Store) -> Assoc Store -> Assoc Store
forall a b. (a -> b) -> a -> b
$ Store -> Assoc Store -> Assoc Store
forall a. Uniquable a => a -> Assoc a -> Assoc a
delAssoc (Reg -> Store
SReg Reg
reg)
(Assoc Store -> Assoc Store) -> Assoc Store -> Assoc Store
forall a b. (a -> b) -> a -> b
$ Assoc Store
assoc
BlockId -> Int -> State CleanS ()
accBlockReloadsSlot BlockId
blockId Int
slot
(Assoc Store, Maybe (LiveInstr instr))
-> CleanM (Assoc Store, Maybe (LiveInstr instr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Assoc Store
assoc', LiveInstr instr -> Maybe (LiveInstr instr)
forall a. a -> Maybe a
Just LiveInstr instr
li)
cleanReload Platform
_ BlockId
_ Assoc Store
_ LiveInstr instr
_
= String -> CleanM (Assoc Store, Maybe (LiveInstr instr))
forall a. String -> a
panic String
"RegSpillClean.cleanReload: unhandled instr"
cleanTopBackward
:: Instruction instr
=> LiveCmmDecl statics instr
-> CleanM (LiveCmmDecl statics instr)
cleanTopBackward :: LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
cleanTopBackward LiveCmmDecl statics instr
cmm
= case LiveCmmDecl statics instr
cmm of
CmmData{}
-> LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
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 CmmStatics
_ [BlockId]
_ BlockMap RegSet
_ BlockMap IntSet
liveSlotsOnEntry <- LiveInfo
info
-> do [SCC (LiveBasicBlock instr)]
sccs' <- (SCC (LiveBasicBlock instr)
-> State CleanS (SCC (LiveBasicBlock instr)))
-> [SCC (LiveBasicBlock instr)]
-> State CleanS [SCC (LiveBasicBlock instr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((LiveBasicBlock instr -> State CleanS (LiveBasicBlock instr))
-> SCC (LiveBasicBlock instr)
-> State CleanS (SCC (LiveBasicBlock instr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SCC a -> m (SCC b)
mapSCCM (BlockMap IntSet
-> LiveBasicBlock instr -> State CleanS (LiveBasicBlock instr)
forall instr.
Instruction instr =>
BlockMap IntSet
-> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockBackward BlockMap IntSet
liveSlotsOnEntry)) [SCC (LiveBasicBlock instr)]
sccs
LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LiveCmmDecl statics instr -> CleanM (LiveCmmDecl statics instr))
-> LiveCmmDecl statics instr -> CleanM (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'
cleanBlockBackward
:: Instruction instr
=> BlockMap IntSet
-> LiveBasicBlock instr
-> CleanM (LiveBasicBlock instr)
cleanBlockBackward :: BlockMap IntSet
-> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
cleanBlockBackward BlockMap IntSet
liveSlotsOnEntry (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
= do [LiveInstr instr]
instrs_spill <- BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward BlockMap IntSet
liveSlotsOnEntry UniqSet Int
forall a. UniqSet a
emptyUniqSet [] [LiveInstr instr]
instrs
LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LiveBasicBlock instr -> CleanM (LiveBasicBlock instr))
-> LiveBasicBlock instr -> CleanM (LiveBasicBlock instr)
forall a b. (a -> b) -> a -> b
$ BlockId -> [LiveInstr instr] -> LiveBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
blockId [LiveInstr instr]
instrs_spill
cleanBackward
:: Instruction instr
=> BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
cleanBackward :: 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 [BlockId]
reloadedBy <- (CleanS -> UniqFM [BlockId]) -> State CleanS (UniqFM [BlockId])
forall s a. (s -> a) -> State s a
gets CleanS -> UniqFM [BlockId]
sReloadedBy
BlockMap IntSet
-> UniqFM [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> CleanM [LiveInstr instr]
forall instr.
Instruction instr =>
BlockMap IntSet
-> UniqFM [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
cleanBackward' BlockMap IntSet
liveSlotsOnEntry UniqFM [BlockId]
reloadedBy UniqSet Int
noReloads [LiveInstr instr]
acc [LiveInstr instr]
lis
cleanBackward'
:: Instruction instr
=> BlockMap IntSet
-> UniqFM [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
cleanBackward' :: BlockMap IntSet
-> UniqFM [BlockId]
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
cleanBackward' BlockMap IntSet
_ UniqFM [BlockId]
_ UniqSet Int
_ [LiveInstr instr]
acc []
= [LiveInstr instr] -> State CleanS [LiveInstr instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [LiveInstr instr]
acc
cleanBackward' BlockMap IntSet
liveSlotsOnEntry UniqFM [BlockId]
reloadedBy UniqSet Int
noReloads [LiveInstr instr]
acc (LiveInstr instr
li : [LiveInstr instr]
instrs)
| LiveInstr (SPILL Reg
_ Int
slot) Maybe Liveness
_ <- LiveInstr instr
li
, Maybe [BlockId]
Nothing <- UniqFM [BlockId] -> Store -> Maybe [BlockId]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [BlockId]
reloadedBy (Int -> Store
SSlot Int
slot)
= do (CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = CleanS -> Int
sCleanedSpillsAcc CleanS
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
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 Int -> UniqSet Int -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Int
slot UniqSet Int
noReloads
then do
(CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s { sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = CleanS -> Int
sCleanedSpillsAcc CleanS
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
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
let noReloads' :: UniqSet Int
noReloads' = UniqSet Int -> Int -> UniqSet Int
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet Int
noReloads Int
slot
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
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 LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| LiveInstr (RELOAD Int
slot Reg
_) Maybe Liveness
_ <- LiveInstr instr
li
, UniqSet Int
noReloads' <- UniqSet Int -> Int -> UniqSet Int
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet Int
noReloads Int
slot
= BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
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 LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| LiveInstr InstrSR instr
instr Maybe Liveness
_ <- LiveInstr instr
li
, [BlockId]
targets <- InstrSR instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
instr
= do
let slotsReloadedByTargets :: IntSet
slotsReloadedByTargets
= [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions
([IntSet] -> IntSet) -> [IntSet] -> IntSet
forall a b. (a -> b) -> a -> b
$ [Maybe IntSet] -> [IntSet]
forall a. [Maybe a] -> [a]
catMaybes
([Maybe IntSet] -> [IntSet]) -> [Maybe IntSet] -> [IntSet]
forall a b. (a -> b) -> a -> b
$ (BlockId -> Maybe IntSet) -> [BlockId] -> [Maybe IntSet]
forall a b. (a -> b) -> [a] -> [b]
map ((BlockId -> BlockMap IntSet -> Maybe IntSet)
-> BlockMap IntSet -> BlockId -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip BlockId -> BlockMap IntSet -> Maybe IntSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockMap IntSet
liveSlotsOnEntry)
([BlockId] -> [Maybe IntSet]) -> [BlockId] -> [Maybe IntSet]
forall a b. (a -> b) -> a -> b
$ [BlockId]
targets
let noReloads' :: UniqSet Int
noReloads'
= (UniqSet Int -> Int -> UniqSet Int)
-> UniqSet Int -> [Int] -> UniqSet Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqSet Int -> Int -> UniqSet Int
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet Int
noReloads
([Int] -> UniqSet Int) -> [Int] -> UniqSet Int
forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IntSet.toList IntSet
slotsReloadedByTargets
BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
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 LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
| Bool
otherwise
= BlockMap IntSet
-> UniqSet Int
-> [LiveInstr instr]
-> [LiveInstr instr]
-> State CleanS [LiveInstr instr]
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 LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
collateJoinPoints :: CleanM ()
collateJoinPoints :: State CleanS ()
collateJoinPoints
= (CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s
{ sJumpValid :: UniqFM (Assoc Store)
sJumpValid = ([Assoc Store] -> Assoc Store)
-> UniqFM [Assoc Store] -> UniqFM (Assoc Store)
forall elt1 elt2. (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
mapUFM [Assoc Store] -> Assoc Store
intersects (CleanS -> UniqFM [Assoc Store]
sJumpValidAcc CleanS
s)
, sJumpValidAcc :: UniqFM [Assoc Store]
sJumpValidAcc = UniqFM [Assoc Store]
forall elt. UniqFM elt
emptyUFM }
intersects :: [Assoc Store] -> Assoc Store
intersects :: [Assoc Store] -> Assoc Store
intersects [] = Assoc Store
forall a. Assoc a
emptyAssoc
intersects [Assoc Store]
assocs = (Assoc Store -> Assoc Store -> Assoc Store)
-> [Assoc Store] -> Assoc Store
forall a. (a -> a -> a) -> [a] -> a
foldl1' Assoc Store -> Assoc Store -> Assoc Store
forall a. Assoc a -> Assoc a -> Assoc a
intersectAssoc [Assoc Store]
assocs
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
forall a. Uniquable a => a -> Assoc a -> UniqSet a
closeAssoc (Int -> Store
SSlot Int
slot) Assoc Store
assoc
, Just (SReg Reg
reg) <- (Store -> Bool) -> [Store] -> Maybe Store
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Store -> Bool
isStoreReg ([Store] -> Maybe Store) -> [Store] -> Maybe Store
forall a b. (a -> b) -> a -> b
$ UniqSet Store -> [Store]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Store
close
= Reg -> Maybe Reg
forall a. a -> Maybe a
Just Reg
reg
| Bool
otherwise
= Maybe Reg
forall a. Maybe a
Nothing
type CleanM
= State CleanS
data CleanS
= CleanS
{
CleanS -> UniqFM (Assoc Store)
sJumpValid :: UniqFM (Assoc Store)
, CleanS -> UniqFM [Assoc Store]
sJumpValidAcc :: UniqFM [Assoc Store]
, CleanS -> UniqFM [BlockId]
sReloadedBy :: UniqFM [BlockId]
, CleanS -> [(Int, Int)]
sCleanedCount :: [(Int, Int)]
, CleanS -> Int
sCleanedSpillsAcc :: Int
, CleanS -> Int
sCleanedReloadsAcc :: Int }
initCleanS :: CleanS
initCleanS :: CleanS
initCleanS
= CleanS :: UniqFM (Assoc Store)
-> UniqFM [Assoc Store]
-> UniqFM [BlockId]
-> [(Int, Int)]
-> Int
-> Int
-> CleanS
CleanS
{ sJumpValid :: UniqFM (Assoc Store)
sJumpValid = UniqFM (Assoc Store)
forall elt. UniqFM elt
emptyUFM
, sJumpValidAcc :: UniqFM [Assoc Store]
sJumpValidAcc = UniqFM [Assoc Store]
forall elt. UniqFM elt
emptyUFM
, sReloadedBy :: UniqFM [BlockId]
sReloadedBy = UniqFM [BlockId]
forall elt. UniqFM elt
emptyUFM
, sCleanedCount :: [(Int, Int)]
sCleanedCount = []
, sCleanedSpillsAcc :: Int
sCleanedSpillsAcc = Int
0
, sCleanedReloadsAcc :: Int
sCleanedReloadsAcc = Int
0 }
accJumpValid :: Assoc Store -> BlockId -> CleanM ()
accJumpValid :: Assoc Store -> BlockId -> State CleanS ()
accJumpValid Assoc Store
assocs BlockId
target
= (CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s {
sJumpValidAcc :: UniqFM [Assoc Store]
sJumpValidAcc = ([Assoc Store] -> [Assoc Store] -> [Assoc Store])
-> UniqFM [Assoc Store]
-> BlockId
-> [Assoc Store]
-> UniqFM [Assoc Store]
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
addToUFM_C [Assoc Store] -> [Assoc Store] -> [Assoc Store]
forall a. [a] -> [a] -> [a]
(++)
(CleanS -> UniqFM [Assoc Store]
sJumpValidAcc CleanS
s)
BlockId
target
[Assoc Store
assocs] }
accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
accBlockReloadsSlot :: BlockId -> Int -> State CleanS ()
accBlockReloadsSlot BlockId
blockId Int
slot
= (CleanS -> CleanS) -> State CleanS ()
forall s. (s -> s) -> State s ()
modify ((CleanS -> CleanS) -> State CleanS ())
-> (CleanS -> CleanS) -> State CleanS ()
forall a b. (a -> b) -> a -> b
$ \CleanS
s -> CleanS
s {
sReloadedBy :: UniqFM [BlockId]
sReloadedBy = ([BlockId] -> [BlockId] -> [BlockId])
-> UniqFM [BlockId] -> Store -> [BlockId] -> UniqFM [BlockId]
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
addToUFM_C [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
(++)
(CleanS -> UniqFM [BlockId]
sReloadedBy CleanS
s)
(Int -> Store
SSlot Int
slot)
[BlockId
blockId] }
data Store
= SSlot Int
| SReg Reg
isStoreReg :: Store -> Bool
isStoreReg :: Store -> Bool
isStoreReg Store
ss
= case Store
ss of
SSlot Int
_ -> Bool
False
SReg Reg
_ -> Bool
True
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
65535 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r2)
| Bool
otherwise
= String -> Unique
forall a. HasCallStack => String -> a
error (String -> Unique) -> String -> Unique
forall a b. (a -> b) -> a -> b
$ String
"RegSpillClean.getUnique: found virtual reg during spill clean,"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"only real regs expected."
getUnique (SSlot Int
i) = Int -> Unique
mkRegSubUnique Int
i
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) = Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r
type Assoc a = UniqFM (UniqSet a)
emptyAssoc :: Assoc a
emptyAssoc :: Assoc a
emptyAssoc = Assoc a
forall elt. UniqFM elt
emptyUFM
addAssoc :: Uniquable a
=> a -> a -> Assoc a -> Assoc a
addAssoc :: a -> a -> Assoc a -> Assoc a
addAssoc a
a a
b Assoc a
m
= let m1 :: Assoc a
m1 = (UniqSet a -> UniqSet a -> UniqSet a)
-> Assoc a -> a -> UniqSet a -> Assoc a
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
addToUFM_C UniqSet a -> UniqSet a -> UniqSet a
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets Assoc a
m a
a (a -> UniqSet a
forall a. Uniquable a => a -> UniqSet a
unitUniqSet a
b)
m2 :: Assoc a
m2 = (UniqSet a -> UniqSet a -> UniqSet a)
-> Assoc a -> a -> UniqSet a -> Assoc a
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
addToUFM_C UniqSet a -> UniqSet a -> UniqSet a
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets Assoc a
m1 a
b (a -> UniqSet a
forall a. Uniquable a => a -> UniqSet a
unitUniqSet a
a)
in Assoc a
m2
delAssoc :: (Uniquable a)
=> a -> Assoc a -> Assoc a
delAssoc :: a -> Assoc a -> Assoc a
delAssoc a
a Assoc a
m
| Just UniqSet a
aSet <- Assoc a -> a -> Maybe (UniqSet a)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM Assoc a
m a
a
, Assoc a
m1 <- Assoc a -> a -> Assoc a
forall key elt. Uniquable key => UniqFM elt -> key -> UniqFM elt
delFromUFM Assoc a
m a
a
= (a -> Assoc a -> Assoc a) -> Assoc a -> UniqSet a -> Assoc a
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetFoldUniqSet (\a
x Assoc a
m -> a -> a -> Assoc a -> Assoc a
forall a. Uniquable a => a -> a -> Assoc a -> Assoc a
delAssoc1 a
x a
a Assoc a
m) Assoc a
m1 UniqSet a
aSet
| Bool
otherwise = Assoc a
m
delAssoc1 :: Uniquable a
=> a -> a -> Assoc a -> Assoc a
delAssoc1 :: a -> a -> Assoc a -> Assoc a
delAssoc1 a
a a
b Assoc a
m
| Just UniqSet a
aSet <- Assoc a -> a -> Maybe (UniqSet a)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM Assoc a
m a
a
= Assoc a -> a -> UniqSet a -> Assoc a
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM Assoc a
m a
a (UniqSet a -> a -> UniqSet a
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet a
aSet a
b)
| Bool
otherwise = Assoc a
m
elemAssoc :: (Uniquable a)
=> a -> a -> Assoc a -> Bool
elemAssoc :: a -> a -> Assoc a -> Bool
elemAssoc a
a a
b Assoc a
m
= a -> UniqSet a -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet a
b (a -> Assoc a -> UniqSet a
forall a. Uniquable a => a -> Assoc a -> UniqSet a
closeAssoc a
a Assoc a
m)
closeAssoc :: (Uniquable a)
=> a -> Assoc a -> UniqSet a
closeAssoc :: a -> Assoc a -> UniqSet a
closeAssoc a
a Assoc a
assoc
= Assoc a -> UniqSet a -> UniqSet a -> UniqSet a
forall a.
Uniquable a =>
UniqFM (UniqSet a) -> UniqSet a -> UniqSet a -> UniqSet a
closeAssoc' Assoc a
assoc UniqSet a
forall a. UniqSet a
emptyUniqSet (a -> UniqSet a
forall a. Uniquable a => a -> UniqSet a
unitUniqSet a
a)
where
closeAssoc' :: UniqFM (UniqSet a) -> UniqSet a -> UniqSet a -> UniqSet a
closeAssoc' UniqFM (UniqSet a)
assoc UniqSet a
visited UniqSet a
toVisit
= case UniqSet a -> [a]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet a
toVisit of
[] -> UniqSet a
visited
(a
x:[a]
_)
| a -> UniqSet a -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet a
x UniqSet a
visited
-> UniqFM (UniqSet a) -> UniqSet a -> UniqSet a -> UniqSet a
closeAssoc' UniqFM (UniqSet a)
assoc UniqSet a
visited (UniqSet a -> a -> UniqSet a
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet a
toVisit a
x)
| Bool
otherwise
-> let neighbors :: UniqSet a
neighbors
= case UniqFM (UniqSet a) -> a -> Maybe (UniqSet a)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (UniqSet a)
assoc a
x of
Maybe (UniqSet a)
Nothing -> UniqSet a
forall a. UniqSet a
emptyUniqSet
Just UniqSet a
set -> UniqSet a
set
in UniqFM (UniqSet a) -> UniqSet a -> UniqSet a -> UniqSet a
closeAssoc' UniqFM (UniqSet a)
assoc
(UniqSet a -> a -> UniqSet a
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet a
visited a
x)
(UniqSet a -> UniqSet a -> UniqSet a
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet a
toVisit UniqSet a
neighbors)
intersectAssoc :: Assoc a -> Assoc a -> Assoc a
intersectAssoc :: Assoc a -> Assoc a -> Assoc a
intersectAssoc Assoc a
a Assoc a
b
= (UniqSet a -> UniqSet a -> UniqSet a)
-> Assoc a -> Assoc a -> Assoc a
forall elt1 elt2 elt3.
(elt1 -> elt2 -> elt3) -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
intersectUFM_C (UniqSet a -> UniqSet a -> UniqSet a
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets) Assoc a
a Assoc a
b