diff options
Diffstat (limited to 'compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs')
| -rw-r--r-- | compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs | 100 |
1 files changed, 53 insertions, 47 deletions
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index e6a078a05e..ba07e61871 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -24,6 +24,7 @@ import BlockId import OldCmm hiding (RegSet) import Digraph import Outputable +import Platform import Unique import UniqFM import UniqSet @@ -34,7 +35,8 @@ import UniqSet -- joinToTargets :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + => Platform + -> 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 @@ -44,19 +46,20 @@ joinToTargets , instr) -- the original branch instruction, but maybe patched to jump -- to a fixup block first. -joinToTargets block_live id instr +joinToTargets platform block_live id instr -- we only need to worry about jump instructions. | not $ isJumpishInstr instr = return ([], instr) | otherwise - = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) + = joinToTargets' platform block_live [] id instr (jumpDestsOfInstr instr) ----- joinToTargets' :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + => Platform + -> 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. -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. @@ -70,11 +73,11 @@ joinToTargets' , instr) -- no more targets to consider. all done. -joinToTargets' _ new_blocks _ instr [] +joinToTargets' _ _ new_blocks _ instr [] = return (new_blocks, instr) -- handle a branch target. -joinToTargets' block_live new_blocks block_id instr (dest:dests) +joinToTargets' platform block_live new_blocks block_id instr (dest:dests) = do -- get the map of where the vregs are stored on entry to each basic block. block_assig <- getBlockAssigR @@ -97,18 +100,19 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) case mapLookup dest block_assig of Nothing -> joinToTargets_first - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests block_assig adjusted_assig to_free Just (_, dest_assig) -> joinToTargets_again - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests adjusted_assig dest_assig -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr) - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -118,7 +122,7 @@ joinToTargets_first :: (FR freeRegs, Instruction instr) -> RegMap Loc -> [RealReg] -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_first block_live new_blocks block_id instr dest dests +joinToTargets_first platform block_live new_blocks block_id instr dest dests block_assig src_assig to_free @@ -129,12 +133,13 @@ joinToTargets_first block_live new_blocks block_id instr dest dests -- remember the current assignment on entry to this block. setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) - joinToTargets' block_live new_blocks block_id instr dests + joinToTargets' platform block_live new_blocks block_id instr dests -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs) - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -143,13 +148,13 @@ joinToTargets_again :: (Instruction instr, FR freeRegs) -> UniqFM Loc -> UniqFM Loc -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_again - block_live new_blocks block_id instr dest dests - src_assig dest_assig +joinToTargets_again + platform block_live new_blocks block_id instr dest dests + src_assig dest_assig -- the assignments already match, no problem. | ufmToList dest_assig == ufmToList src_assig - = joinToTargets' block_live new_blocks block_id instr dests + = joinToTargets' platform block_live new_blocks block_id instr dests -- assignments don't match, need fixup code | otherwise @@ -184,7 +189,7 @@ joinToTargets_again (return ()) -} delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + fixUpInstrs_ <- mapM (handleComponent platform delta instr) sccs let fixUpInstrs = concat fixUpInstrs_ -- make a new basic block containing the fixup code. @@ -202,7 +207,7 @@ joinToTargets_again -} -- if we didn't need any fixups, then don't include the block case fixUpInstrs of - [] -> joinToTargets' block_live new_blocks block_id instr dests + [] -> joinToTargets' platform block_live new_blocks block_id instr dests -- patch the original branch instruction so it goes to our -- fixup block instead. @@ -211,7 +216,7 @@ joinToTargets_again then mkBlockId fixup_block_id else bid) -- no change! - in joinToTargets' block_live (block : new_blocks) block_id instr' dests + in joinToTargets' platform block_live (block : new_blocks) block_id instr' dests -- | Construct a graph of register\/spill movements. @@ -281,14 +286,14 @@ expandNode vreg src dst -- handleComponent :: Instruction instr - => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] + => Platform -> Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [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 -- go via a spill slot. -- -handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) - = mapM (makeMove delta vreg src) dsts +handleComponent platform delta _ (AcyclicSCC (vreg, src, dsts)) + = mapM (makeMove platform delta vreg src) dsts -- Handle some cyclic moves. @@ -306,53 +311,54 @@ handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) -- are allocated exclusively for a virtual register and therefore can not -- require a fixup. -- -handleComponent delta instr +handleComponent platform delta instr (CyclicSCC ( (vreg, InReg sreg, (InReg dreg: _)) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do -- spill the source into its slot (instrSpill, slot) - <- spillR (RegReal sreg) vreg + <- spillR platform (RegReal sreg) vreg -- reload into destination reg - instrLoad <- loadR (RegReal dreg) slot + instrLoad <- loadR platform (RegReal dreg) slot - remainingFixUps <- mapM (handleComponent delta instr) + remainingFixUps <- mapM (handleComponent platform delta instr) (stronglyConnCompFromEdgedVerticesR rest) -- make sure to do all the reloads after all the spills, -- so we don't end up clobbering the source values. return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) -handleComponent _ _ (CyclicSCC _) +handleComponent _ _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" -- | Move a vreg between these two locations. -- -makeMove - :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM freeRegs instr -- ^ move instruction. - -makeMove _ vreg (InReg src) (InReg dst) - = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr (RegReal src) (RegReal dst) - -makeMove delta vreg (InMem src) (InReg dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr (RegReal dst) delta src - -makeMove delta vreg (InReg src) (InMem dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr (RegReal src) delta dst +makeMove + :: Instruction instr + => Platform + -> Int -- ^ current C stack delta. + -> Unique -- ^ unique of the vreg that we're moving. + -> Loc -- ^ source location. + -> Loc -- ^ destination location. + -> RegM freeRegs instr -- ^ move instruction. + +makeMove platform _ vreg (InReg src) (InReg dst) + = do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal src) (RegReal dst) + +makeMove platform delta vreg (InMem src) (InReg dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr platform (RegReal dst) delta src + +makeMove platform delta vreg (InReg src) (InMem dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr platform (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. -makeMove _ vreg src dst +makeMove _ _ vreg src dst = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" ++ show dst ++ ")" ++ " we don't handle mem->mem moves." |