projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix Trac #959: a long-standing bug in instantiating otherwise-unbound type variables
[ghc-hetmet.git]
/
compiler
/
nativeGen
/
RegAlloc
/
Linear
/
JoinToTargets.hs
diff --git
a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index
5c63346
..
8ff06eb
100644
(file)
--- a/
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@
-18,14
+18,12
@@
where
import RegAlloc.Linear.State
import RegAlloc.Linear.Base
import RegAlloc.Linear.FreeRegs
import RegAlloc.Linear.State
import RegAlloc.Linear.Base
import RegAlloc.Linear.FreeRegs
+import RegAlloc.Liveness
+import Instruction
+import Reg
import BlockId
import BlockId
-import Instrs
-import Regs
-import RegAllocInfo
-import RegLiveness
import Cmm hiding (RegSet)
import Cmm hiding (RegSet)
-
import Digraph
import Outputable
import Unique
import Digraph
import Outputable
import Unique
@@
-37,39
+35,41
@@
import UniqSet
-- vregs are in the correct regs for its destination.
--
joinToTargets
-- vregs are in the correct regs for its destination.
--
joinToTargets
- :: BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
+ :: Instruction instr
+ => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
-- that are known to be live on the entry to each block.
-> BlockId -- ^ id of the current block
-- that are known to be live on the entry to each block.
-> BlockId -- ^ id of the current block
- -> Instr -- ^ branch instr on the end of the source block.
+ -> instr -- ^ branch instr on the end of the source block.
- -> RegM ([NatBasicBlock] -- fresh blocks of fixup code.
- , Instr) -- the original branch instruction, but maybe patched to jump
+ -> RegM ([NatBasicBlock instr] -- fresh blocks of fixup code.
+ , instr) -- the original branch instruction, but maybe patched to jump
-- to a fixup block first.
joinToTargets block_live id instr
-- we only need to worry about jump instructions.
-- to a fixup block first.
joinToTargets block_live id instr
-- we only need to worry about jump instructions.
- | not $ isJumpish instr
+ | not $ isJumpishInstr instr
= return ([], instr)
| otherwise
= return ([], instr)
| otherwise
- = joinToTargets' block_live [] id instr (jumpDests instr [])
+ = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)
-----
joinToTargets'
-----
joinToTargets'
- :: BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
+ :: Instruction instr
+ => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs
-- that are known to be live on the entry to each block.
-- that are known to be live on the entry to each block.
- -> [NatBasicBlock] -- ^ acc blocks of fixup code.
+ -> [NatBasicBlock instr] -- ^ acc blocks of fixup code.
-> BlockId -- ^ id of the current block
-> BlockId -- ^ id of the current block
- -> Instr -- ^ branch instr on the end of the source block.
+ -> instr -- ^ branch instr on the end of the source block.
-> [BlockId] -- ^ branch destinations still to consider.
-> [BlockId] -- ^ branch destinations still to consider.
- -> RegM ( [NatBasicBlock]
- , Instr)
+ -> RegM ( [NatBasicBlock instr]
+ , instr)
-- no more targets to consider. all done.
joinToTargets' _ new_blocks _ instr []
-- no more targets to consider. all done.
joinToTargets' _ new_blocks _ instr []
@@
-110,7
+110,8
@@
joinToTargets' block_live new_blocks block_id instr (dest:dests)
-- this is the first time we jumped to this block.
joinToTargets_first block_live new_blocks block_id instr dest dests
-- this is the first time we jumped to this block.
joinToTargets_first block_live new_blocks block_id instr dest dests
- block_assig src_assig to_free
+ block_assig src_assig
+ (to_free :: [RealReg])
= do -- free up the regs that are not live on entry to this block.
freeregs <- getFreeRegsR
= do -- free up the regs that are not live on entry to this block.
freeregs <- getFreeRegsR
@@
-152,8
+153,8
@@
joinToTargets_again
--
let sccs = stronglyConnCompFromEdgedVerticesR graph
--
let sccs = stronglyConnCompFromEdgedVerticesR graph
- -- debugging
-{- pprTrace
+{- -- debugging
+ pprTrace
("joinToTargets: making fixup code")
(vcat [ text " in block: " <> ppr block_id
, text " jmp instruction: " <> ppr instr
("joinToTargets: making fixup code")
(vcat [ text " in block: " <> ppr block_id
, text " jmp instruction: " <> ppr instr
@@
-173,7
+174,7
@@
joinToTargets_again
-- then that will jump to our original destination.
fixup_block_id <- getUniqueR
let block = BasicBlock (BlockId fixup_block_id)
-- then that will jump to our original destination.
fixup_block_id <- getUniqueR
let block = BasicBlock (BlockId fixup_block_id)
- $ fixUpInstrs ++ mkBranchInstr dest
+ $ fixUpInstrs ++ mkJumpInstr dest
{- pprTrace
("joinToTargets: fixup code is:")
{- pprTrace
("joinToTargets: fixup code is:")
@@
-187,7
+188,11
@@
joinToTargets_again
-- patch the original branch instruction so it goes to our
-- fixup block instead.
-- patch the original branch instruction so it goes to our
-- fixup block instead.
- _ -> let instr' = patchJump instr dest (BlockId fixup_block_id)
+ _ -> let instr' = patchJumpInstr instr
+ (\bid -> if bid == dest
+ then BlockId fixup_block_id
+ else dest)
+
in joinToTargets' block_live (block : new_blocks) block_id instr' dests
in joinToTargets' block_live (block : new_blocks) block_id instr' dests
@@
-256,7
+261,9
@@
expandNode vreg src dst
-- destinations. We have eliminated any possibility of single-node
-- cycles in expandNode above.
--
-- destinations. We have eliminated any possibility of single-node
-- cycles in expandNode above.
--
-handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr]
+handleComponent
+ :: Instruction instr
+ => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM [instr]
-- If the graph is acyclic then we won't get the swapping problem below.
-- In this case we can just do the moves directly, and avoid having to
-- If the graph is acyclic then we won't get the swapping problem below.
-- In this case we can just do the moves directly, and avoid having to
@@
-286,10
+293,10
@@
handleComponent delta instr
= do
-- spill the source into its slot
(instrSpill, slot)
= do
-- spill the source into its slot
(instrSpill, slot)
- <- spillR (RealReg sreg) vreg
+ <- spillR (RegReal sreg) vreg
-- reload into destination reg
-- reload into destination reg
- instrLoad <- loadR (RealReg dreg) slot
+ instrLoad <- loadR (RegReal dreg) slot
remainingFixUps <- mapM (handleComponent delta instr)
(stronglyConnCompFromEdgedVerticesR rest)
remainingFixUps <- mapM (handleComponent delta instr)
(stronglyConnCompFromEdgedVerticesR rest)
@@
-305,23
+312,24
@@
handleComponent _ _ (CyclicSCC _)
-- | Move a vreg between these two locations.
--
makeMove
-- | Move a vreg between these two locations.
--
makeMove
- :: Int -- ^ current C stack delta.
+ :: Instruction instr
+ => Int -- ^ current C stack delta.
-> Unique -- ^ unique of the vreg that we're moving.
-> Loc -- ^ source location.
-> Loc -- ^ destination location.
-> Unique -- ^ unique of the vreg that we're moving.
-> Loc -- ^ source location.
-> Loc -- ^ destination location.
- -> RegM Instr -- ^ move instruction.
+ -> RegM instr -- ^ move instruction.
makeMove _ vreg (InReg src) (InReg dst)
= do recordSpill (SpillJoinRR vreg)
makeMove _ vreg (InReg src) (InReg dst)
= do recordSpill (SpillJoinRR vreg)
- return $ mkRegRegMoveInstr (RealReg src) (RealReg dst)
+ return $ mkRegRegMoveInstr (RegReal src) (RegReal dst)
makeMove delta vreg (InMem src) (InReg dst)
= do recordSpill (SpillJoinRM vreg)
makeMove delta vreg (InMem src) (InReg dst)
= do recordSpill (SpillJoinRM vreg)
- return $ mkLoadInstr (RealReg dst) delta src
+ return $ mkLoadInstr (RegReal dst) delta src
makeMove delta vreg (InReg src) (InMem dst)
= do recordSpill (SpillJoinRM vreg)
makeMove delta vreg (InReg src) (InMem dst)
= do recordSpill (SpillJoinRM vreg)
- return $ mkSpillInstr (RealReg src) delta dst
+ return $ mkSpillInstr (RegReal src) delta dst
-- we don't handle memory to memory moves.
-- they shouldn't happen because we don't share stack slots between vregs.
-- we don't handle memory to memory moves.
-- they shouldn't happen because we don't share stack slots between vregs.