module RegAlloc.Graph.Coalesce (
regCoalesce,
slurpJoinMovs
)
where
import RegAlloc.Liveness
import Instruction
import Reg
import Cmm
import Bag
import UniqFM
import UniqSet
import UniqSupply
import Data.List
regCoalesce
:: Instruction instr
=> [LiveCmmTop instr]
-> UniqSM [LiveCmmTop instr]
regCoalesce code
= do
let joins = foldl' unionBags emptyBag
$ map slurpJoinMovs code
let alloc = foldl' buildAlloc emptyUFM
$ bagToList joins
let patched = map (patchEraseLive (sinkReg alloc)) code
return patched
buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
buildAlloc fm (r1, r2)
= let rmin = min r1 r2
rmax = max r1 r2
in addToUFM fm rmax rmin
sinkReg :: UniqFM Reg -> Reg -> Reg
sinkReg fm r
= case lookupUFM fm r of
Nothing -> r
Just r' -> sinkReg fm r'
slurpJoinMovs
:: Instruction instr
=> LiveCmmTop instr
-> Bag (Reg, Reg)
slurpJoinMovs live
= slurpCmm emptyBag live
where
slurpCmm rs CmmData{} = rs
slurpCmm rs (CmmProc _ _ _ (ListGraph blocks)) = foldl' slurpComp rs blocks
slurpComp rs (BasicBlock _ blocks) = foldl' slurpBlock rs blocks
slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs
slurpLI rs (Instr _ Nothing) = rs
slurpLI rs (Instr instr (Just live))
| Just (r1, r2) <- takeRegRegMoveInstr instr
, elementOfUniqSet r1 $ liveDieRead live
, elementOfUniqSet r2 $ liveBorn live
, isVirtualReg r1 && isVirtualReg r2
= consBag (r1, r2) rs
| otherwise
= rs
slurpLI rs SPILL{} = rs
slurpLI rs RELOAD{} = rs