-
--- -----------------------------------------------------------------------------
--- Joining a jump instruction to its targets
-
--- The first time we encounter a jump to a particular basic block, we
--- record the assignment of temporaries. The next time we encounter a
--- jump to the same block, we compare our current assignment to the
--- stored one. They might be different if spilling has occrred in one
--- branch; so some fixup code will be required to match up the
--- assignments.
-
-joinToTargets
- :: BlockMap RegSet
- -> [NatBasicBlock]
- -> Instr
- -> [BlockId]
- -> RegM ([NatBasicBlock], Instr)
-
-joinToTargets _ new_blocks instr []
- = return (new_blocks, instr)
-
-joinToTargets block_live new_blocks instr (dest:dests) = do
- block_assig <- getBlockAssigR
- assig <- getAssigR
- let
- -- adjust the assignment to remove any registers which are not
- -- live on entry to the destination block.
- adjusted_assig = filterUFM_Directly still_live assig
-
- live_set = lookItUp "joinToTargets" block_live dest
- still_live uniq _ = uniq `elemUniqSet_Directly` live_set
-
- -- 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
- case lookupBlockEnv block_assig dest of
- -- Nothing <=> this is the first time we jumped to this
- -- block.
- Nothing -> do
- freeregs <- getFreeRegsR
- let freeregs' = foldr releaseReg freeregs to_free
- setBlockAssigR (extendBlockEnv block_assig dest
- (freeregs',adjusted_assig))
- joinToTargets block_live new_blocks instr dests
-
- Just (_, dest_assig)
-
- -- the assignments match
- | ufmToList dest_assig == ufmToList adjusted_assig
- -> joinToTargets block_live new_blocks instr dests
-
- -- need fixup code
- | otherwise
- -> do
- delta <- getDeltaR
-
- let graph = makeRegMovementGraph adjusted_assig dest_assig
- let sccs = stronglyConnCompFromEdgedVerticesR graph
- fixUpInstrs <- mapM (handleComponent delta instr) sccs
-
- block_id <- getUniqueR
- let block = BasicBlock (BlockId block_id) $
- concat fixUpInstrs ++ mkBranchInstr dest
-
- let instr' = patchJump instr dest (BlockId block_id)
-
- joinToTargets block_live (block : new_blocks) instr' dests
-
-
--- | Construct a graph of register\/spill movements.
---
--- We cut some corners by
--- a) not handling cyclic components
--- b) not handling memory-to-memory moves.
---
--- Cyclic components seem to occur only very rarely,
--- and we don't need memory-to-memory moves because we
--- make sure that every temporary always gets its own
--- stack slot.
-
-makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
-makeRegMovementGraph adjusted_assig dest_assig
- = let
- mkNodes src vreg
- = expandNode vreg src
- $ lookupWithDefaultUFM_Directly
- dest_assig
- (panic "RegAllocLinear.makeRegMovementGraph")
- vreg
-
- in [ node | (vreg, src) <- ufmToList adjusted_assig
- , node <- mkNodes src vreg ]
-
--- The InBoth handling is a little tricky here. If
--- the destination is InBoth, then we must ensure that
--- the value ends up in both locations. An InBoth
--- destination must conflict with an InReg or InMem
--- source, so we expand an InBoth destination as
--- necessary. An InBoth source is slightly different:
--- we only care about the register that the source value
--- is in, so that we can move it to the destinations.
-
-expandNode vreg loc@(InReg src) (InBoth dst mem)
- | src == dst = [(vreg, loc, [InMem mem])]
- | otherwise = [(vreg, loc, [InReg dst, InMem mem])]
-
-expandNode vreg loc@(InMem src) (InBoth dst mem)
- | src == mem = [(vreg, loc, [InReg dst])]
- | otherwise = [(vreg, loc, [InReg dst, InMem mem])]
-
-expandNode _ (InBoth _ src) (InMem dst)
- | src == dst = [] -- guaranteed to be true
-
-expandNode _ (InBoth src _) (InReg dst)
- | src == dst = []
-
-expandNode vreg (InBoth src _) dst
- = expandNode vreg (InReg src) dst
-
-expandNode vreg src dst
- | src == dst = []
- | otherwise = [(vreg, src, [dst])]
-
-
--- | Make a move instruction between these two locations so we
--- can join together allocations for different basic blocks.
---
-makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr
-makeMove _ vreg (InReg src) (InReg dst)
- = do recordSpill (SpillJoinRR vreg)
- return $ mkRegRegMoveInstr (RealReg src) (RealReg dst)
-
-makeMove delta vreg (InMem src) (InReg dst)
- = do recordSpill (SpillJoinRM vreg)
- return $ mkLoadInstr (RealReg dst) delta src
-
-makeMove delta vreg (InReg src) (InMem dst)
- = do recordSpill (SpillJoinRM vreg)
- return $ mkSpillInstr (RealReg src) delta dst
-
-makeMove _ vreg src dst
- = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
- ++ show dst ++ ")"
- ++ " (workaround: use -fviaC)"
-
-
--- we have eliminated any possibility of single-node cylces
--- in expandNode above.
-handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr]
-handleComponent delta _ (AcyclicSCC (vreg,src,dsts))
- = mapM (makeMove delta 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 delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
- = do
- spill_id <- getUniqueR
- (_, slot) <- spillR (RealReg sreg) spill_id
- remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest)
- restoreAndFixInstr <- getRestoreMoves dsts slot
- return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
-
- where
- getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot
- = do
- restoreToReg <- loadR (RealReg reg) slot
- moveInstr <- makeMove delta vreg r mem
- return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr]
-
- 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"
-
-
-
--- -----------------------------------------------------------------------------
--- Utils
-
-my_fromJust :: String -> SDoc -> Maybe a -> a
-my_fromJust _ _ (Just x) = x
-my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
-
-lookItUp :: String -> BlockMap a -> BlockId -> a
-lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x)