Commit 5a10dc1b authored by simonmar's avatar simonmar
Browse files

[project @ 2005-04-11 13:51:45 by simonmar]

Fix register allocation bug: at a branch destination we weren't
setting the free register set correctly.  This may have resulted in
poor code in some cases; worst case it causes a Prelude.head: empty list.
parent a6f9b43a
...@@ -636,7 +636,8 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do ...@@ -636,7 +636,8 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
| (temp, InReg reg) <- ufmToList assig, | (temp, InReg reg) <- ufmToList assig,
temp `notElem` keep', regClass (RealReg reg) == regClass r ] temp `notElem` keep', regClass (RealReg reg) == regClass r ]
-- in -- in
ASSERT2(not (null candidates1 && null candidates2), ppr assig) do ASSERT2(not (null candidates1 && null candidates2),
text (show freeregs) <+> ppr r <+> ppr assig) do
case candidates1 of case candidates1 of
...@@ -656,7 +657,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do ...@@ -656,7 +657,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
-- resides in a register. -- resides in a register.
[] -> do [] -> do
let let
(temp_to_push_out, my_reg) = head candidates2 (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
-- TODO: plenty of room for optimisation in choosing which temp -- TODO: plenty of room for optimisation in choosing which temp
-- to spill. We just pick the first one that isn't used in -- to spill. We just pick the first one that isn't used in
-- the current instruction for now. -- the current instruction for now.
...@@ -678,6 +679,9 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do ...@@ -678,6 +679,9 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
do_load _ _ _ spills = do_load _ _ _ spills =
return spills return spills
myHead s [] = panic s
myHead s (x:xs) = x
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Joining a jump instruction to its targets -- Joining a jump instruction to its targets
...@@ -703,18 +707,28 @@ joinToTargets block_live new_blocks instr (dest:dests) = do ...@@ -703,18 +707,28 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
let let
-- adjust the assignment to remove any registers which are not -- adjust the assignment to remove any registers which are not
-- live on entry to the destination block. -- live on entry to the destination block.
adjusted_assig = adjusted_assig = filterUFM_Directly still_live assig
listToUFM [ (reg,loc) | reg <- live, still_live uniq _ = uniq `elemUniqSet_Directly` live_set
Just loc <- [lookupUFM assig reg] ]
-- and free up those registers which are now free.
to_free =
[ r | (reg, loc) <- ufmToList assig,
not (elemUniqSet_Directly reg live_set),
r <- regsOfLoc loc ]
regsOfLoc (InReg r) = [r]
regsOfLoc (InBoth r _) = [r]
regsOfLoc (InMem _) = []
-- in -- in
case lookupUFM block_assig dest of case lookupUFM block_assig dest of
-- Nothing <=> this is the first time we jumped to this -- Nothing <=> this is the first time we jumped to this
-- block. -- block.
Nothing -> do Nothing -> do
freeregs <- getFreeRegsR freeregs <- getFreeRegsR
let freeregs' = foldr releaseReg freeregs to_free
stack <- getStackR stack <- getStackR
setBlockAssigR (addToUFM block_assig dest setBlockAssigR (addToUFM block_assig dest
(freeregs,stack,adjusted_assig)) (freeregs',stack,adjusted_assig))
joinToTargets block_live new_blocks instr dests joinToTargets block_live new_blocks instr dests
Just (freeregs,stack,dest_assig) Just (freeregs,stack,dest_assig)
...@@ -725,7 +739,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do ...@@ -725,7 +739,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
-> -- need fixup code -> -- need fixup code
panic "joinToTargets: ToDo: need fixup code" panic "joinToTargets: ToDo: need fixup code"
where where
live = uniqSetToList (lookItUp "joinToTargets" block_live dest) live_set = lookItUp "joinToTargets" block_live dest
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- The register allocator's monad. -- The register allocator's monad.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment