) where
#include "HsVersions.h"
-#include "../includes/ghcconfig.h"
import PprMach
import MachRegs
import Cmm
import Digraph
-import Unique ( Uniquable(..), Unique, getUnique )
+import Unique ( Uniquable(getUnique), Unique )
import UniqSet
import UniqFM
import Outputable
-- 32-bit words).
data FreeRegs = FreeRegs !Word32 !Word32
+ deriving( Show ) -- The Show is used in an ASSERT
+noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0 0
+
+releaseReg :: RegNo -> FreeRegs -> FreeRegs
releaseReg r (FreeRegs g f)
| r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
| otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
initFreeRegs :: FreeRegs
initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
+getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly
getFreeRegs cls (FreeRegs g f)
| RcDouble <- cls = go f (0x80000000) 63
| RcInteger <- cls = go g (0x80000000) 31
go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
| otherwise = go x (m `shiftR` 1) $! i-1
-allocateReg (FreeRegs g f) r
+allocateReg :: RegNo -> FreeRegs -> FreeRegs
+allocateReg r (FreeRegs g f)
| r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
| otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
-- ToDo: there's no point looking through all the integer registers
-- in order to find a floating-point one.
-allocateReg :: FreeRegs -> RegNo -> FreeRegs
-allocateReg f r = f .&. complement (1 `shiftL` fromIntegral r)
+allocateReg :: RegNo -> FreeRegs -> FreeRegs
+allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r)
+
#endif
-- -----------------------------------------------------------------------------
other -> genRaInsn block_live new_instrs instr r_dying w_dying
-genRaInsn block_live new_instrs instr r_dying w_dying = do
+genRaInsn block_live new_instrs instr r_dying w_dying =
+ case regUsage instr of { RU read written ->
+ case partition isRealReg written of { (real_written1,virt_written) ->
+ do
let
- RU read written = regUsage instr
-
- (real_written1,virt_written) = partition isRealReg written
-
real_written = [ r | RealReg r <- real_written1 ]
-- we don't need to do anything with real registers that are
return (patched_instr : w_spills ++ reverse r_spills
++ clobber_saves ++ new_instrs,
fixup_blocks)
+ }}
-- -----------------------------------------------------------------------------
-- releaseRegs
free <- getFreeRegsR
loop assig free regs
where
+ loop assig free _ | free `seq` False = undefined
loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
loop assig free (r:rs) =
clobberRegs [] = return () -- common case
clobberRegs clobbered = do
freeregs <- getFreeRegsR
- setFreeRegsR (foldl allocateReg freeregs clobbered)
+ setFreeRegsR $! foldr allocateReg freeregs clobbered
assig <- getAssigR
setAssigR $! clobber assig (ufmToList assig)
where
| Just (InMem slot) <- loc, reading = InBoth my_reg slot
| otherwise = InReg my_reg
setAssigR (addToUFM assig r $! new_loc)
- setFreeRegsR (allocateReg freeregs 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
| (temp, InReg reg) <- ufmToList assig,
temp `notElem` keep', regClass (RealReg reg) == regClass r ]
-- in
- ASSERT2(not (null candidates1 && null candidates2), ppr assig) do
+ ASSERT2(not (null candidates1 && null candidates2),
+ text (show freeregs) <+> ppr r <+> ppr assig) do
case candidates1 of
-- resides in a register.
[] -> do
let
- (temp_to_push_out, my_reg) = head candidates2
+ (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
-- TODO: plenty of room for optimisation in choosing which temp
-- to spill. We just pick the first one that isn't used in
-- the current instruction for now.
do_load _ _ _ spills =
return spills
+myHead s [] = panic s
+myHead s (x:xs) = x
+
-- -----------------------------------------------------------------------------
-- Joining a jump instruction to its targets
let
-- adjust the assignment to remove any registers which are not
-- live on entry to the destination block.
- adjusted_assig =
- listToUFM [ (reg,loc) | reg <- live,
- Just loc <- [lookupUFM assig reg] ]
+ adjusted_assig = filterUFM_Directly still_live assig
+ 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 lookupUFM 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
stack <- getStackR
setBlockAssigR (addToUFM block_assig dest
- (freeregs,stack,adjusted_assig))
+ (freeregs',stack,adjusted_assig))
joinToTargets block_live new_blocks instr dests
Just (freeregs,stack,dest_assig)
-> -- need fixup code
panic "joinToTargets: ToDo: need fixup code"
where
- live = uniqSetToList (lookItUp "joinToTargets" block_live dest)
+ live_set = lookItUp "joinToTargets" block_live dest
-- -----------------------------------------------------------------------------
-- The register allocator's monad.
ra_blockassig :: BlockAssignment,
-- The current mapping from basic blocks to
-- the register assignments at the beginning of that block.
- ra_freeregs :: FreeRegs, -- free machine registers
+ ra_freeregs :: {-#UNPACK#-}!FreeRegs, -- free machine registers
ra_assig :: RegMap Loc, -- assignment of temps to locations
ra_delta :: Int, -- current stack delta
ra_stack :: FreeStack -- free stack slots for spilling
projects / ghc-hetmet.git / blobdiff