%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1998
%
+\section[AsmRegAlloc]{Register allocator}
\begin{code}
-#include "HsVersions.h"
-#include "../../includes/platform.h"
-#include "../../includes/GhcConstants.h"
-
-module AsmRegAlloc (
- FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..),
- MachineRegisters(..), MachineCode(..),
-
- mkReg, runRegAllocate,
- extractMappedRegNos,
-
- -- And, for self-sufficiency
- CLabel, OrdList, PrimKind, UniqSet(..), UniqFM,
- FiniteMap, Unique
- ) where
+module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
-IMPORT_Trace
+#include "HsVersions.h"
-import CLabelInfo ( CLabel )
-import FiniteMap
-import MachDesc
-import Maybes ( maybeToBool, Maybe(..) )
-import OrdList -- ( mkUnitList, mkSeqList, mkParList, OrdList )
+import MachCode ( InstrBlock )
+import MachMisc ( Instr(..) )
+import PprMach ( pprUserReg ) -- debugging
+import MachRegs
+import RegAllocInfo
+
+import FiniteMap ( emptyFM, addListToFM, delListFromFM,
+ lookupFM, keysFM )
+import Maybes ( maybeToBool )
+import Unique ( mkBuiltinUnique )
+import Util ( mapAccumB )
+import OrdList ( unitOL, appOL, fromOL, concatOL )
import Outputable
-import Pretty
-import PrimKind ( PrimKind(..) )
-import UniqSet
-import Unique
-import Util
-
-#if ! OMIT_NATIVE_CODEGEN
-
-#if sparc_TARGET_ARCH
-import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing
-
-{-# SPECIALIZE
- runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr]
- #-}
-#endif
-#if alpha_TARGET_ARCH
-import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing
-
-{-# SPECIALIZE
- runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr]
- #-}
-#endif
-
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Reg]{Real registers}
-%* *
-%************************************************************************
-
-Static Registers correspond to actual machine registers. These should
-be avoided until the last possible moment.
-
-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.
-
-\begin{code}
-
-data Reg = FixedReg FAST_INT -- A pre-allocated machine register
-
- | MappedReg FAST_INT -- A dynamically allocated machine register
-
- | MemoryReg Int PrimKind -- A machine "register" actually held in a memory
- -- allocated table of registers which didn't fit
- -- in real registers.
-
- | UnmappedReg Unique PrimKind -- One of an infinite supply of registers,
- -- always mapped to one of the earlier two
- -- before we're done.
- -- No thanks: deriving (Eq)
-
-mkReg :: Unique -> PrimKind -> Reg
-mkReg = UnmappedReg
-
-instance Text 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 sty r = ppStr (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' _) = cmp_i i i'
-cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmpUnique 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_i :: Int -> Int -> TAG_
-cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_
-
-cmp_ihash :: FAST_INT -> FAST_INT -> TAG_
-cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_
-
-instance Eq Reg where
- a == b = case cmpReg a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpReg a b of { EQ_ -> False; _ -> True }
-
-instance Ord Reg where
- a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
-#ifdef __GLASGOW_HASKELL__
- _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-
-instance NamedThing Reg where
- -- the *only* method that should be defined is "getTheUnique"!
- -- (so we can use UniqFMs/UniqSets on Regs
- getTheUnique (UnmappedReg u _) = u
- getTheUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
- getTheUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
- getTheUnique (MemoryReg i _) = mkPseudoUnique3 i
+import List ( mapAccumL )
\end{code}
This is the generic register allocator.
-%************************************************************************
-%* *
-\subsection[RegPlace]{Map Stix registers to {\em real} registers}
-%* *
-%************************************************************************
-
-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
-lists 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).
-
-\begin{code}
-
-class MachineRegisters a where
- mkMRegs :: [Int] -> a
- possibleMRegs :: PrimKind -> a -> [Int]
- useMReg :: a -> FAST_INT -> a
- useMRegs :: a -> [Int] -> a
- freeMReg :: a -> FAST_INT -> a
- freeMRegs :: a -> [Int] -> a
-
-type RegAssignment = FiniteMap Reg Reg
-type RegConflicts = FiniteMap Int (UniqSet Reg)
-
-data FutureLive
- = FL (UniqSet Reg)
- (FiniteMap CLabel (UniqSet Reg))
-fstFL (FL a b) = a
-
-data RegHistory a
- = RH a
- Int
- RegAssignment
-
-data RegFuture
- = RF (UniqSet Reg) -- in use
- FutureLive -- future
- RegConflicts
-
-data RegInfo a
- = RI (UniqSet Reg) -- in use
- (UniqSet Reg) -- sources
- (UniqSet Reg) -- destinations
- [Reg] -- last used
- RegConflicts
-
-data RegUsage
- = RU (UniqSet Reg)
- (UniqSet Reg)
-
-data RegLiveness
- = RL (UniqSet Reg)
- FutureLive
-
-class MachineCode a where
--- OLD:
--- flatten :: OrdList a -> [a]
- regUsage :: a -> RegUsage
- regLiveness :: a -> RegLiveness -> RegLiveness
- patchRegs :: a -> (Reg -> Reg) -> a
- spillReg :: Reg -> Reg -> OrdList a
- loadReg :: Reg -> Reg -> OrdList a
-
-\end{code}
-
-First we try something extremely simple.
-If that fails, we have to do things the hard way.
+First we try something extremely simple. If that fails, we have to do
+things the hard way.
\begin{code}
-
runRegAllocate
- :: (MachineRegisters a, MachineCode b)
- => a
- -> [Int]
- -> (OrdList b)
- -> [b]
-
-runRegAllocate regs reserve_regs instrs =
- case simpleAlloc of
- Just x -> x
- Nothing -> hairyAlloc
+ :: MRegsState
+ -> ([Instr] -> [[RegNo]])
+ -> InstrBlock
+ -> [Instr]
+
+runRegAllocate regs find_reserve_regs instrs
+ = case simpleAlloc of
+ Just simple -> simple
+ Nothing -> tryHairy reserves
where
- flatInstrs = flattenOrdList instrs
- simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
- hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs
-
+ tryHairy []
+ = error "nativeGen: spilling failed. Try -fvia-C.\n"
+ tryHairy (resv:resvs)
+ = case hairyAlloc resv of
+ Just success -> success
+ Nothing -> tryHairy 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
\end{code}
Here is the simple register allocator. Just dole out registers until
we generate.
\begin{code}
-
simpleRegAlloc
- :: (MachineRegisters a, MachineCode b)
- => a -- registers to select from
+ :: MRegsState -- registers to select from
-> [Reg] -- live static registers
-> RegAssignment -- mapping of dynamics to statics
- -> [b] -- code
- -> Maybe [b]
+ -> [Instr] -- code
+ -> Maybe [Instr]
simpleRegAlloc _ _ _ [] = Just []
-simpleRegAlloc free live env (instr:instrs) =
- if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
- Just (instr3 : instrs3)
- else
- Nothing
+
+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 -> (uniqSetToList s, uniqSetToList d) }
+ (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}
+ 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]
instrs3 = case instrs2 of Just x -> x
allocateNewReg
- :: MachineRegisters a
- => Reg
- -> Maybe (a, [(Reg, Reg)])
- -> Maybe (a, [(Reg, Reg)])
+ :: Reg
+ -> Maybe (MRegsState, [(Reg, Reg)])
+ -> Maybe (MRegsState, [(Reg, Reg)])
allocateNewReg _ Nothing = Nothing
- allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) =
- if null choices then Nothing
- else Just (free2, prs2)
+ 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)
-
+ reg = head choices
+ free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
+ prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
\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.
-\begin{code}
+hairyRegAlloc 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.
+\begin{code}
hairyRegAlloc
- :: (MachineRegisters a, MachineCode b)
- => a
- -> [Int]
- -> [b]
- -> [b]
+ :: MRegsState
+ -> [RegNo]
+ -> [Instr]
+ -> Maybe [Instr]
hairyRegAlloc regs reserve_regs instrs =
- case mapAccumB (doRegAlloc reserve_regs)
- (RH regs' 1 emptyFM) noFuture instrs
- of (RH _ loc' _, _, instrs') ->
- if loc' == 1 then instrs' else
- case mapAccumB do_RegAlloc_Nil
- (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs'))
- of ((RH _ loc'' _),_,instrs'') ->
- if loc'' == loc' then instrs'' else panic "runRegAllocate"
+ 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 -> trace (spillMsg True) (Just instrs'')
+ -- no; we have to give up
+ | otherwise -> trace (spillMsg False) Nothing
+ -- instrs''
where
- regs' = regs `useMRegs` reserve_regs
- regs'' = mkMRegs reserve_regs `asTypeOf` regs
-
-do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
-do_RegAlloc_Nil
- :: (MachineRegisters a, MachineCode b)
- => RegHistory a
- -> RegFuture
- -> b
- -> (RegHistory a, RegFuture, b)
-
-noFuture :: RegFuture
-noFuture = RF emptyUniqSet (FL emptyUniqSet emptyFM) emptyFM
+ 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
\end{code}
-Here we patch instructions that reference ``registers'' which are really in
-memory somewhere (the mapping is under the control of the machine-specific
-code generator). We place the appropriate load 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.
+Here we patch instructions that reference ``registers'' which are
+really in memory somewhere (the mapping is under the control of the
+machine-specific code generator). We place the appropriate load
+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.
+
+On some architectures (x86, currently), we do without a frame-pointer,
+and instead spill relative to the stack pointer (%esp on x86).
+Because the stack pointer may move, the patcher needs to keep track of
+the current stack pointer "delta". That's easy, because all it needs
+to do is spot the DELTA bogus-insns which will have been inserted by
+the relevant insn selector precisely so as to notify the spiller of
+stack-pointer movement. The delta is passed to loadReg and spillReg,
+since they generate the actual spill code. We expect the final delta
+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.
\begin{code}
+patchMem :: [Instr] -> [Instr]
+patchMem cs
+ = let (final_stack_delta, css) = mapAccumL patchMem' 0 cs
+ in
+ if final_stack_delta == 0
+ then concat css
+ else pprPanic "patchMem: non-zero final delta"
+ (int final_stack_delta)
+
+patchMem' :: Int -> Instr -> (Int, [Instr])
+patchMem' delta instr
+
+ | null memSrcs && null memDsts
+ = (delta', [instr])
+
+ | otherwise
+ = (delta', loadSrcs ++ [instr'] ++ spillDsts)
+ where
+ delta' = case instr of DELTA d -> d ; _ -> delta
-patchMem
- :: MachineCode a
- => [a]
- -> OrdList a
-
-patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
-
-patchMem'
- :: MachineCode a
- => a
- -> OrdList a
-
-patchMem' instr =
- if null memSrcs && null memDsts then mkUnitList instr
- else mkSeqList
- (foldr mkParList mkEmptyList loadSrcs)
- (mkSeqList instr'
- (foldr mkParList mkEmptyList spillDsts))
-
- where
(RU srcs dsts) = regUsage instr
memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
memToDyn other = other
- memSrcs = [ r | r@(MemoryReg _ _) <- uniqSetToList srcs]
- memDsts = [ r | r@(MemoryReg _ _) <- uniqSetToList dsts]
+ memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
+ memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
- loadSrcs = map load memSrcs
+ loadSrcs = map load memSrcs
spillDsts = map spill memDsts
- load mem = loadReg mem (memToDyn mem)
- spill mem = spillReg (memToDyn mem) mem
-
- instr' = mkUnitList (patchRegs instr memToDyn)
+ load mem = loadReg delta mem (memToDyn mem)
+ spill mem = spillReg delta' (memToDyn mem) mem
+ instr' = patchRegs instr memToDyn
\end{code}
\begin{code}
-
doRegAlloc
- :: (MachineRegisters a, MachineCode b)
- => [Int]
- -> RegHistory a
+ :: [RegNo]
+ -> RegHistory MRegsState
-> RegFuture
- -> b
- -> (RegHistory a, RegFuture, b)
+ -> 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
- :: MachineCode a
- => RegFuture
- -> a
- -> (RegFuture, RegInfo a)
+ :: RegFuture
+ -> Instr
+ -> (RegFuture, RegInfo Instr)
-getUsage (RF next_in_use future reg_conflicts) instr =
- (RF in_use' future' reg_conflicts',
+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 `minusUniqSet` dsts
- last_used = [ r | r <- uniqSetToList srcs,
- not (r `elementOfUniqSet` (fstFL future) || r `elementOfUniqSet` in_use)]
- in_use' = srcs `unionUniqSets` live_through
- reg_conflicts' = case new_conflicts of
- [] -> reg_conflicts
- _ -> addListToFM reg_conflicts new_conflicts
- new_conflicts = if isEmptyUniqSet live_dynamics then []
- else [ (r, merge_conflicts r)
- | r <- extractMappedRegNos (uniqSetToList dsts) ]
- merge_conflicts reg = case lookupFM reg_conflicts reg of
- Nothing -> live_dynamics
- Just conflicts -> conflicts `unionUniqSets` live_dynamics
- live_dynamics = mkUniqSet
- [ r | r@(UnmappedReg _ _) <- uniqSetToList live_through ]
+ 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'
- :: (MachineRegisters a, MachineCode b)
- => [Int]
- -> RegHistory a
- -> RegInfo b
- -> b
- -> (RegHistory a, b)
+ :: [RegNo]
+ -> RegHistory MRegsState
+ -> RegInfo Instr
+ -> Instr
+ -> (RegHistory MRegsState, Instr)
-doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) 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 :: [Int]
+ 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 (uniqSetToList in_use))
+ -- (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 _ _) <- uniqSetToList dsts, r `not_elem` keysFM env ]
+ new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts,
+ r `not_elem` keysFM env ]
(frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
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
+ Nothing -> trace ("Lost register; possibly a floating point"
+ ++" type error in a _ccall_?") dyn
dynToStatic other = other
- allocateNewRegs
- :: MachineRegisters a
- => Reg -> (a, Int, [(Reg, Reg)]) -> (a, 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)
+ allocateNewRegs :: Reg
+ -> (MRegsState, Int, [(Reg, Reg)])
+ -> (MRegsState, Int, [(Reg, Reg)])
- acceptable regs = filter no_conflict (possibleMRegs pk regs)
- no_conflict reg = case lookupFM conflicts reg of
- Nothing -> True
- Just conflicts -> not (d `elementOfUniqSet` conflicts)
-\end{code}
+ 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)
-\begin{code}
-extractMappedRegNos :: [Reg] -> [Int]
+ acceptable regs = filter no_conflict (possibleMRegs pk regs)
-extractMappedRegNos regs
- = foldr ex [] regs
- where
- ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it
- ex _ acc = acc -- leave it out
+ no_conflict reg =
+ case lookupFM conflicts reg of
+ Nothing -> True
+ Just conflicts -> not (d `elementOfRegSet` conflicts)
\end{code}
We keep a local copy of the Prelude function \tr{notElem},
projects / ghc-hetmet.git / blobdiff