(c) Update the current assignment
- (d) If the intstruction is a branch:
+ (d) If the instruction is a branch:
if the destination block already has a register assignment,
Generate a new block with fixup code and redirect the
jump to the new block.
import Reg
import BlockId
-import Cmm hiding (RegSet)
+import OldCmm hiding (RegSet)
import Digraph
import Unique
import Data.List
import Control.Monad
-#include "../includes/MachRegs.h"
+#include "../includes/stg/MachRegs.h"
-- -----------------------------------------------------------------------------
( CmmData sec d
, Nothing )
-regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
- = return ( CmmProc info lbl params (ListGraph [])
+regAlloc (CmmProc (LiveInfo info _ _ _) lbl [])
+ = return ( CmmProc info lbl (ListGraph [])
, Nothing )
-regAlloc (CmmProc static lbl params (ListGraph comps))
- | LiveInfo info (Just first_id) block_live <- static
+regAlloc (CmmProc static lbl sccs)
+ | LiveInfo info (Just first_id) (Just block_live) _ <- static
= do
-- do register allocation on each component.
(final_blocks, stats)
- <- linearRegAlloc first_id block_live
- $ map (\b -> case b of
- BasicBlock _ [b] -> AcyclicSCC b
- BasicBlock _ bs -> CyclicSCC bs)
- $ comps
+ <- linearRegAlloc first_id block_live sccs
-- make sure the block that was first in the input list
-- stays at the front of the output
let ((first':_), rest')
= partition ((== first_id) . blockId) final_blocks
- return ( CmmProc info lbl params (ListGraph (first' : rest'))
+ return ( CmmProc info lbl (ListGraph (first' : rest'))
, Just stats)
-- bogus. to make non-exhaustive match warning go away.
-regAlloc (CmmProc _ _ _ _)
+regAlloc (CmmProc _ _ _)
= panic "RegAllocLinear.regAlloc: no match"
linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
= do
- blockss' <- process first_id block_live blocks [] (return [])
+ blockss' <- process first_id block_live blocks [] (return []) False
linearRA_SCCs first_id block_live
(reverse (concat blockss') ++ blocksAcc)
sccs
some reason then this function will loop. We should probably do some
more sanity checking to guard against this eventuality.
-}
-
-process _ _ [] [] accum
+
+process _ _ [] [] accum _
= return $ reverse accum
-process first_id block_live [] next_round accum
- = process first_id block_live next_round [] accum
+process first_id block_live [] next_round accum madeProgress
+ | not madeProgress
+
+ {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
+ pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
+ ( text "Unreachable blocks:"
+ $$ vcat (map ppr next_round)) -}
+ = return $ reverse accum
+
+ | otherwise
+ = process first_id block_live
+ next_round [] accum False
-process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum
+process first_id block_live (b@(BasicBlock id _) : blocks)
+ next_round accum madeProgress
= do
block_assig <- getBlockAssigR
- if isJust (lookupBlockEnv block_assig id)
+ if isJust (mapLookup id block_assig)
|| id == first_id
then do
b' <- processBlock block_live b
- process first_id block_live blocks next_round (b' : accum)
+ process first_id block_live blocks
+ next_round (b' : accum) True
- else process first_id block_live blocks (b : next_round) accum
+ else process first_id block_live blocks
+ (b : next_round) accum madeProgress
-- | Do register allocation on this basic block
initBlock :: BlockId -> RegM ()
initBlock id
= do block_assig <- getBlockAssigR
- case lookupBlockEnv block_assig id of
+ case mapLookup id block_assig of
-- no prior info about this block: assume everything is
-- free and the assignment is empty.
Nothing
linearRA block_live accInstr accFixups id (instr:instrs)
= do
- (accInstr', new_fixups)
+ (accInstr', new_fixups)
<- raInsn block_live accInstr id instr
linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
( [instr] -- new instructions
, [NatBasicBlock instr]) -- extra fixup blocks
-raInsn _ new_instrs _ (Instr ii Nothing)
+raInsn _ new_instrs _ (LiveInstr ii Nothing)
| Just n <- takeDeltaInstr ii
= do setDeltaR n
return (new_instrs, [])
-raInsn _ new_instrs _ (Instr ii Nothing)
+raInsn _ new_instrs _ (LiveInstr ii Nothing)
| isMetaInstr ii
= return (new_instrs, [])
-raInsn block_live new_instrs id (Instr instr (Just live))
+raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
= do
assig <- getAssigR
-- register does not already have an assignment,
-- and the source register is assigned to a register, not to a spill slot,
-- then we can eliminate the instruction.
- -- (we can't eliminitate it if the source register is on the stack, because
+ -- (we can't eliminate it if the source register is on the stack, because
-- we do not want to use one spill slot for different virtual registers)
case takeRegRegMoveInstr instr of
Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
clobber_saves <- saveClobberedTemps real_written r_dying
-- debugging
-{- freeregs <- getFreeRegsR
+{- freeregs <- getFreeRegsR
assig <- getAssigR
pprTrace "genRaInsn"
(ppr instr
saveClobberedTemps
- :: Instruction instr
+ :: (Outputable instr, Instruction instr)
=> [RealReg] -- real registers clobbered by this instruction
-> [Reg] -- registers which are no longer live after this insn
-> RegM [instr] -- return: instructions to spill any temps that will
--- | Mark all these regal regs as allocated,
+-- | Mark all these real regs as allocated,
-- and kick out their vreg assignments.
--
clobberRegs :: [RealReg] -> RegM ()
-- -----------------------------------------------------------------------------
-- allocateRegsAndSpill
+-- Why are we performing a spill?
+data SpillLoc = ReadMem StackSlot -- reading from register only in memory
+ | WriteNew -- writing to a new variable
+ | WriteMem -- writing to register only in memory
+-- Note that ReadNew is not valid, since you don't want to be reading
+-- from an uninitialized register. We also don't need the location of
+-- the register in memory, since that will be invalidated by the write.
+-- Technically, we could coalesce WriteNew and WriteMem into a single
+-- entry as well. -- EZY
+
-- This function does several things:
-- For each temporary referred to by this instruction,
-- we allocate a real register (spilling another temporary if necessary).
-- the list of free registers and free stack slots.
allocateRegsAndSpill
- :: Instruction instr
+ :: (Outputable instr, Instruction instr)
=> Bool -- True <=> reading (load up spilled regs)
-> [VirtualReg] -- don't push these out
-> [instr] -- spill insns
allocateRegsAndSpill reading keep spills alloc (r:rs)
= do assig <- getAssigR
+ let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
case lookupUFM assig r of
-- case (1a): already in a register
Just (InReg my_reg) ->
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-- case (1b): already in a register (and memory)
- -- NB1. if we're writing this register, update its assignemnt to be
+ -- NB1. if we're writing this register, update its assignment to be
-- InReg, because the memory value is no longer valid.
-- NB2. This is why we must process written registers here, even if they
-- are also read by the same instruction.
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-- Not already in a register, so we need to find a free one...
- loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
+ Just (InMem slot) | reading -> doSpill (ReadMem slot)
+ | otherwise -> doSpill WriteMem
+ Nothing | reading ->
+ -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
+ -- ToDo: This case should be a panic, but we
+ -- sometimes see an unreachable basic block which
+ -- triggers this because the register allocator
+ -- will start with an empty assignment.
+ doSpill WriteNew
+
+ | otherwise -> doSpill WriteNew
-allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
+-- reading is redundant with reason, but we keep it around because it's
+-- convenient and it maintains the recursive structure of the allocator. -- EZY
+allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
= do
freeRegs <- getFreeRegsR
let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs
-- case (2): we have a free register
(my_reg : _) ->
- do spills' <- loadTemp reading r loc my_reg spills
-
- let new_loc
- -- if the tmp was in a slot, then now its in a reg as well
- | Just (InMem slot) <- loc
- , reading
- = InBoth my_reg slot
-
- -- tmp has been loaded into a reg
- | otherwise
- = InReg my_reg
+ do spills' <- loadTemp r spill_loc my_reg spills
- setAssigR (addToUFM assig r $! new_loc)
+ setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
setFreeRegsR $ allocateReg my_reg freeRegs
allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
-- we have a temporary that is in both register and mem,
-- just free up its register for use.
| (temp, my_reg, slot) : _ <- candidates_inBoth
- = do spills' <- loadTemp reading r loc my_reg spills
+ = do spills' <- loadTemp r spill_loc my_reg spills
let assig1 = addToUFM assig temp (InMem slot)
- let assig2 = addToUFM assig1 r (InReg my_reg)
+ let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
setAssigR assig2
allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
-- update the register assignment
let assig1 = addToUFM assig temp_to_push_out (InMem slot)
- let assig2 = addToUFM assig1 r (InReg my_reg)
+ let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
setAssigR assig2
-- if need be, load up a spilled temp into the reg we've just freed up.
- spills' <- loadTemp reading r loc my_reg spills
+ spills' <- loadTemp r spill_loc my_reg spills
allocateRegsAndSpill reading keep
(spill_store ++ spills')
result
--- | Load up a spilled temporary if we need to.
+-- | Calculate a new location after a register has been loaded.
+newLocation :: SpillLoc -> RealReg -> Loc
+-- if the tmp was read from a slot, then now its in a reg as well
+newLocation (ReadMem slot) my_reg = InBoth my_reg slot
+-- writes will always result in only the register being available
+newLocation _ my_reg = InReg my_reg
+
+-- | Load up a spilled temporary if we need to (read from memory).
loadTemp
- :: Instruction instr
- => Bool
- -> VirtualReg -- the temp being loaded
- -> Maybe Loc -- the current location of this temp
+ :: (Outputable instr, Instruction instr)
+ => VirtualReg -- the temp being loaded
+ -> SpillLoc -- the current location of this temp
-> RealReg -- the hreg to load the temp into
-> [instr]
-> RegM [instr]
-loadTemp True vreg (Just (InMem slot)) hreg spills
+loadTemp vreg (ReadMem slot) hreg spills
= do
insn <- loadR (RegReal hreg) slot
recordSpill (SpillLoad $ getUnique vreg)
return $ {- COMMENT (fsLit "spill load") : -} insn : spills
-loadTemp _ _ _ _ spills =
+loadTemp _ _ _ spills =
return spills
projects / ghc-hetmet.git / blobdiff