X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAlloc%2FLinear%2FJoinToTargets.hs;h=e6a078a05e4b2e4a27bbfbbbf670095d7fe0c2e8;hp=7d2cbcd7a788dda02a86f822940935e29d173398;hb=3c2a7f3515ca15cdebb6242967f89e633cb59494;hpb=b04a210e26ca57242fd052f2aa91011a80b76299 diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index 7d2cbcd..e6a078a 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -1,5 +1,3 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} - -- | Handles joining of a jump instruction to its targets. @@ -23,7 +21,7 @@ import Instruction import Reg import BlockId -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph import Outputable import Unique @@ -35,14 +33,14 @@ import UniqSet -- vregs are in the correct regs for its destination. -- joinToTargets - :: Instruction instr + :: (FR freeRegs, 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 -> instr -- ^ branch instr on the end of the source block. - -> RegM ([NatBasicBlock instr] -- fresh blocks of fixup code. + -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. , instr) -- the original branch instruction, but maybe patched to jump -- to a fixup block first. @@ -57,7 +55,7 @@ joinToTargets block_live id instr ----- joinToTargets' - :: Instruction instr + :: (FR freeRegs, 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. @@ -68,7 +66,7 @@ joinToTargets' -> [BlockId] -- ^ branch destinations still to consider. - -> RegM ( [NatBasicBlock instr] + -> RegM freeRegs ( [NatBasicBlock instr] , instr) -- no more targets to consider. all done. @@ -86,7 +84,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- adjust the current assignment to remove any vregs that are not live -- on entry to the destination block. - let Just live_set = lookupBlockEnv block_live dest + let Just live_set = mapLookup dest block_live let still_live uniq _ = uniq `elemUniqSet_Directly` live_set let adjusted_assig = filterUFM_Directly still_live assig @@ -96,7 +94,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) , not (elemUniqSet_Directly reg live_set) , r <- regsOfLoc loc ] - case lookupBlockEnv block_assig dest of + case mapLookup dest block_assig of Nothing -> joinToTargets_first block_live new_blocks block_id instr dest dests @@ -109,21 +107,42 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- this is the first time we jumped to this block. +joinToTargets_first :: (FR freeRegs, Instruction instr) + => BlockMap RegSet + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> BlockAssignment freeRegs + -> RegMap Loc + -> [RealReg] + -> RegM freeRegs ([NatBasicBlock instr], instr) joinToTargets_first block_live new_blocks block_id instr dest dests - block_assig src_assig to_free + block_assig src_assig + to_free = do -- free up the regs that are not live on entry to this block. freeregs <- getFreeRegsR - let freeregs' = foldr releaseReg freeregs to_free + let freeregs' = foldr frReleaseReg freeregs to_free -- remember the current assignment on entry to this block. - setBlockAssigR (extendBlockEnv block_assig dest - (freeregs', src_assig)) + setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) joinToTargets' block_live new_blocks block_id instr dests -- we've jumped to this block before +joinToTargets_again :: (Instruction instr, FR freeRegs) + => BlockMap RegSet + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> UniqFM Loc + -> UniqFM Loc + -> RegM freeRegs ([NatBasicBlock instr], instr) joinToTargets_again block_live new_blocks block_id instr dest dests src_assig dest_assig @@ -172,7 +191,7 @@ joinToTargets_again -- A the end of the current block we will jump to the fixup one, -- then that will jump to our original destination. fixup_block_id <- getUniqueR - let block = BasicBlock (BlockId fixup_block_id) + let block = BasicBlock (mkBlockId fixup_block_id) $ fixUpInstrs ++ mkJumpInstr dest {- pprTrace @@ -189,8 +208,8 @@ joinToTargets_again -- fixup block instead. _ -> let instr' = patchJumpInstr instr (\bid -> if bid == dest - then BlockId fixup_block_id - else dest) + then mkBlockId fixup_block_id + else bid) -- no change! in joinToTargets' block_live (block : new_blocks) block_id instr' dests @@ -262,7 +281,7 @@ expandNode vreg src dst -- handleComponent :: Instruction instr - => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM [instr] + => 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 @@ -288,14 +307,15 @@ handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) -- require a fixup. -- handleComponent delta instr - (CyclicSCC ( (vreg, InReg sreg, [InReg dreg]) : rest)) + (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 (RealReg sreg) vreg + <- spillR (RegReal sreg) vreg -- reload into destination reg - instrLoad <- loadR (RealReg dreg) slot + instrLoad <- loadR (RegReal dreg) slot remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest) @@ -316,19 +336,19 @@ makeMove -> Unique -- ^ unique of the vreg that we're moving. -> Loc -- ^ source location. -> Loc -- ^ destination location. - -> RegM instr -- ^ move instruction. + -> RegM freeRegs instr -- ^ move instruction. 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) - return $ mkLoadInstr (RealReg dst) delta src + return $ mkLoadInstr (RegReal dst) delta src 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.