+allocateRegsAndSpill _ _ spills alloc []
+ = return (spills, reverse alloc)
+
+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 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.
+ Just (InBoth my_reg _)
+ -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
+ allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+ -- Not already in a register, so we need to find a free one...
+ 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
+
+
+-- 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 :: (Instruction instr, Outputable instr)
+ => Bool
+ -> [VirtualReg]
+ -> [instr]
+ -> [RealReg]
+ -> VirtualReg
+ -> [VirtualReg]
+ -> UniqFM Loc
+ -> SpillLoc
+ -> RegM ([instr], [RealReg])
+allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
+ = do
+ freeRegs <- getFreeRegsR
+ let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs
+
+ case freeRegs_thisClass of
+
+ -- case (2): we have a free register
+ (my_reg : _) ->
+ do spills' <- loadTemp r spill_loc my_reg spills
+
+ setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
+ setFreeRegsR $ allocateReg my_reg freeRegs
+
+ allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
+
+
+ -- case (3): we need to push something out to free up a register
+ [] ->
+ do let keep' = map getUnique keep
+
+ -- the vregs we could kick out that are already in a slot
+ let candidates_inBoth
+ = [ (temp, reg, mem)
+ | (temp, InBoth reg mem) <- ufmToList assig
+ , temp `notElem` keep'
+ , targetClassOfRealReg reg == classOfVirtualReg r ]
+
+ -- the vregs we could kick out that are only in a reg
+ -- this would require writing the reg to a new slot before using it.
+ let candidates_inReg
+ = [ (temp, reg)
+ | (temp, InReg reg) <- ufmToList assig
+ , temp `notElem` keep'
+ , targetClassOfRealReg reg == classOfVirtualReg r ]
+
+ let result
+
+ -- 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 r spill_loc my_reg spills
+ let assig1 = addToUFM assig temp (InMem slot)
+ let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
+
+ setAssigR assig2
+ allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
+
+ -- otherwise, we need to spill a temporary that currently
+ -- resides in a register.
+ | (temp_to_push_out, (my_reg :: RealReg)) : _
+ <- candidates_inReg
+ = do
+ (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
+ let spill_store = (if reading then id else reverse)
+ [ -- COMMENT (fsLit "spill alloc")
+ spill_insn ]
+
+ -- record that this temp was spilled
+ recordSpill (SpillAlloc temp_to_push_out)
+
+ -- update the register assignment
+ let assig1 = addToUFM assig temp_to_push_out (InMem slot)
+ 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 r spill_loc my_reg spills
+
+ allocateRegsAndSpill reading keep
+ (spill_store ++ spills')
+ (my_reg:alloc) rs
+
+
+ -- there wasn't anything to spill, so we're screwed.
+ | otherwise
+ = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
+ $ vcat
+ [ text "allocating vreg: " <> text (show r)
+ , text "assignment: " <> text (show $ ufmToList assig)
+ , text "freeRegs: " <> text (show freeRegs)
+ , text "initFreeRegs: " <> text (show initFreeRegs) ]
+
+ result
+
+
+-- | 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
+ :: (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 vreg (ReadMem slot) hreg spills
+ = do
+ insn <- loadR (RegReal hreg) slot
+ recordSpill (SpillLoad $ getUnique vreg)
+ return $ {- COMMENT (fsLit "spill load") : -} insn : spills
+
+loadTemp _ _ _ spills =
+ return spills