#ifndef DEBUG
import Data.Maybe ( fromJust )
#endif
-import Data.Maybe ( fromMaybe )
import Data.List ( nub, partition, mapAccumL, groupBy )
import Control.Monad ( when )
import Data.Word
liveness liveregs blockmap done [] = (liveregs, done)
liveness liveregs blockmap done (instr:instrs)
- = liveness liveregs2 blockmap ((instr,r_dying,w_dying):done) instrs
+ | not_a_branch = liveness liveregs1 blockmap
+ ((instr,r_dying,w_dying):done) instrs
+ | otherwise = liveness liveregs_br blockmap
+ ((instr,r_dying_br,w_dying):done) instrs
where
RU read written = regUsage instr
liveregs1 = (liveregs `delListFromUniqSet` written)
`addListToUniqSet` read
+ -- registers that are not live beyond this point, are recorded
+ -- as dying here.
+ r_dying = [ reg | reg <- read, reg `notElem` written,
+ not (elementOfUniqSet reg liveregs) ]
+
+ w_dying = [ reg | reg <- written,
+ not (elementOfUniqSet reg liveregs) ]
+
-- union in the live regs from all the jump destinations of this
-- instruction.
targets = jumpDests instr [] -- where we go from here
- liveregs2 = unionManyUniqSets
- (liveregs1 : map targetLiveRegs targets)
+ not_a_branch = null targets
targetLiveRegs target = case lookupUFM blockmap target of
Just ra -> ra
Nothing -> emptyBlockMap
- -- registers that are not live beyond this point, are recorded
- -- as dying here.
- r_dying = [ reg | reg <- read, reg `notElem` written,
- not (elementOfUniqSet reg liveregs) ]
+ live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
- w_dying = [ reg | reg <- written,
- not (elementOfUniqSet reg liveregs) ]
+ liveregs_br = liveregs1 `unionUniqSets` live_from_branch
+ -- registers that are live only in the branch targets should
+ -- be listed as dying here.
+ live_branch_only = live_from_branch `minusUniqSet` liveregs
+ r_dying_br = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
+ live_branch_only)
-- -----------------------------------------------------------------------------
-- Linear sweep to allocate registers
(CyclicSCC blocks : sccs)
= getUs `thenUs` \us ->
let
- ((block_assig', stack', us'), blocks') = mapAccumL processBlock
+ ((block_assig', stack', _), blocks') = mapAccumL processBlock
(block_assig, stack, us)
({-reverse-} blocks)
in
-- we have eliminated any possibility of single-node cylces
-- in expandNode above.
handleComponent (AcyclicSCC (vreg,src,dsts))
- = map (makeMove vreg src) dsts
- handleComponent (CyclicSCC things)
- = panic $ "Register Allocator: handleComponent: cyclic"
- ++ " (workaround: use -fviaC)"
-
+ = return $ map (makeMove vreg src) dsts
+
+ -- we can not have cycles that involve memory
+ -- locations as source nor as single destination
+ -- because memory locations (stack slots) are
+ -- allocated exclusively for a virtual register and
+ -- therefore can not require a fixup
+ handleComponent (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest))
+ = do
+ spill_id <- getUniqueR
+ (saveInstr,slot) <- spillR (RealReg sreg) spill_id
+ remainingFixUps <- mapM handleComponent (stronglyConnCompR rest)
+ restoreAndFixInstr <- getRestoreMoves dsts slot
+ return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
+ where
+ getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot
+ = do
+ restoreToReg <- loadR (RealReg reg) slot
+ return $ [restoreToReg, makeMove vreg r mem]
+ getRestoreMoves [InReg reg] slot
+ = loadR (RealReg reg) slot >>= return . (:[])
+ getRestoreMoves [InMem _] _ = panic "getRestoreMoves can not handle memory only restores"
+ getRestoreMoves _ _ = panic "getRestoreMoves unknown case"
+ handleComponent (CyclicSCC _)
+ = panic "Register Allocator: handleComponent cyclic"
makeMove vreg (InReg src) (InReg dst)
= mkRegRegMoveInstr (RealReg src) (RealReg dst)
makeMove vreg (InMem src) (InReg dst)
++ " (workaround: use -fviaC)"
block_id <- getUniqueR
+ fixUpInstrs <- mapM handleComponent sccs
let block = BasicBlock (BlockId block_id) $
- concatMap handleComponent sccs ++ mkBranchInstr dest
+ concat fixUpInstrs ++ mkBranchInstr dest
let instr' = patchJump instr dest (BlockId block_id)
joinToTargets block_live (block : new_blocks) instr' dests
where
(# s{ra_stack=stack'}, (instr,slot) #)
loadR :: Reg -> Int -> RegM Instr
-loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
+loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
(# s, mkLoadInstr reg delta slot #)
getFreeRegsR :: RegM FreeRegs
setAssigR assig = RegM $ \ s ->
(# s{ra_assig=assig}, () #)
-getStackR :: RegM StackMap
-getStackR = RegM $ \ s@RA_State{ra_stack = stack} ->
- (# s, stack #)
-
-setStackR :: StackMap -> RegM ()
-setStackR stack = RegM $ \ s ->
- (# s{ra_stack=stack}, () #)
-
getBlockAssigR :: RegM BlockAssignment
getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
(# s, assig #)