-}
-{-
-Possible plan for x86 floating pt register alloc:
-
- - The standard reg alloc procedure allocates pretend floating point
- registers to the GXXX instructions. We need to convert these GXXX
- instructions to proper x86 FXXX instructions, using the FP stack for
- registers.
-
- We could do this in a separate pass, but it helps to have the
- information about which real registers are live after the
- instruction, so we do it at reg alloc time where that information
- is already available.
-
- - keep a mapping from %fakeN to FP stack slot in the monad.
-
- - after assigning registers to the GXXX instruction, convert the
- instruction to an FXXX instruction. eg.
- - for GMOV just update the mapping, and ffree any dead regs.
- - GLD: just fld and update mapping
- GLDZ: just fldz and update mapping
- GLD1: just fld1 and update mapping
- - GST: just fst and update mapping, ffree dead regs.
- - special case for GST reg, where reg is st(0), we can fstp.
- - for GADD fp1, fp2, fp3:
- - easy way: fld fp2
- fld fp1
- faddp
- -- record that fp3 is now in %st(0), and all other
- -- slots are pushed down one.
- ffree fp1 -- if fp1 is dead now
- ffree fp2 -- if fp2 is dead now
- - optimisation #1
- - if fp1 is in %st(0) and is dead afterward
- fadd %st(0), fp2
- -- record fp3 is in %st(0)
- ffree fp2 -- if fp2 is dead now
- - if fp2 is in %st(0) and is dead afterward
- fadd %st(0), fp1
- -- record fp3 is in %st(0)
- - if fp1 is in %st(0), fp2 is dead afterward
- fadd fp2, %st(0)
- -- record fp3 is in fp2's locn
- - if fp2 is in %st(0), fp1 is dead afterward
- fadd fp1, %st(0)
- -- record fp3 is in fp1's locn
-
- - we should be able to avoid the nasty ffree problems of the current
- scheme. The stack should be empty before doing a non-local
- jump/call - we can assert that this is the case.
--}
-
-
module RegisterAlloc (
regAlloc
) where
-- 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
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