diff options
Diffstat (limited to 'ghc/compiler/nativeGen/AsmRegAlloc.lhs')
| -rw-r--r-- | ghc/compiler/nativeGen/AsmRegAlloc.lhs | 498 |
1 files changed, 498 insertions, 0 deletions
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs new file mode 100644 index 0000000000..9d11e229b0 --- /dev/null +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -0,0 +1,498 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\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 + +IMPORT_Trace + +import CLabelInfo ( CLabel ) +import FiniteMap +import MachDesc +import Maybes ( maybeToBool, Maybe(..) ) +import OrdList -- ( mkUnitList, mkSeqList, mkParList, OrdList ) +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 +\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. + +\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 + where + flatInstrs = flattenOrdList instrs + simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs + hairyAlloc = hairyRegAlloc regs reserve_regs 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. + +\begin{code} + +simpleRegAlloc + :: (MachineRegisters a, MachineCode b) + => a -- registers to select from + -> [Reg] -- live static registers + -> RegAssignment -- mapping of dynamics to statics + -> [b] -- code + -> Maybe [b] + +simpleRegAlloc _ _ _ [] = Just [] +simpleRegAlloc free live env (instr:instrs) = + if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then + Just (instr3 : instrs3) + else + Nothing + where + instr3 = patchRegs instr (lookup env2) + + (srcs, dsts) = case regUsage instr of { RU s d -> (uniqSetToList s, uniqSetToList 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] + + newAlloc = foldr allocateNewReg (Just (free, [])) newDsts + (free2, new) = case newAlloc of Just x -> x + + env2 = env `addListToFM` new + + live2 = map snd new ++ [x | x <- live, x `not_elem` dsts] + + instrs2 = simpleRegAlloc free2 live2 env2 instrs + instrs3 = case instrs2 of Just x -> x + + allocateNewReg + :: MachineRegisters a + => Reg + -> Maybe (a, [(Reg, Reg)]) + -> Maybe (a, [(Reg, Reg)]) + + allocateNewReg _ Nothing = Nothing + + allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) = + if null choices then Nothing + else 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) + +\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 + :: (MachineRegisters a, MachineCode b) + => a + -> [Int] + -> [b] + -> [b] + +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" + 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 +\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. + +\begin{code} + +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] + + 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) + +\end{code} + +\begin{code} + +doRegAlloc + :: (MachineRegisters a, MachineCode b) + => [Int] + -> RegHistory a + -> RegFuture + -> b + -> (RegHistory a, RegFuture, b) + +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) + +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 ] + +doRegAlloc' + :: (MachineRegisters a, MachineCode b) + => [Int] + -> RegHistory a + -> RegInfo b + -> b + -> (RegHistory a, b) + +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 = 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)) + 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 ] + + (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 + :: 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) + + 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} + +\begin{code} +extractMappedRegNos :: [Reg] -> [Int] + +extractMappedRegNos regs + = foldr ex [] regs + where + ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it + ex _ acc = acc -- leave it out +\end{code} + +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} |