%
-% (c) The AQUA Project, Glasgow University, 1993-1998
+% (c) The AQUA Project, Glasgow University, 1993-2000
%
\section[AsmRegAlloc]{Register allocator}
\begin{code}
-module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
+module AsmRegAlloc ( runRegAllocate ) where
#include "HsVersions.h"
import MachCode ( InstrBlock )
import MachMisc ( Instr(..) )
-import PprMach ( pprUserReg ) -- debugging
+import PprMach ( pprUserReg, pprInstr ) -- debugging
import MachRegs
import RegAllocInfo
-import FiniteMap ( emptyFM, addListToFM, delListFromFM,
- lookupFM, keysFM )
+import FiniteMap ( FiniteMap, emptyFM, addListToFM, delListFromFM,
+ lookupFM, keysFM, eltsFM, mapFM, addToFM_C, addToFM,
+ listToFM, fmToList, lookupWithDefaultFM )
import Maybes ( maybeToBool )
import Unique ( mkBuiltinUnique )
import Util ( mapAccumB )
import OrdList ( unitOL, appOL, fromOL, concatOL )
import Outputable
-import List ( mapAccumL )
+import Unique ( Unique, Uniquable(..), mkPseudoUnique3 )
+import CLabel ( CLabel, pprCLabel )
+
+import List ( mapAccumL, nub, sort )
+import Array ( Array, array, (!), bounds )
\end{code}
-This is the generic register allocator.
+This is the generic register allocator. It does allocation for all
+architectures. Details for specific architectures are given in
+RegAllocInfo.lhs. In practice the allocator needs to know next to
+nothing about an architecture to do its job:
+
+* It needs to be given a list of the registers it can allocate to.
+
+* It needs to be able to find out which registers each insn reads and
+ writes.
+
+* It needs be able to change registers in instructions into other
+ registers.
+
+* It needs to be able to find out where execution could go after an
+ in instruction.
+
+* It needs to be able to discover sets of registers which can be
+ used to attempt spilling.
First we try something extremely simple. If that fails, we have to do
things the hard way.
\begin{code}
runRegAllocate
- :: MRegsState
- -> ([Instr] -> [[RegNo]])
+ :: [Reg]
+ -> ([Instr] -> [[Reg]])
-> InstrBlock
-> [Instr]
runRegAllocate regs find_reserve_regs instrs
= case simpleAlloc of
- Just simple -> simple
- Nothing -> tryHairy reserves
+ Just simple -> --trace "SIMPLE"
+ simple
+ Nothing -> --trace "GENERAL"
+ (tryGeneral reserves)
where
- tryHairy []
- = error "nativeGen: spilling failed. Try -fvia-C.\n"
- tryHairy (resv:resvs)
- = case hairyAlloc resv of
+ tryGeneral []
+ = error "nativeGen: spilling failed. Workaround: compile with -fvia-C.\n"
+ tryGeneral (resv:resvs)
+ = case generalAlloc resv of
Just success -> success
- Nothing -> tryHairy resvs
+ Nothing -> tryGeneral resvs
- reserves = find_reserve_regs flatInstrs
- flatInstrs = fromOL instrs
- simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
- hairyAlloc resvd = hairyRegAlloc regs resvd flatInstrs
-
-
-runHairyRegAllocate
- :: MRegsState
- -> [RegNo]
- -> InstrBlock
- -> Maybe [Instr]
-
-runHairyRegAllocate regs reserve_regs instrs
- = hairyRegAlloc regs reserve_regs flatInstrs
- where
- flatInstrs = fromOL instrs
+ reserves = find_reserve_regs flatInstrs
+ flatInstrs = fromOL instrs
+ simpleAlloc = doSimpleAlloc regs flatInstrs
+ generalAlloc resvd = doGeneralAlloc regs resvd flatInstrs
\end{code}
-Here is the simple register allocator. Just dole out registers until
-we run out, or until one gets clobbered before its last use. Don't
-do anything fancy with branches. Just pretend that you've got a block
-of straight-line code and hope for the best. Experience indicates that
-this approach will suffice for about 96 percent of the code blocks that
-we generate.
+Rather than invoke the heavyweight machinery in @doGeneralAlloc@ for
+each and every code block, we first try using this simple, fast and
+utterly braindead allocator. In practice it handles about 60\% of the
+code blocks really fast, even with only 3 integer registers available.
+Since we can always give up and fall back to @doGeneralAlloc@,
+@doSimpleAlloc@ is geared to handling the common case as fast as
+possible. It will succeed only if:
-\begin{code}
-simpleRegAlloc
- :: MRegsState -- registers to select from
- -> [Reg] -- live static registers
- -> RegAssignment -- mapping of dynamics to statics
- -> [Instr] -- code
- -> Maybe [Instr]
-
-simpleRegAlloc _ _ _ [] = Just []
-
-simpleRegAlloc free live env (instr:instrs)
- | null deadSrcs &&
- maybeToBool newAlloc &&
- maybeToBool instrs2
- = Just (instr3 : instrs3)
- | otherwise
- = Nothing
- where
- instr3 = patchRegs instr (lookup env2)
-
- (srcs, dsts) = case regUsage instr of
- (RU s d) -> (regSetToList s, regSetToList d)
-
- lookup env x = case lookupFM env x of Just y -> y; Nothing -> x
-
- deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
- newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
+* The code mentions registers only of integer class, not floating
+ class.
- newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
- (free2, new) = case newAlloc of Just x -> x
+* The code doesn't mention any real registers, so we don't have to
+ think about dodging and weaving to work around fixed register uses.
- env2 = env `addListToFM` new
+* The code mentions at most N virtual registers, where N is the number
+ of real registers for allocation.
- live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
+If those conditions are satisfied, we simply trundle along the code,
+doling out a real register every time we see mention of a new virtual
+register. We either succeed at this, or give up when one of the above
+three conditions is no longer satisfied.
- instrs2 = simpleRegAlloc free2 live2 env2 instrs
- instrs3 = case instrs2 of Just x -> x
-
- allocateNewReg
- :: Reg
- -> Maybe (MRegsState, [(Reg, Reg)])
- -> Maybe (MRegsState, [(Reg, Reg)])
-
- allocateNewReg _ Nothing = Nothing
-
- allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs))
- | null choices = Nothing
- | otherwise = Just (free2, prs2)
- where
- choices = possibleMRegs pk free
- reg = head choices
- free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
- prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
+\begin{code}
+doSimpleAlloc :: [Reg] -> [Instr] -> Maybe [Instr]
+doSimpleAlloc available_real_regs instrs
+ = let available_iregs
+ = filter ((== RcInteger).regClass) available_real_regs
+
+ trundle :: [( {-Virtual-}Reg, {-Real-}Reg )]
+ -> [ {-Real-}Reg ]
+ -> [Instr]
+ -> [Instr]
+ -> Maybe [Instr]
+ trundle vreg_map uncommitted_rregs ris_done []
+ = Just (reverse ris_done)
+ trundle vreg_map uncommitted_rregs ris_done (i:is)
+ = case regUsage i of
+ RU rds wrs
+
+ -- Mentions no regs? Move on quickly
+ | null rds_l && null wrs_l
+ -> trundle vreg_map uncommitted_rregs (i:ris_done) is
+
+ -- A case we can't be bothered to handle?
+ | any isFloatingOrReal rds_l || any isFloatingOrReal wrs_l
+ -> Nothing
+
+ -- Update the rreg commitments, and map the insn
+ | otherwise
+ -> case upd_commitment (wrs_l++rds_l)
+ vreg_map uncommitted_rregs of
+ Nothing -- out of rregs; give up
+ -> Nothing
+ Just (vreg_map2, uncommitted_rregs2)
+ -> let i2 = patchRegs i (subst_reg vreg_map2)
+ in trundle vreg_map2 uncommitted_rregs2
+ (i2:ris_done) is
+ where
+ isFloatingOrReal reg
+ = isRealReg reg || regClass reg == RcFloating
+
+ rds_l = regSetToList rds
+ wrs_l = regSetToList wrs
+
+ upd_commitment [] vr_map uncomm
+ = Just (vr_map, uncomm)
+ upd_commitment (reg:regs) vr_map uncomm
+ | isRealReg reg
+ = upd_commitment regs vr_map uncomm
+ | reg `elem` (map fst vr_map)
+ = upd_commitment regs vr_map uncomm
+ | null uncomm
+ = Nothing
+ | otherwise
+ = upd_commitment regs ((reg, head uncomm):vr_map)
+ (tail uncomm)
+
+ subst_reg vreg_map r
+ -- If it's a RealReg, it must be STG-specific one
+ -- (Hp,Sp,BaseReg,etc), since regUsage filters them out,
+ -- so isFloatingOrReal would not have objected to it.
+ | isRealReg r
+ = r
+ | otherwise
+ = case [rr | (vr,rr) <- vreg_map, vr == r] of
+ [rr2] -> rr2
+ other -> pprPanic
+ "doSimpleAlloc: unmapped VirtualReg"
+ (ppr r)
+ in
+ trundle [] available_iregs [] instrs
\end{code}
-Here is the ``clever'' bit. First go backward (i.e. left), looking for
-the last use of dynamic registers. Then go forward (i.e. right), filling
-registers with static placements.
-
-hairyRegAlloc takes reserve_regs as the regs to use as spill
+From here onwards is the general register allocator and spiller. For
+each flow edge (possible transition between instructions), we compute
+which virtual and real registers are live on that edge. Then the
+mapping is inverted, to give a mapping from register (virtual+real) to
+sets of flow edges on which the register is live. Finally, we can use
+those sets to decide whether a virtual reg v can be assigned to a real
+reg r, by checking that v's live-edge-set does not intersect with r's
+current live-edge-set. Having made that assignment, we then augment
+r's current live-edge-set (its current commitment, you could say) with
+v's live-edge-set.
+
+doGeneralAlloc takes reserve_regs as the regs to use as spill
temporaries. First it tries to allocate using all regs except
reserve_regs. If that fails, it inserts spill code and tries again to
allocate regs, but this time with the spill temporaries available.
Even this might not work if there are insufficient spill temporaries:
-in the worst case on x86, we'd need 3 of them, for insns like
-addl (reg1,reg2,4) reg3, since this insn uses all 3 regs as input.
+in the worst case on x86, we'd need 3 of them, for insns like addl
+(%reg1,%reg2,4) %reg3, since this insn uses all 3 regs as input.
\begin{code}
-hairyRegAlloc
- :: MRegsState
- -> [RegNo]
- -> [Instr]
- -> Maybe [Instr]
-
-hairyRegAlloc regs reserve_regs instrs =
- case mapAccumB (doRegAlloc reserve_regs)
- (RH regs' 1 emptyFM) noFuture instrs of
- (RH _ mloc1 _, _, instrs')
- -- succeeded w/out using reserves
- | mloc1 == 1 -> Just instrs'
- -- failed, and no reserves avail, so pointless to attempt spilling
- | null reserve_regs -> Nothing
- -- failed, but we have reserves, so attempt to do spilling
- | otherwise
- -> let instrs_patched = patchMem instrs'
- in
- case mapAccumB (doRegAlloc []) (RH regs'' mloc1 emptyFM)
- noFuture instrs_patched of
- ((RH _ mloc2 _),_,instrs'')
- -- successfully allocated the patched code
- | mloc2 == mloc1 -> maybetrace (spillMsg True) (Just instrs'')
- -- no; we have to give up
- | otherwise -> maybetrace (spillMsg False) Nothing
- -- instrs''
- where
- regs' = regs `useMRegs` reserve_regs
- regs'' = mkMRegsState reserve_regs
-
- noFuture :: RegFuture
- noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
-
- spillMsg success
- = "nativeGen: spilling "
- ++ (if success then "succeeded" else "failed ")
- ++ " using "
- ++ showSDoc (hsep (map (pprUserReg.toMappedReg)
- (reverse reserve_regs)))
- where
- toMappedReg (I# i) = MappedReg i
-#ifdef DEBUG
- maybetrace msg x = trace msg x
-#else
- maybetrace msg x = x
-#endif
-
+doGeneralAlloc
+ :: [Reg] -- all allocatable regs
+ -> [Reg] -- the reserve regs
+ -> [Instr] -- instrs in
+ -> Maybe [Instr] -- instrs out
+
+doGeneralAlloc all_regs reserve_regs instrs
+ -- succeeded without spilling
+ | prespill_ok = Just prespill_insns
+ -- failed, and no spill regs avail, so pointless to attempt spilling
+ | null reserve_regs = Nothing
+ -- success after spilling
+ | postspill_ok = maybetrace (spillMsg True) (Just postspill_insns)
+ -- still not enough reserves after spilling; we have to give up
+ | otherwise = maybetrace (spillMsg False) Nothing
+ where
+ prespill_regs
+ = filter (`notElem` reserve_regs) all_regs
+ (prespill_ok, prespill_insns)
+ = allocUsingTheseRegs instrs prespill_regs
+ instrs_with_spill_code
+ = insertSpillCode prespill_insns
+ (postspill_ok, postspill_insns)
+ = allocUsingTheseRegs instrs_with_spill_code all_regs
+
+ spillMsg success
+ = "nativeGen: spilling "
+ ++ (if success then "succeeded" else "failed ")
+ ++ " using "
+ ++ showSDoc (hsep (map ppr reserve_regs))
+
+# ifdef DEBUG
+ maybetrace msg x = trace msg x
+# else
+ maybetrace msg x = x
+# endif
\end{code}
Here we patch instructions that reference ``registers'' which are
sequences before any instructions that use memory registers as
sources, and we place the appropriate spill sequences after any
instructions that use memory registers as destinations. The offending
-instructions are rewritten with new dynamic registers, so we have to
-run register allocation again after all of this is said and done.
+instructions are rewritten with new dynamic registers, so generalAlloc
+has to run register allocation again after all of this is said and
+done.
On some architectures (x86, currently), we do without a frame-pointer,
and instead spill relative to the stack pointer (%esp on x86).
to be the same as the starting one (zero), reflecting the fact that
changes to the stack pointer should not extend beyond a basic block.
+Finally, there is the issue of mapping an arbitrary set of unallocated
+VirtualRegs into a contiguous sequence of spill slots. The failed
+allocation will have left the code peppered with references to
+VirtualRegs, each of which contains a unique. So we make an env which
+maps these VirtualRegs to integers, starting from zero, and pass that
+env through to loadReg and spillReg. There, they are used to look up
+spill slot numbers for the uniques.
+
\begin{code}
-patchMem :: [Instr] -> [Instr]
-patchMem cs
- = let (final_stack_delta, css) = mapAccumL patchMem' 0 cs
+insertSpillCode :: [Instr] -> [Instr]
+insertSpillCode insns
+ = let uniques_in_insns
+ = map getUnique
+ (regSetToList
+ (foldl unionRegSets emptyRegSet
+ (map vregs_in_insn insns)))
+ vregs_in_insn i
+ = case regUsage i of
+ RU rds wrs -> filterRegSet isVirtualReg
+ (rds `unionRegSets` wrs)
+ vreg_to_slot_map :: FiniteMap Unique Int
+ vreg_to_slot_map
+ = listToFM (zip uniques_in_insns [0..])
+
+ ((final_stack_delta, final_ctr), insnss)
+ = mapAccumL (patchInstr vreg_to_slot_map) (0,0) insns
in
if final_stack_delta == 0
- then concat css
+ then concat insnss
else pprPanic "patchMem: non-zero final delta"
(int final_stack_delta)
-patchMem' :: Int -> Instr -> (Int, [Instr])
-patchMem' delta instr
+
+-- patchInstr has as a running state two Ints, one the current stack delta,
+-- needed to figure out offsets to stack slots on archs where we spill relative
+-- to the stack pointer, as opposed to the frame pointer. The other is a
+-- counter, used to manufacture new temporary register names.
+
+patchInstr :: FiniteMap Unique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr])
+patchInstr vreg_to_slot_map (delta,ctr) instr
| null memSrcs && null memDsts
- = (delta', [instr])
+ = ((delta',ctr), [instr])
| otherwise
- = (delta', loadSrcs ++ [instr'] ++ spillDsts)
+ = ((delta',ctr'), loadSrcs ++ [instr'] ++ spillDsts)
where
delta' = case instr of DELTA d -> d ; _ -> delta
- (RU srcs dsts) = regUsage instr
-
- memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
- memToDyn other = other
-
- memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
- memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
-
- loadSrcs = map load memSrcs
+ (RU srcs dsts) = regUsage instr
+
+ -- The instr being patched may mention several vregs -- those which
+ -- could not be assigned real registers. For each such vreg, we
+ -- invent a new vreg, used only around this instruction and nowhere
+ -- else. These new vregs replace the unallocatable vregs; they are
+ -- loaded from the spill area, the instruction is done with them,
+ -- and results if any are then written back to the spill area.
+ vregs_in_instr
+ = nub (filter isVirtualReg
+ (regSetToList srcs ++ regSetToList dsts))
+ n_vregs_in_instr
+ = length vregs_in_instr
+ ctr'
+ = ctr + n_vregs_in_instr
+ vreg_env
+ = zip vregs_in_instr [ctr, ctr+1 ..]
+
+ mkTmpReg vreg
+ | isVirtualReg vreg
+ = case [vi | (vreg', vi) <- vreg_env, vreg' == vreg] of
+ [i] -> if regClass vreg == RcInteger
+ then VirtualRegI (mkPseudoUnique3 i)
+ else VirtualRegF (mkPseudoUnique3 i)
+ _ -> pprPanic "patchInstr: unmapped VReg" (ppr vreg)
+ | otherwise
+ = vreg
+
+ memSrcs = filter isVirtualReg (regSetToList srcs)
+ memDsts = filter isVirtualReg (regSetToList dsts)
+
+ loadSrcs = map load memSrcs
spillDsts = map spill memDsts
- load mem = loadReg delta mem (memToDyn mem)
- spill mem = spillReg delta' (memToDyn mem) mem
+ load mem = loadReg vreg_to_slot_map delta mem (mkTmpReg mem)
+ spill mem = spillReg vreg_to_slot_map delta' (mkTmpReg mem) mem
- instr' = patchRegs instr memToDyn
+ instr' = patchRegs instr mkTmpReg
\end{code}
+allocUsingTheseRegs is the register allocator proper. It attempts
+to allocate dynamic regs to real regs, given a list of real regs
+which it may use. If it fails due to lack of real regs, the returned
+instructions use what real regs there are, but will retain uses of
+dynamic regs for which a real reg could not be found. It is these
+leftover dynamic reg references which insertSpillCode will later
+assign to spill slots.
+
+Some implementation notes.
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instructions are numbered sequentially, starting at zero.
+
+A flow edge (FE) is a pair of insn numbers (MkFE Int Int) denoting
+a possible flow of control from the first insn to the second.
+
+The input to the register allocator is a list of instructions, which
+mention Regs. A Reg can be a RealReg -- a real machine reg -- or a
+VirtualReg, which carries a unique. After allocation, all the
+VirtualReg references will have been converted into RealRegs, and
+possible some spill code will have been inserted.
+
+The heart of the register allocator works in four phases.
+
+1. (find_flow_edges) Calculate all the FEs for the code list.
+ Return them not as a [FE], but implicitly, as a pair of
+ Array Int [Int], being the successor and predecessor maps
+ for instructions.
+
+2. (calc_liveness) Returns a FiniteMap FE RegSet. For each
+ FE, indicates the set of registers live on that FE. Note
+ that the set includes both RealRegs and VirtualRegs. The
+ former appear because the code could mention fixed register
+ usages, and we need to take them into account from the start.
+
+3. (calc_live_range_sets) Invert the above mapping, giving a
+ FiniteMap Reg FeSet, indicating, for each virtual and real
+ reg mentioned in the code, which FEs it is live on.
+
+4. (calc_vreg_to_rreg_mapping) For virtual reg, try and find
+ an allocatable real register for it. Each real register has
+ a "current commitment", indicating the set of FEs it is
+ currently live on. A virtual reg v can be assigned to
+ real reg r iff v's live-fe-set does not intersect with r's
+ current commitment fe-set. If the assignment is made,
+ v's live-fe-set is union'd into r's current commitment fe-set.
+ There is also the minor restriction that v and r must be of
+ the same register class (integer or floating).
+
+ Once this mapping is established, we simply apply it to the
+ input insns, and that's it.
+
+ If no suitable real register can be found, the vreg is mapped
+ to itself, and we deem allocation to have failed. The partially
+ allocated code is returned. The higher echelons of the allocator
+ (doGeneralAlloc and runRegAlloc) then cooperate to insert spill
+ code and re-run allocation, until a successful allocation is found.
\begin{code}
-doRegAlloc
- :: [RegNo]
- -> RegHistory MRegsState
- -> RegFuture
- -> Instr
- -> (RegHistory MRegsState, RegFuture, Instr)
-
-doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
- where
- (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
- (in_use', info) = getUsage in_use instr
-\end{code}
-\begin{code}
-getUsage
- :: RegFuture
- -> Instr
- -> (RegFuture, RegInfo Instr)
-
-getUsage (RF next_in_use future reg_conflicts) instr
- = (RF in_use' future' reg_conflicts',
- RI in_use' srcs dsts last_used reg_conflicts')
- where (RU srcs dsts) = regUsage instr
- (RL in_use future') = regLiveness instr (RL next_in_use future)
- live_through = in_use `minusRegSet` dsts
- last_used = [ r | r <- regSetToList srcs,
- not (r `elementOfRegSet` (fstFL future)
- || r `elementOfRegSet` in_use)]
-
- in_use' = srcs `unionRegSets` live_through
-
- reg_conflicts' =
- case new_conflicts of
- [] -> reg_conflicts
- _ -> addListToFM reg_conflicts new_conflicts
-
- new_conflicts
- | isEmptyRegSet live_dynamics = []
- | otherwise =
- [ (r, merge_conflicts r)
- | r <- extractMappedRegNos (regSetToList dsts) ]
-
- merge_conflicts reg =
- case lookupFM reg_conflicts reg of
- Nothing -> live_dynamics
- Just conflicts -> conflicts `unionRegSets` live_dynamics
-
- live_dynamics
- = mkRegSet [ r | r@(UnmappedReg _ _)
- <- regSetToList live_through ]
-
-doRegAlloc'
- :: [RegNo]
- -> RegHistory MRegsState
- -> RegInfo Instr
- -> Instr
- -> (RegHistory MRegsState, Instr)
-
-doRegAlloc' reserved (RH frs loc env)
- (RI in_use srcs dsts lastu conflicts) instr =
-
- (RH frs'' loc' env'', patchRegs instr dynToStatic)
-
- where
-
- -- free up new registers
- free :: [RegNo]
- free = extractMappedRegNos (map dynToStatic lastu)
-
- -- (1) free registers that are used last as
- -- source operands in this instruction
- frs_not_in_use = frs `useMRegs`
- (extractMappedRegNos (regSetToList in_use))
- frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
-
- -- (2) allocate new registers for the destination operands
- -- allocate registers for new dynamics
-
- new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts,
- r `not_elem` keysFM env ]
-
- (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
-
- env' = addListToFM env new
-
- env'' = delListFromFM env' lastu
-
- dynToStatic :: Reg -> Reg
- dynToStatic dyn@(UnmappedReg _ _) =
- case lookupFM env' dyn of
- Just r -> r
- Nothing -> trace ("Lost register; possibly a floating point"
- ++" type error in a _ccall_?") dyn
- dynToStatic other = other
-
- allocateNewRegs :: Reg
- -> (MRegsState, Int, [(Reg, Reg)])
- -> (MRegsState, Int, [(Reg, Reg)])
-
- allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst)
- = (fs', mem', (d, f) : lst)
- where
- (fs', f, mem') =
- case acceptable fs of
- [] -> (fs, MemoryReg mem pk, mem + 1)
- (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
-
- acceptable regs = filter no_conflict (possibleMRegs pk regs)
-
- no_conflict reg =
- case lookupFM conflicts reg of
- Nothing -> True
- Just conflicts -> not (d `elementOfRegSet` conflicts)
-\end{code}
+allocUsingTheseRegs :: [Instr] -> [Reg] -> (Bool, [Instr])
+allocUsingTheseRegs instrs available_real_regs
+ = let (all_vregs_mapped, v_to_r_mapping)
+ = calc_vreg_to_rreg_mapping instrs available_real_regs
+ new_insns
+ = map (flip patchRegs sr) instrs
+ sr reg
+ | isRealReg reg
+ = reg
+ | otherwise
+ = case lookupFM v_to_r_mapping reg of
+ Just r -> r
+ Nothing -> pprPanic "allocateUsingTheseRegs: unmapped vreg: "
+ (ppr reg)
+ in
+ --trace ("allocUsingTheseRegs: " ++ show available_real_regs) (
+ (all_vregs_mapped, new_insns)
+ --)
+
+
+-- the heart of the matter.
+calc_vreg_to_rreg_mapping :: [Instr] -> [Reg] -> (Bool, FiniteMap Reg Reg)
+calc_vreg_to_rreg_mapping insns available_real_regs
+ = let
+ lr_sets :: FiniteMap Reg FeSet
+ lr_sets = calc_live_range_sets insns
+
+ -- lr_sets maps: vregs mentioned in insns to sets of live FEs
+ -- and also: rregs mentioned in insns to sets of live FEs
+ -- We need to extract the rreg mapping, and use it as the
+ -- initial real-register-commitment. Also, add to the initial
+ -- commitment, empty commitments for any real regs not
+ -- mentioned in it.
+
+ -- which real regs do we want to keep track of in the running
+ -- commitment mapping? Precisely the available_real_regs.
+ -- We don't care about real regs mentioned by insns which are
+ -- not in this list, since we're not allocating to them.
+ initial_rr_commitment :: FiniteMap Reg FeSet
+ initial_rr_commitment
+ = listToFM [(rreg,
+ case lookupFM lr_sets rreg of
+ Nothing -> emptyFeSet
+ Just fixed_use_fes -> fixed_use_fes
+ )
+ | rreg <- available_real_regs]
+
+ -- These are the vregs for which we actually have to (try to)
+ -- assign a real register. (ie, the whole reason we're here at all :)
+ vreg_liveness_list :: [(Reg, FeSet)]
+ vreg_liveness_list = filter (not.isRealReg.fst)
+ (fmToList lr_sets)
+
+ -- A loop, which attempts to assign each vreg to a rreg.
+ loop rr_commitment v_to_r_map []
+ = v_to_r_map
+ loop rr_commitment v_to_r_map ((vreg,vreg_live_fes):not_yet_done)
+ = let
+ -- find a real reg which is not live for any of vreg_live_fes
+ cand_reals
+ = [rreg
+ | (rreg,rreg_live_FEs) <- fmToList rr_commitment,
+ regClass vreg == regClass rreg,
+ isEmptyFeSet (intersectionFeSets rreg_live_FEs
+ vreg_live_fes)
+ ]
+ in
+ case cand_reals of
+ [] -> -- bummer. No register is available. Just go on to
+ -- the next vreg, mapping the vreg to itself.
+ loop rr_commitment (addToFM v_to_r_map vreg vreg)
+ not_yet_done
+ (r:_)
+ -> -- Hurrah! Found a free reg of the right class.
+ -- Now we need to update the RR commitment.
+ loop rr_commitment2 (addToFM v_to_r_map vreg r)
+ not_yet_done
+ where
+ rr_commitment2
+ = addToFM_C unionFeSets rr_commitment r
+ vreg_live_fes
+
+ -- the final vreg to rreg mapping
+ vreg_assignment
+ = loop initial_rr_commitment emptyFM vreg_liveness_list
+ -- did we succeed in mapping everyone to a real reg?
+ allocation_succeeded
+ = all isRealReg (eltsFM vreg_assignment)
+ in
+ (allocation_succeeded, vreg_assignment)
+
+
+
+-- calculate liveness, then produce the live range info
+-- as a mapping of VRegs to the set of FEs on which they are live.
+-- The difficult part is inverting the mapping of Reg -> FeSet
+-- to produce a mapping FE -> RegSet.
+
+calc_live_range_sets :: [Instr] -> FiniteMap Reg FeSet
+calc_live_range_sets insns
+ = let
+ -- this is the "original" (old) mapping
+ lis :: FiniteMap FE RegSet
+ lis = calc_liveness insns
+
+ -- establish the totality of reg names mentioned by the
+ -- insns, by scanning over the insns.
+ all_mentioned_regs :: RegSet
+ all_mentioned_regs
+ = foldl unionRegSets emptyRegSet
+ (map (\i -> case regUsage i of
+ RU rds wrs -> unionRegSets rds wrs)
+ insns)
+
+ -- Initial inverted mapping, from Reg to sets of FEs
+ initial_imap :: FiniteMap Reg FeSet
+ initial_imap
+ = listToFM [(reg, emptyFeSet)
+ | reg <- regSetToList all_mentioned_regs]
+
+ -- Update the new map with one element of the old map
+ upd_imap :: FiniteMap Reg FeSet -> (FE, RegSet)
+ -> FiniteMap Reg FeSet
+ upd_imap imap (fe, regset)
+ = foldl upd_1_imap imap (regSetToList regset)
+ where
+ upd_1_imap curr reg
+ = addToFM_C unionFeSets curr reg (unitFeSet fe)
+
+ -- the complete inverse mapping
+ final_imap :: FiniteMap Reg FeSet
+ final_imap
+ = foldl upd_imap initial_imap (fmToList lis)
+ in
+ final_imap
+
+
+
+-- Given the insns, calculate the FEs, and then doing fixpointing to
+-- figure out the set of live regs (virtual regs AND real regs) live
+-- on each FE.
+
+calc_liveness :: [Instr] -> FiniteMap FE RegSet
+calc_liveness insns
+ = let (pred_map, succ_map)
+ = find_flow_edges insns
+
+ -- We use the convention that if the current approximation
+ -- doesn't give a mapping for some FE, that FE maps to the
+ -- empty set.
+ initial_approx, fixpoint :: FiniteMap FE RegSet
+ initial_approx
+ = mk_initial_approx 0 insns succ_map emptyFM
+ fixpoint
+ = fix_set initial_approx 1
+ -- If you want to live dangerously, and promise that the code
+ -- doesn't contain any loops (ie, there are no back edges in
+ -- the flow graph), you should be able to get away with this:
+ -- = upd_liveness_info pred_map succ_map insn_array initial_approx
+ -- But since I'm paranoid, and since it hardly makes any difference
+ -- to the compiler run-time (about 0.1%), I prefer to do the
+ -- the full fixpointing game.
+
+ insn_array
+ = let n = length insns
+ in array (0, n-1) (zip [0..] insns)
+
+ sameSets [] [] = True
+ sameSets (c:cs) (n:ns) = eqRegSets c n && sameSets cs ns
+ sameSets _ _ = False
+
+ fix_set curr_approx iter_number
+ = let next_approx
+ = upd_liveness_info pred_map succ_map insn_array curr_approx
+ curr_sets
+ = eltsFM curr_approx
+ next_sets
+ = eltsFM next_approx
+ same
+ = sameSets curr_sets next_sets
+ final_approx
+ = if same then curr_approx
+ else fix_set next_approx (iter_number+1)
+ in
+ --trace (let qqq (fe, regset)
+ -- = show fe ++ " " ++ show (regSetToList regset)
+ -- in
+ -- "\n::iteration " ++ show iter_number ++ "\n"
+ -- ++ (unlines . map qqq . fmToList)
+ -- next_approx ++"\n"
+ -- )
+ final_approx
+ in
+ fixpoint
+
+
+-- Create a correct initial approximation. For each instruction that
+-- writes a register, we deem that the register is live on the
+-- flow edges leaving the instruction. Subsequent iterations of
+-- the liveness AbI augment this based purely on reads of regs, not
+-- writes. We need to start off with at least this minimal write-
+-- based information in order that writes to vregs which are never
+-- used have non-empty live ranges. If we don't do that, we eventually
+-- wind up assigning such vregs to any old real reg, since they don't
+-- apparently conflict -- you can't conflict with an empty live range.
+-- This kludge is unfortunate, but we need to do it to cover not only
+-- writes to vregs which are never used, but also to deal correctly
+-- with the fact that calls to C will trash the callee saves registers.
+
+mk_initial_approx :: Int -> [Instr] -> Array Int [Int]
+ -> FiniteMap FE RegSet
+ -> FiniteMap FE RegSet
+mk_initial_approx ino [] succ_map ia_so_far
+ = ia_so_far
+mk_initial_approx ino (i:is) succ_map ia_so_far
+ = let wrs
+ = case regUsage i of RU rrr www -> www
+ new_fes
+ = [case ino of { I# inoh ->
+ case ino_succ of { I# ino_succh ->
+ MkFE inoh ino_succh
+ }}
+ | ino_succ <- succ_map ! ino]
+
+ loop [] ia = ia
+ loop (fe:fes) ia
+ = loop fes (addToFM_C unionRegSets ia fe wrs)
+
+ next_ia
+ = loop new_fes ia_so_far
+ in
+ mk_initial_approx (ino+1) is succ_map next_ia
+
+
+-- Do one step in the liveness info calculation (AbI :). Given the
+-- prior approximation (which tells you a subset of live VRegs+RRegs
+-- for each flow edge), calculate new information for all FEs.
+-- Rather than do this by iterating over FEs, it's easier to iterate
+-- over insns, and update their incoming FEs.
+
+upd_liveness_info :: Array Int [Int] -- instruction pred map
+ -> Array Int [Int] -- instruction succ map
+ -> Array Int Instr -- array of instructions
+ -> FiniteMap FE RegSet -- previous approx
+ -> FiniteMap FE RegSet -- improved approx
+
+upd_liveness_info pred_map succ_map insn_array prev_approx
+ = do_insns hi prev_approx
+ where
+ (lo, hi) = bounds insn_array
+
+ enquireMapFE :: FiniteMap FE RegSet -> FE
+ -> RegSet
+ enquireMapFE fm fe
+ = case lookupFM fm fe of
+ Just set -> set
+ Nothing -> emptyRegSet
+
+ -- Work backwards, from the highest numbered insn to the lowest.
+ -- This is a heuristic which causes faster convergence to the
+ -- fixed point. In particular, for straight-line code with no
+ -- branches at all, arrives at the fixpoint in one iteration.
+ do_insns ino approx
+ | ino < lo
+ = approx
+ | otherwise
+ = let fes_to_futures
+ = [case ino of { I# inoh ->
+ case future_ino of { I# future_inoh ->
+ MkFE inoh future_inoh
+ }}
+ | future_ino <- succ_map ! ino]
+ future_lives
+ = map (enquireMapFE approx) fes_to_futures
+ future_live
+ = foldr unionRegSets emptyRegSet future_lives
+
+ fes_from_histories
+ = [case history_ino of { I# history_inoh ->
+ case ino of { I# inoh ->
+ MkFE history_inoh inoh
+ }}
+ | history_ino <- pred_map ! ino]
+ new_approx
+ = foldl update_one_history approx fes_from_histories
+
+ insn
+ = insn_array ! ino
+ history_independent_component
+ = case regUsage insn of
+ RU rds wrs
+ -> unionRegSets rds
+ (minusRegSets future_live wrs)
+
+ update_one_history :: FiniteMap FE RegSet
+ -> FE
+ -> FiniteMap FE RegSet
+ update_one_history approx0 fe
+ = addToFM_C unionRegSets approx0 fe
+ history_independent_component
+
+ rest_done
+ = do_insns (ino-1) new_approx
+ in
+ rest_done
+
+
+
+-- Extract the flow edges from a list of insns. Express the information
+-- as two mappings, from insn number to insn numbers of predecessors,
+-- and from insn number to insn numbers of successors. (Since that's
+-- what we need to know when computing live ranges later). Instructions
+-- are numbered starting at zero. This function is long and complex
+-- in order to be efficient; it could equally well be shorter and slower.
+
+find_flow_edges :: [Instr] -> (Array Int [Int],
+ Array Int [Int])
+find_flow_edges insns
+ = let
+ -- First phase: make a temp env which maps labels
+ -- to insn numbers, so the second pass can know the insn
+ -- numbers for jump targets.
+
+ label_env :: FiniteMap CLabel Int
+
+ mk_label_env n env [] = env
+ mk_label_env n env ((LABEL clbl):is)
+ = mk_label_env (n+1) (addToFM env clbl n) is
+ mk_label_env n env (i:is)
+ = mk_label_env (n+1) env is
+
+ label_env = mk_label_env 0 emptyFM insns
+
+ find_label :: CLabel -> Int
+ find_label jmptarget
+ = case lookupFM label_env jmptarget of
+ Just ino -> ino
+ Nothing -> pprPanic "find_flow_edges: unmapped label"
+ (pprCLabel jmptarget)
+
+ -- Second phase: traverse the insns, and make up the successor map.
+
+ least_ino, greatest_ino :: Int
+ least_ino = 0
+ greatest_ino = length insns - 1
+
+ mk_succ_map :: Int -> [(Int, [Int])] -> [Instr] -> [(Int, [Int])]
+
+ mk_succ_map i_num rsucc_map []
+ = reverse rsucc_map
+
+ mk_succ_map i_num rsucc_map (i:is)
+ = let i_num_1 = i_num + 1
+ in
+ case insnFuture i of
+
+ NoFuture
+ -> -- A non-local jump. We can regard this insn as a terminal
+ -- insn in the graph, so we don't add any edges.
+ mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is
+
+ Next
+ | null is -- this is the last insn, and it doesn't go anywhere
+ -- (a meaningless scenario); handle it anyway
+ -> mk_succ_map i_num_1 ((i_num,[]):rsucc_map) is
+
+ | otherwise -- flows to next insn; add fe i_num -> i_num+1
+ -> mk_succ_map i_num_1 ((i_num, [i_num_1]): rsucc_map)
+ is
+
+ Branch lab -- jmps to lab; add fe i_num -> i_target
+ -> let i_target = find_label lab
+ in
+ mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map)
+ is
+ NextOrBranch lab
+ | null is -- jmps to label, or falls through, and this is
+ -- the last insn (a meaningless scenario);
+ -- flag an error
+ -> error "find_flow_edges: NextOrBranch is last"
+
+ | otherwise -- add fes i_num -> i_num+1
+ -- and i_num -> i_target
+ -> let i_target = find_label lab
+ in
+ mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map)
+ is
+
+ -- Third phase: invert the successor map to get the predecessor
+ -- map, using an algorithm which is quadratic in the worst case,
+ -- but runs in almost-linear time, because of the nature of our
+ -- inputs: most insns have a single successor, the next insn.
+
+ invert :: [(Int, [Int])] -> [(Int, [Int])]
+ invert fmap
+ = let inverted_pairs
+ = concatMap ( \ (a, bs) -> [(b,a) | b <- bs] ) fmap
+ sorted_inverted_pairs
+ = isort inverted_pairs
+
+ grp :: Int -> [Int] -> [(Int,Int)] -> [(Int,[Int])]
+ grp k vs [] = [(k, vs)]
+ grp k vs ((kk,vv):rest)
+ | k == kk = grp k (vv:vs) rest
+ | otherwise = (k,vs) : grp kk [vv] rest
+
+ grp_start [] = []
+ grp_start ((kk,vv):rest) = grp kk [vv] rest
+
+ grouped
+ = grp_start sorted_inverted_pairs
+
+ -- make sure that the reverse mapping maps all inos
+ add_empties ino []
+ | ino > greatest_ino = []
+ | otherwise = (ino,[]): add_empties (ino+1) []
+ add_empties ino ((k,vs):rest)
+ | ino < k = (ino,[]): add_empties (ino+1) ((k,vs):rest)
+ | ino == k = (k,vs) : add_empties (ino+1) rest
+
+ -- This is nearly linear provided that the fsts of the
+ -- list are nearly in order -- a critical assumption
+ -- for efficiency.
+ isort :: [(Int,Int)] -> [(Int,Int)]
+ isort [] = []
+ isort (x:xs) = insert x (isort xs)
+
+ insert :: (Int,Int) -> [(Int,Int)] -> [(Int,Int)]
+ insert y [] = [y]
+ insert y (z:zs)
+ -- specifically, this first test should almost always
+ -- be True in order for the near-linearity to happen
+ | fst y <= fst z = y:z:zs
+ | otherwise = z: insert y zs
+ in
+ add_empties least_ino grouped
+
+ -- Finally ...
+
+ succ_list
+ = mk_succ_map 0 [] insns
+ succ_map
+ = array (least_ino, greatest_ino) succ_list
+ pred_list
+ = invert succ_list
+ pred_map
+ = array (least_ino, greatest_ino) pred_list
+ in
+ (pred_map, succ_map)
+
+
+-- That's all, folks! From here on is just some dull supporting stuff.
+
+-- A data type for flow edges
+data FE
+ = MkFE Int# Int# deriving (Eq, Ord)
+
+-- deriving Show on types with unboxed fields doesn't work
+instance Show FE where
+ showsPrec _ (MkFE s d)
+ = showString "MkFE" . shows (I# s) . shows ' ' . shows (I# d)
+
+-- Blargh. Use ghc stuff soon! Or: perhaps that's not such a good
+-- idea. Most of these sets are either empty or very small, and it
+-- might be that the overheads of the FiniteMap based set implementation
+-- is a net loss. The same might be true of RegSets.
+
+newtype FeSet = MkFeSet [FE]
+
+feSetFromList xs
+ = MkFeSet (nukeDups (sort xs))
+ where nukeDups :: [FE] -> [FE]
+ nukeDups [] = []
+ nukeDups [x] = [x]
+ nukeDups (x:y:xys)
+ = if x == y then nukeDups (y:xys)
+ else x : nukeDups (y:xys)
+
+feSetToList (MkFeSet xs) = xs
+isEmptyFeSet (MkFeSet xs) = null xs
+emptyFeSet = MkFeSet []
+eqFeSet (MkFeSet xs1) (MkFeSet xs2) = xs1 == xs2
+unitFeSet x = MkFeSet [x]
+
+elemFeSet x (MkFeSet xs)
+ = f xs
+ where
+ f [] = False
+ f (y:ys) | x == y = True
+ | x < y = False
+ | otherwise = f ys
+
+unionFeSets (MkFeSet xs1) (MkFeSet xs2)
+ = MkFeSet (f xs1 xs2)
+ where
+ f [] bs = bs
+ f as [] = as
+ f (a:as) (b:bs)
+ | a < b = a : f as (b:bs)
+ | a > b = b : f (a:as) bs
+ | otherwise = a : f as bs
+
+minusFeSets (MkFeSet xs1) (MkFeSet xs2)
+ = MkFeSet (f xs1 xs2)
+ where
+ f [] bs = []
+ f as [] = as
+ f (a:as) (b:bs)
+ | a < b = a : f as (b:bs)
+ | a > b = f (a:as) bs
+ | otherwise = f as bs
+
+intersectionFeSets (MkFeSet xs1) (MkFeSet xs2)
+ = MkFeSet (f xs1 xs2)
+ where
+ f [] bs = []
+ f as [] = []
+ f (a:as) (b:bs)
+ | a < b = f as (b:bs)
+ | a > b = f (a:as) bs
+ | otherwise = a : f as bs
-We keep a local copy of the Prelude function \tr{notElem},
-so that it can be specialised. (Hack me gently. [WDP 94/11])
-\begin{code}
-not_elem x [] = True
-not_elem x (y:ys) = x /= y && not_elem x ys
\end{code}
module MachRegs (
- Reg(..),
+ RegClass(..), regClass,
+ Reg(..), isRealReg, isVirtualReg,
+ allocatableRegs,
+
Imm(..),
MachRegsAddr(..),
RegLoc(..),
- RegNo,
addrOffset,
- argRegs,
baseRegOffset,
- callClobberedRegs,
callerSaves,
- extractMappedRegNos,
- mappedRegNo,
- freeMappedRegs,
- freeReg, freeRegs,
+ freeReg,
getNewRegNCG,
+ mkVReg,
magicIdRegMaybe,
- mkReg,
- realReg,
saveLoc,
spRel,
stgReg,
import AbsCUtils ( magicIdPrimRep )
import CLabel ( CLabel, mkMainRegTableLabel )
import PrimOp ( PrimOp(..) )
-import PrimRep ( PrimRep(..) )
+import PrimRep ( PrimRep(..), isFloatingRep )
import Stix ( StixTree(..), StixReg(..),
getUniqueNat, returnNat, thenNat, NatM )
-import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
- Uniquable(..), Unique
- )
---import UniqSupply ( getUniqueUs, returnUs, thenUs, UniqSM )
+import Unique ( mkPseudoUnique2, Uniquable(..), Unique )
import Outputable
\end{code}
%* *
%************************************************************************
-Static Registers correspond to actual machine registers. These should
-be avoided until the last possible moment.
+RealRegs are machine regs which are available for allocation, in the
+usual way. We know what class they are, because that's part of the
+processor's architecture.
+
+VirtualRegs are virtual registers. The register allocator will
+eventually have to map them into RealRegs, or into spill slots.
+VirtualRegs are allocated on the fly, usually to represent a single
+value in the abstract assembly code (i.e. dynamic registers are
+usually single assignment). With the new register allocator, the
+single assignment restriction isn't necessary to get correct code,
+although a better register allocation will result if single assignment
+is used -- because the allocator maps a VirtualReg into a single
+RealReg, even if the VirtualReg has multiple live ranges.
-Dynamic registers are allocated on the fly, usually to represent a single
-value in the abstract assembly code (i.e. dynamic registers are usually
-single assignment). Ultimately, they are mapped to available machine
-registers before spitting out the code.
+Virtual regs can be of either class, so that info is attached.
\begin{code}
-data Reg
- = FixedReg FAST_INT -- A pre-allocated machine register
- | MappedReg FAST_INT -- A dynamically allocated machine register
+data RegClass
+ = RcInteger
+ | RcFloating
+ deriving Eq
+
+data Reg
+ = RealReg Int
+ | VirtualRegI Unique
+ | VirtualRegF Unique
- | MemoryReg Int PrimRep -- A machine "register" actually held in
- -- a memory allocated table of
- -- registers which didn't fit in real
- -- registers.
+mkVReg :: Unique -> PrimRep -> Reg
+mkVReg u pk
+ = if isFloatingRep pk then VirtualRegF u else VirtualRegI u
- | UnmappedReg Unique PrimRep -- One of an infinite supply of registers,
- -- always mapped to one of the earlier
- -- two (?) before we're done.
-mkReg :: Unique -> PrimRep -> Reg
-mkReg = UnmappedReg
+isVirtualReg (RealReg _) = False
+isVirtualReg (VirtualRegI _) = True
+isVirtualReg (VirtualRegF _) = True
+isRealReg = not . isVirtualReg
getNewRegNCG :: PrimRep -> NatM Reg
getNewRegNCG pk
- = getUniqueNat `thenNat` \ u ->
- returnNat (UnmappedReg u pk)
-
-instance Show Reg where
- showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i)
- showsPrec _ (MappedReg i) = showString "%" . shows IBOX(i)
- showsPrec _ (MemoryReg i _) = showString "%M" . shows i
- showsPrec _ (UnmappedReg i _) = showString "%U" . shows i
-
-#ifdef DEBUG
-instance Outputable Reg where
- ppr r = text (show r)
-#endif
-
-cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
-cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i'
-cmpReg (MemoryReg i _) (MemoryReg i' _) = i `compare` i'
-cmpReg (UnmappedReg u _) (UnmappedReg u' _) = compare u u'
-cmpReg r1 r2
- = let tag1 = tagReg r1
- tag2 = tagReg r2
- in
- if tag1 _LT_ tag2 then LT else GT
- where
- tagReg (FixedReg _) = (ILIT(1) :: FAST_INT)
- tagReg (MappedReg _) = ILIT(2)
- tagReg (MemoryReg _ _) = ILIT(3)
- tagReg (UnmappedReg _ _) = ILIT(4)
-
-cmp_ihash :: FAST_INT -> FAST_INT -> Ordering
-cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ else if a1 _LT_ a2 then LT else GT
+ = if isFloatingRep pk
+ then getUniqueNat `thenNat` \ u -> returnNat (VirtualRegF u)
+ else getUniqueNat `thenNat` \ u -> returnNat (VirtualRegI u)
instance Eq Reg where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+ (==) (RealReg i1) (RealReg i2) = i1 == i2
+ (==) (VirtualRegI u1) (VirtualRegI u2) = u1 == u2
+ (==) (VirtualRegF u1) (VirtualRegF u2) = u1 == u2
+ (==) reg1 reg2 = False
instance Ord Reg where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare a b = cmpReg a b
-
-instance Uniquable Reg where
- getUnique (UnmappedReg u _) = u
- getUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
- getUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
- getUnique (MemoryReg i _) = mkPseudoUnique3 i
-\end{code}
-
-\begin{code}
-type RegNo = Int
+ compare (RealReg i1) (RealReg i2) = compare i1 i2
+ compare (RealReg _) (VirtualRegI _) = LT
+ compare (RealReg _) (VirtualRegF _) = LT
+ compare (VirtualRegI _) (RealReg _) = GT
+ compare (VirtualRegI u1) (VirtualRegI u2) = compare u1 u2
+ compare (VirtualRegI _) (VirtualRegF _) = LT
+ compare (VirtualRegF _) (RealReg _) = GT
+ compare (VirtualRegF _) (VirtualRegI _) = GT
+ compare (VirtualRegF u1) (VirtualRegF u2) = compare u1 u2
-realReg :: RegNo -> Reg
-realReg n@IBOX(i)
- = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i
-
-extractMappedRegNos :: [Reg] -> [RegNo]
+instance Show Reg where
+ showsPrec _ (RealReg i) = showString (showReg i)
+ showsPrec _ (VirtualRegI u) = showString "%vI_" . shows u
+ showsPrec _ (VirtualRegF u) = showString "%vF_" . shows u
-extractMappedRegNos regs
- = foldr ex [] regs
- where
- ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it
- ex _ acc = acc -- leave it out
+instance Outputable Reg where
+ ppr r = text (show r)
-mappedRegNo :: Reg -> RegNo
-mappedRegNo (MappedReg i) = IBOX(i)
-mappedRegNo _ = pprPanic "mappedRegNo" empty
+instance Uniquable Reg where
+ getUnique (RealReg i) = mkPseudoUnique2 i
+ getUnique (VirtualRegI u) = u
+ getUnique (VirtualRegF u) = u
\end{code}
** Machine-specific Reg stuff: **
\begin{code}
#if i386_TARGET_ARCH
-gReg,fReg :: Int -> Int
-gReg x = x
-fReg x = (8 + x)
-
-fake0, fake1, fake2, fake3, fake4, fake5, eax, ebx, ecx, edx, esp :: Reg
-eax = realReg (gReg 0)
-ebx = realReg (gReg 1)
-ecx = realReg (gReg 2)
-edx = realReg (gReg 3)
-esi = realReg (gReg 4)
-edi = realReg (gReg 5)
-ebp = realReg (gReg 6)
-esp = realReg (gReg 7)
-fake0 = realReg (fReg 0)
-fake1 = realReg (fReg 1)
-fake2 = realReg (fReg 2)
-fake3 = realReg (fReg 3)
-fake4 = realReg (fReg 4)
-fake5 = realReg (fReg 5)
+fake0, fake1, fake2, fake3, fake4, fake5,
+ eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg
+eax = RealReg 0
+ebx = RealReg 1
+ecx = RealReg 2
+edx = RealReg 3
+esi = RealReg 4
+edi = RealReg 5
+ebp = RealReg 6
+esp = RealReg 7
+fake0 = RealReg 8
+fake1 = RealReg 9
+fake2 = RealReg 10
+fake3 = RealReg 11
+fake4 = RealReg 12
+fake5 = RealReg 13
+
+regClass (RealReg i) = if i < 8 then RcInteger else RcFloating
+regClass (VirtualRegI u) = RcInteger
+regClass (VirtualRegF u) = RcFloating
+
+regNames
+ = ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp",
+ "%fake0", "%fake1", "%fake2", "%fake3", "%fake4", "%fake5", "%fake6"]
+showReg n
+ = if n >= 0 && n < 14
+ then regNames !! n
+ else "%unknown_x86_real_reg_" ++ show n
+
#endif
\end{code}
magicIdRegMaybe :: MagicId -> Maybe Reg
#ifdef REG_Base
-magicIdRegMaybe BaseReg = Just (FixedReg ILIT(REG_Base))
+magicIdRegMaybe BaseReg = Just (RealReg REG_Base)
#endif
#ifdef REG_R1
-magicIdRegMaybe (VanillaReg _ ILIT(1)) = Just (FixedReg ILIT(REG_R1))
+magicIdRegMaybe (VanillaReg _ ILIT(1)) = Just (RealReg REG_R1)
#endif
#ifdef REG_R2
-magicIdRegMaybe (VanillaReg _ ILIT(2)) = Just (FixedReg ILIT(REG_R2))
+magicIdRegMaybe (VanillaReg _ ILIT(2)) = Just (RealReg REG_R2)
#endif
#ifdef REG_R3
-magicIdRegMaybe (VanillaReg _ ILIT(3)) = Just (FixedReg ILIT(REG_R3))
+magicIdRegMaybe (VanillaReg _ ILIT(3)) = Just (RealReg REG_R3)
#endif
#ifdef REG_R4
-magicIdRegMaybe (VanillaReg _ ILIT(4)) = Just (FixedReg ILIT(REG_R4))
+magicIdRegMaybe (VanillaReg _ ILIT(4)) = Just (RealReg REG_R4)
#endif
#ifdef REG_R5
-magicIdRegMaybe (VanillaReg _ ILIT(5)) = Just (FixedReg ILIT(REG_R5))
+magicIdRegMaybe (VanillaReg _ ILIT(5)) = Just (RealReg REG_R5)
#endif
#ifdef REG_R6
-magicIdRegMaybe (VanillaReg _ ILIT(6)) = Just (FixedReg ILIT(REG_R6))
+magicIdRegMaybe (VanillaReg _ ILIT(6)) = Just (RealReg REG_R6)
#endif
#ifdef REG_R7
-magicIdRegMaybe (VanillaReg _ ILIT(7)) = Just (FixedReg ILIT(REG_R7))
+magicIdRegMaybe (VanillaReg _ ILIT(7)) = Just (RealReg REG_R7)
#endif
#ifdef REG_R8
-magicIdRegMaybe (VanillaReg _ ILIT(8)) = Just (FixedReg ILIT(REG_R8))
+magicIdRegMaybe (VanillaReg _ ILIT(8)) = Just (RealReg REG_R8)
#endif
#ifdef REG_R9
-magicIdRegMaybe (VanillaReg _ ILIT(9)) = Just (FixedReg ILIT(REG_R9))
+magicIdRegMaybe (VanillaReg _ ILIT(9)) = Just (RealReg REG_R9)
#endif
#ifdef REG_R10
-magicIdRegMaybe (VanillaReg _ ILIT(10)) = Just (FixedReg ILIT(REG_R10))
+magicIdRegMaybe (VanillaReg _ ILIT(10)) = Just (RealReg REG_R10)
#endif
#ifdef REG_F1
-magicIdRegMaybe (FloatReg ILIT(1)) = Just (FixedReg ILIT(REG_F1))
+magicIdRegMaybe (FloatReg ILIT(1)) = Just (RealReg REG_F1)
#endif
#ifdef REG_F2
-magicIdRegMaybe (FloatReg ILIT(2)) = Just (FixedReg ILIT(REG_F2))
+magicIdRegMaybe (FloatReg ILIT(2)) = Just (RealReg REG_F2)
#endif
#ifdef REG_F3
-magicIdRegMaybe (FloatReg ILIT(3)) = Just (FixedReg ILIT(REG_F3))
+magicIdRegMaybe (FloatReg ILIT(3)) = Just (RealReg REG_F3)
#endif
#ifdef REG_F4
-magicIdRegMaybe (FloatReg ILIT(4)) = Just (FixedReg ILIT(REG_F4))
+magicIdRegMaybe (FloatReg ILIT(4)) = Just (RealReg REG_F4)
#endif
#ifdef REG_D1
-magicIdRegMaybe (DoubleReg ILIT(1)) = Just (FixedReg ILIT(REG_D1))
+magicIdRegMaybe (DoubleReg ILIT(1)) = Just (RealReg REG_D1)
#endif
#ifdef REG_D2
-magicIdRegMaybe (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_D2))
+magicIdRegMaybe (DoubleReg ILIT(2)) = Just (RealReg REG_D2)
#endif
#ifdef REG_Sp
-magicIdRegMaybe Sp = Just (FixedReg ILIT(REG_Sp))
+magicIdRegMaybe Sp = Just (RealReg REG_Sp)
#endif
#ifdef REG_Lng1
-magicIdRegMaybe (LongReg _ ILIT(1)) = Just (FixedReg ILIT(REG_Lng1))
+magicIdRegMaybe (LongReg _ ILIT(1)) = Just (RealReg REG_Lng1)
#endif
#ifdef REG_Lng2
-magicIdRegMaybe (LongReg _ ILIT(2)) = Just (FixedReg ILIT(REG_Lng2))
+magicIdRegMaybe (LongReg _ ILIT(2)) = Just (RealReg REG_Lng2)
#endif
#ifdef REG_Su
-magicIdRegMaybe Su = Just (FixedReg ILIT(REG_Su))
+magicIdRegMaybe Su = Just (RealReg REG_Su)
#endif
#ifdef REG_SpLim
-magicIdRegMaybe SpLim = Just (FixedReg ILIT(REG_SpLim))
+magicIdRegMaybe SpLim = Just (RealReg REG_SpLim)
#endif
#ifdef REG_Hp
-magicIdRegMaybe Hp = Just (FixedReg ILIT(REG_Hp))
+magicIdRegMaybe Hp = Just (RealReg REG_Hp)
#endif
#ifdef REG_HpLim
-magicIdRegMaybe HpLim = Just (FixedReg ILIT(REG_HpLim))
+magicIdRegMaybe HpLim = Just (RealReg REG_HpLim)
#endif
#ifdef REG_CurrentTSO
-magicIdRegMaybe CurrentTSO = Just (FixedReg ILIT(REG_CurrentTSO))
+magicIdRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO)
#endif
#ifdef REG_CurrentNursery
-magicIdRegMaybe CurrentNursery = Just (FixedReg ILIT(REG_CurrentNursery))
+magicIdRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery)
#endif
magicIdRegMaybe _ = Nothing
\end{code}
\begin{code}
-------------------------------
+#if 0
freeRegs :: [Reg]
freeRegs
= freeMappedRegs IF_ARCH_alpha( [0..63],
IF_ARCH_i386( [0..13],
IF_ARCH_sparc( [0..63],)))
+#endif
+-- allMachRegs is the complete set of machine regs.
+allMachRegNos :: [Int]
+allMachRegNos
+ = IF_ARCH_alpha( [0..63],
+ IF_ARCH_i386( [0..13],
+ IF_ARCH_sparc( [0..63],)))
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+allocatableRegs :: [Reg]
+allocatableRegs
+ = let isFree (RealReg (I# i)) = _IS_TRUE_(freeReg i)
+ in filter isFree (map RealReg allMachRegNos)
+
-------------------------------
+#if 0
callClobberedRegs :: [Reg]
callClobberedRegs
= freeMappedRegs
[gReg i | i <- [1..7]] ++
[fReg i | i <- [0..31]] )
#endif {- sparc_TARGET_ARCH -}
+#endif
-------------------------------
+#if 0
argRegs :: Int -> [Reg]
argRegs 0 = []
#endif {- sparc_TARGET_ARCH -}
argRegs _ = panic "MachRegs.argRegs: don't know about >6 arguments!"
#endif {- i386_TARGET_ARCH -}
+#endif
-------------------------------
+#if 0
#if alpha_TARGET_ARCH
allArgRegs :: [(Reg, Reg)]
allArgRegs = map realReg [oReg i | i <- [0..5]]
#endif {- sparc_TARGET_ARCH -}
-
--------------------------------
-freeMappedRegs :: [Int] -> [Reg]
-
-freeMappedRegs nums
- = foldr free [] nums
- where
- free IBOX(i) acc
- = if _IS_TRUE_(freeReg i) then (MappedReg i) : acc else acc
+#endif
\end{code}
\begin{code}
#include "nativeGen/NCG.h"
module RegAllocInfo (
- MRegsState(..),
- mkMRegsState,
- freeMReg,
- freeMRegs,
- possibleMRegs,
- useMReg,
- useMRegs,
-
RegUsage(..),
noUsage,
- endUsage,
regUsage,
+ InsnFuture(..),
+ insnFuture,
- FutureLive(..),
- RegAssignment,
- RegConflicts,
- RegFuture(..),
- RegHistory(..),
- RegInfo(..),
- RegLiveness(..),
-
- fstFL,
loadReg,
patchRegs,
- regLiveness,
spillReg,
findReservedRegs,
RegSet,
- elementOfRegSet,
- emptyRegSet,
- isEmptyRegSet,
- minusRegSet,
- mkRegSet,
- regSetToList,
- unionRegSets,
-
- argRegSet,
- callClobberedRegSet,
- freeRegSet
+ regSetFromList,
+ regSetToList,
+ isEmptyRegSet,
+ emptyRegSet,
+ eqRegSets,
+ filterRegSet,
+ unitRegSet,
+ elemRegSet,
+ unionRegSets,
+ minusRegSets,
+ intersectionRegSets
) where
#include "HsVersions.h"
-import List ( partition )
+import List ( partition, sort )
import OrdList ( unitOL )
import MachMisc
import MachRegs
import MachCode ( InstrBlock )
import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet )
-import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} )
+import CLabel ( pprCLabel_asm, isAsmTemp, CLabel{-instance Ord-} )
import FiniteMap ( addToFM, lookupFM, FiniteMap )
import PrimRep ( PrimRep(..) )
import UniqSet -- quite a bit of it
import Outputable
import Constants ( rESERVED_C_STACK_BYTES )
+import Unique ( Unique, Uniquable(..) )
\end{code}
%************************************************************************
%* *
-\subsection{Register allocation information}
+\subsection{Sets of registers}
%* *
%************************************************************************
\begin{code}
-type RegSet = UniqSet Reg
-
-mkRegSet :: [Reg] -> RegSet
-emptyRegSet :: RegSet
-unionRegSets, minusRegSet :: RegSet -> RegSet -> RegSet
-elementOfRegSet :: Reg -> RegSet -> Bool
-isEmptyRegSet :: RegSet -> Bool
-regSetToList :: RegSet -> [Reg]
-
-mkRegSet = mkUniqSet
-emptyRegSet = emptyUniqSet
-unionRegSets = unionUniqSets
-minusRegSet = minusUniqSet
-elementOfRegSet = elementOfUniqSet
-isEmptyRegSet = isEmptyUniqSet
-regSetToList = uniqSetToList
-
-freeRegSet, callClobberedRegSet :: RegSet
-argRegSet :: Int -> RegSet
-
-freeRegSet = mkRegSet freeRegs
-callClobberedRegSet = mkRegSet callClobberedRegs
-argRegSet n = mkRegSet (argRegs n)
-
-type RegAssignment = FiniteMap Reg Reg
-type RegConflicts = FiniteMap Int RegSet
-
-data FutureLive = FL RegSet (FiniteMap CLabel RegSet)
-
-fstFL (FL a b) = a
-
-data RegHistory a
- = RH a
- Int
- RegAssignment
-
-data RegFuture
- = RF RegSet -- in use
- FutureLive -- future
- RegConflicts
-
-data RegInfo a
- = RI RegSet -- in use
- RegSet -- sources
- RegSet -- destinations
- [Reg] -- last used
- RegConflicts
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Register allocation information}
-%* *
-%************************************************************************
-
-COMMENT ON THE EXTRA BitSet FOR SPARC MRegsState: Getting the conflicts
-right is a bit tedious for doubles. We'd have to add a conflict
-function to the MachineRegisters class, and we'd have to put a PrimRep
-in the MappedReg datatype, or use some kludge (e.g. register 64 + n is
-really the same as 32 + n, except that it's used for a double, so it
-also conflicts with 33 + n) to deal with it. It's just not worth the
-bother, so we just partition the free floating point registers into
-two sets: one for single precision and one for double precision. We
-never seem to run out of floating point registers anyway.
-
-\begin{code}
-data MRegsState
- = MRs BitSet -- integer registers
- BitSet -- floating-point registers
- IF_ARCH_sparc(BitSet,) -- double registers handled separately
-\end{code}
-
-\begin{code}
-#if alpha_TARGET_ARCH
-# define INT_FLPT_CUTOFF 32
-#endif
-#if i386_TARGET_ARCH
-# define INT_FLPT_CUTOFF 8
-#endif
-#if sparc_TARGET_ARCH
-# define INT_FLPT_CUTOFF 32
-# define SNGL_DBL_CUTOFF 48
-#endif
-
-mkMRegsState :: [RegNo] -> MRegsState
-possibleMRegs :: PrimRep -> MRegsState -> [RegNo]
-useMReg :: MRegsState -> FAST_REG_NO -> MRegsState
-useMRegs :: MRegsState -> [RegNo] -> MRegsState
-freeMReg :: MRegsState -> FAST_REG_NO -> MRegsState
-freeMRegs :: MRegsState -> [RegNo] -> MRegsState
-
-mkMRegsState xs
- = MRs (mkBS is) (mkBS fs2) IF_ARCH_sparc((mkBS ds2),)
- where
- (is, fs) = partition (< INT_FLPT_CUTOFF) xs
-#if sparc_TARGET_ARCH
- (ss, ds) = partition (< SNGL_DBL_CUTOFF) fs
- fs2 = map (subtract INT_FLPT_CUTOFF) ss
- ds2 = map (subtract INT_FLPT_CUTOFF) (filter even ds)
-#else
- fs2 = map (subtract INT_FLPT_CUTOFF) fs
-#endif
-
-------------------------------------------------
-#if sparc_TARGET_ARCH
-possibleMRegs FloatRep (MRs _ ss _) = [ x + INT_FLPT_CUTOFF | x <- listBS ss]
-possibleMRegs DoubleRep (MRs _ _ ds) = [ x + INT_FLPT_CUTOFF | x <- listBS ds]
-possibleMRegs _ (MRs is _ _) = listBS is
-#else
-possibleMRegs FloatRep (MRs _ fs) = [ x + INT_FLPT_CUTOFF | x <- listBS fs]
-possibleMRegs DoubleRep (MRs _ fs) = [ x + INT_FLPT_CUTOFF | x <- listBS fs]
-possibleMRegs _ (MRs is _) = listBS is
-#endif
-
-------------------------------------------------
-#if sparc_TARGET_ARCH
-useMReg (MRs is ss ds) n
- = if (n _LT_ ILIT(INT_FLPT_CUTOFF)) then
- MRs (is `minusBS` unitBS IBOX(n)) ss ds
- else if (n _LT_ ILIT(SNGL_DBL_CUTOFF)) then
- MRs is (ss `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) ds
- else
- MRs is ss (ds `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF))))
-#else
-useMReg (MRs is fs) n
- = if (n _LT_ ILIT(INT_FLPT_CUTOFF))
- then MRs (is `minusBS` unitBS IBOX(n)) fs
- else MRs is (fs `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF))))
-#endif
-
-------------------------------------------------
-#if sparc_TARGET_ARCH
-useMRegs (MRs is ss ds) xs
- = MRs (is `minusBS` is2) (ss `minusBS` ss2) (ds `minusBS` ds2)
- where
- MRs is2 ss2 ds2 = mkMRegsState xs
-#else
-useMRegs (MRs is fs) xs
- = MRs (is `minusBS` is2) (fs `minusBS` fs2)
- where
- MRs is2 fs2 = mkMRegsState xs
-#endif
-
-------------------------------------------------
-#if sparc_TARGET_ARCH
-freeMReg (MRs is ss ds) n
- = if (n _LT_ ILIT(INT_FLPT_CUTOFF)) then
- MRs (is `unionBS` unitBS IBOX(n)) ss ds
- else if (n _LT_ ILIT(SNGL_DBL_CUTOFF)) then
- MRs is (ss `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) ds
- else
- MRs is ss (ds `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF))))
-#else
-freeMReg (MRs is fs) n
- = if (n _LT_ ILIT(INT_FLPT_CUTOFF))
- then MRs (is `unionBS` unitBS IBOX(n)) fs
- else MRs is (fs `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF))))
-#endif
-------------------------------------------------
-#if sparc_TARGET_ARCH
-freeMRegs (MRs is ss ds) xs
- = MRs (is `unionBS` is2) (ss `unionBS` ss2) (ds `unionBS` ds2)
- where
- MRs is2 ss2 ds2 = mkMRegsState xs
-#else
-freeMRegs (MRs is fs) xs
- = MRs (is `unionBS` is2) (fs `unionBS` fs2)
- where
- MRs is2 fs2 = mkMRegsState xs
-#endif
+-- Blargh. Use ghc stuff soon! Or: perhaps that's not such a good
+-- idea. Most of these sets are either empty or very small, and it
+-- might be that the overheads of the FiniteMap based set implementation
+-- is a net loss. The same might be true of FeSets.
+
+newtype RegSet = MkRegSet [Reg]
+
+regSetFromList xs
+ = MkRegSet (nukeDups (sort xs))
+ where nukeDups :: [Reg] -> [Reg]
+ nukeDups [] = []
+ nukeDups [x] = [x]
+ nukeDups (x:y:xys)
+ = if x == y then nukeDups (y:xys)
+ else x : nukeDups (y:xys)
+
+regSetToList (MkRegSet xs) = xs
+isEmptyRegSet (MkRegSet xs) = null xs
+emptyRegSet = MkRegSet []
+eqRegSets (MkRegSet xs1) (MkRegSet xs2) = xs1 == xs2
+unitRegSet x = MkRegSet [x]
+filterRegSet p (MkRegSet xs) = MkRegSet (filter p xs)
+
+elemRegSet x (MkRegSet xs)
+ = f xs
+ where
+ f [] = False
+ f (y:ys) | x == y = True
+ | x < y = False
+ | otherwise = f ys
+
+unionRegSets (MkRegSet xs1) (MkRegSet xs2)
+ = MkRegSet (f xs1 xs2)
+ where
+ f [] bs = bs
+ f as [] = as
+ f (a:as) (b:bs)
+ | a < b = a : f as (b:bs)
+ | a > b = b : f (a:as) bs
+ | otherwise = a : f as bs
+
+minusRegSets (MkRegSet xs1) (MkRegSet xs2)
+ = MkRegSet (f xs1 xs2)
+ where
+ f [] bs = []
+ f as [] = as
+ f (a:as) (b:bs)
+ | a < b = a : f as (b:bs)
+ | a > b = f (a:as) bs
+ | otherwise = f as bs
+
+intersectionRegSets (MkRegSet xs1) (MkRegSet xs2)
+ = MkRegSet (f xs1 xs2)
+ where
+ f [] bs = []
+ f as [] = []
+ f (a:as) (b:bs)
+ | a < b = f as (b:bs)
+ | a > b = f (a:as) bs
+ | otherwise = a : f as bs
\end{code}
%************************************************************************
particular instruction. Machine registers that are pre-allocated to
stgRegs are filtered out, because they are uninteresting from a
register allocation standpoint. (We wouldn't want them to end up on
-the free list!)
+the free list!) As far as we are concerned, the fixed registers
+simply don't exist (for allocation purposes, anyway).
-An important point: The @regUsage@ function for a particular
-assembly language must not refer to fixed registers, such as Hp, SpA,
-etc. The source and destination MRegsStates should only refer to
-dynamically allocated registers or static registers from the free
-list. As far as we are concerned, the fixed registers simply don't
-exist (for allocation purposes, anyway).
+regUsage doesn't need to do any trickery for jumps and such. Just
+state precisely the regs read and written by that insn. The
+consequences of control flow transfers, as far as register allocation
+goes, are taken care of by @insnFuture@.
\begin{code}
data RegUsage = RU RegSet RegSet
-noUsage, endUsage :: RegUsage
+noUsage :: RegUsage
noUsage = RU emptyRegSet emptyRegSet
-endUsage = RU emptyRegSet freeRegSet
regUsage :: Instr -> RegUsage
CMP sz src dst -> mkRU (use_R src ++ use_R dst) []
SETCC cond op -> mkRU [] (def_W op)
JXX cond lbl -> mkRU [] []
- JMP op -> mkRU (use_R op) freeRegs
+ JMP op -> mkRU (use_R op) []
CALL imm -> mkRU [] callClobberedRegs
CLTD -> mkRU [eax] [edx]
NOP -> mkRU [] []
use_EA (AddrBaseIndex Nothing (Just (i,_)) _) = [i]
use_EA (AddrBaseIndex (Just b) (Just (i,_)) _) = [b,i]
- mkRU src dst = RU (mkRegSet (filter interesting src))
- (mkRegSet (filter interesting dst))
+ mkRU src dst = RU (regSetFromList (filter interesting src))
+ (regSetFromList (filter interesting dst))
- interesting (FixedReg _) = False
- interesting _ = True
+ interesting (VirtualRegI _) = True
+ interesting (VirtualRegF _) = True
+ interesting (RealReg (I# i)) = _IS_TRUE_(freeReg i)
--- Allow the spiller to decide whether or not it can use
--- %edx as spill temporaries.
+-- Allow the spiller to de\cide whether or not it can use
+-- %edx as a spill temporary.
hasFixedEDX instr
= case instr of
IDIV _ _ -> True
a singleton list which we know will satisfy all spill demands.
\begin{code}
-findReservedRegs :: [Instr] -> [[RegNo]]
+findReservedRegs :: [Instr] -> [[Reg]]
findReservedRegs instrs
#if alpha_TARGET_ARCH
= --[[NCG_Reserved_I1, NCG_Reserved_I2,
= ecx : if any hasFixedEDX instrs then [] else [edx]
possibilities
= case intregs_avail of
- [i1] -> [ [], [i1], [f1], [i1,f1], [f1,f2], [i1,f1,f2] ]
+ [i1] -> [ [], [i1], [f1], [i1,f1], [f1,f2],
+ [i1,f1,f2] ]
[i1,i2] -> [ [], [i1], [f1], [i1,i2], [i1,f1], [f1,f2],
[i1,i2,f1], [i1,f1,f2], [i1,i2,f1,f2] ]
in
- map (map mappedRegNo) possibilities
+ possibilities
#endif
\end{code}
%************************************************************************
%* *
-\subsection{@RegLiveness@ type; @regLiveness@ function}
+\subsection{@InsnFuture@ type; @insnFuture@ function}
%* *
%************************************************************************
-@regLiveness@ takes future liveness information and modifies it
-according to the semantics of branches and labels. (An out-of-line
-branch clobbers the liveness passed back by the following instruction;
-a forward local branch passes back the liveness from the target label;
-a conditional branch merges the liveness from the target and the
-liveness from its successor; a label stashes away the current liveness
-in the future liveness environment).
+@insnFuture@ indicates the places we could get to following the
+current instruction. This is used by the register allocator to
+compute the flow edges for a bunch of instructions.
\begin{code}
-data RegLiveness = RL RegSet FutureLive
+data InsnFuture
+ = NoFuture -- makes a non-local jump; for the purposes of
+ -- register allocation, it exits our domain
+ | Next -- falls through to next insn
+ | Branch CLabel -- unconditional branch to the label
+ | NextOrBranch CLabel -- conditional branch to the label
-regLiveness :: Instr -> RegLiveness -> RegLiveness
+--instance Outputable InsnFuture where
+-- ppr NoFuture = text "NoFuture"
+-- ppr Next = text "Next"
+-- ppr (Branch clbl) = text "(Branch " <> ppr clbl <> char ')'
+-- ppr (NextOrBranch clbl) = text "(NextOrBranch " <> ppr clbl <> char ')'
-regLiveness instr info@(RL live future@(FL all env))
- = let
- lookup lbl
- = case (lookupFM env lbl) of
- Just rs -> rs
- Nothing -> pprTrace "Missing" (pprCLabel_asm lbl <+> text "in future?")
- emptyRegSet
- in
- case instr of -- the rest is machine-specific...
+
+insnFuture insn
+ = case insn of
#if alpha_TARGET_ARCH
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
- JXX _ lbl -> RL (lookup lbl `unionRegSets` live) future
- JMP _ -> RL emptyRegSet future
- CALL _ -> RL live future
- LABEL lbl -> RL live (FL (all `unionRegSets` live) (addToFM env lbl live))
- _ -> info
+ -- conditional jump
+ JXX _ clbl | isAsmTemp clbl -> NextOrBranch clbl
+ JXX _ _ -> panic "insnFuture: conditional jump to non-local label"
+
+ -- unconditional jump to local label
+ JMP (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> Branch clbl
+
+ -- unconditional jump to non-local label
+ JMP lbl -> NoFuture
+
+ boring -> Next
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
= pprPanic "spillSlotToOffset:"
(text "invalid spill location: " <> int slot)
-spillReg, loadReg :: Int -> Reg -> Reg -> Instr
+vregToSpillSlot :: FiniteMap Unique Int -> Unique -> Int
+vregToSpillSlot vreg_to_slot_map u
+ = case lookupFM vreg_to_slot_map u of
+ Just xx -> xx
+ Nothing -> pprPanic "vregToSpillSlot: unmapped vreg" (ppr u)
+
+
+spillReg, loadReg :: FiniteMap Unique Int -> Int -> Reg -> Reg -> Instr
-spillReg delta dyn (MemoryReg i pk)
- = let sz = primRepToSize pk
- off = spillSlotToOffset i
+spillReg vreg_to_slot_map delta dyn vreg
+ | isVirtualReg vreg
+ = let slot_no = vregToSpillSlot vreg_to_slot_map (getUnique vreg)
+ off = spillSlotToOffset slot_no
in
{-Alpha: spill below the stack pointer (?)-}
IF_ARCH_alpha( ST sz dyn (spRel (- (off `div` 8)))
{-I386: spill above stack pointer leaving 3 words/spill-}
,IF_ARCH_i386 ( let off_w = (off-delta) `div` 4
in
- if pk == FloatRep || pk == DoubleRep
+ if regClass vreg == RcFloating
then GST F80 dyn (spRel off_w)
- else MOV sz (OpReg dyn) (OpAddr (spRel off_w))
+ else MOV L (OpReg dyn) (OpAddr (spRel off_w))
{-SPARC: spill below frame pointer leaving 2 words/spill-}
,IF_ARCH_sparc( ST sz dyn (fpRel (- (off `div` 4)))
,)))
-loadReg delta (MemoryReg i pk) dyn
- = let sz = primRepToSize pk
- off = spillSlotToOffset i
+loadReg vreg_to_slot_map delta vreg dyn
+ | isVirtualReg vreg
+ = let slot_no = vregToSpillSlot vreg_to_slot_map (getUnique vreg)
+ off = spillSlotToOffset slot_no
in
IF_ARCH_alpha( LD sz dyn (spRel (- (off `div` 8)))
,IF_ARCH_i386 ( let off_w = (off-delta) `div` 4
in
- if pk == FloatRep || pk == DoubleRep
+ if regClass vreg == RcFloating
then GLD F80 (spRel off_w) dyn
- else MOV sz (OpAddr (spRel off_w)) (OpReg dyn)
+ else MOV L (OpAddr (spRel off_w)) (OpReg dyn)
,IF_ARCH_sparc( LD sz (fpRel (- (off `div` 4))) dyn
,)))
\end{code}
projects / ghc-hetmet.git / commitdiff