2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[AsmRegAlloc]{Register allocator}
7 #include "HsVersions.h"
9 module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
13 import MachCode ( SYN_IE(InstrList) )
14 import MachMisc ( Instr )
15 #if __GLASGOW_HASKELL__ >= 202
16 import MachRegs hiding (Addr)
22 import AbsCSyn ( MagicId )
23 import BitSet ( BitSet )
24 import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
25 import Maybes ( maybeToBool )
26 import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
27 flattenOrdList, OrdList
29 import Stix ( StixTree )
30 import Unique ( mkBuiltinUnique )
31 import Util ( mapAccumB, panic )
34 This is the generic register allocator.
36 First we try something extremely simple. If that fails, we have to do
46 runRegAllocate regs reserve_regs instrs
51 flatInstrs = flattenOrdList instrs
52 simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
53 hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs
55 runHairyRegAllocate -- use only hairy for i386!
61 runHairyRegAllocate regs reserve_regs instrs
62 = hairyRegAlloc regs reserve_regs flatInstrs
64 flatInstrs = flattenOrdList instrs
67 Here is the simple register allocator. Just dole out registers until
68 we run out, or until one gets clobbered before its last use. Don't
69 do anything fancy with branches. Just pretend that you've got a block
70 of straight-line code and hope for the best. Experience indicates that
71 this approach will suffice for about 96 percent of the code blocks that
76 :: MRegsState -- registers to select from
77 -> [Reg] -- live static registers
78 -> RegAssignment -- mapping of dynamics to statics
82 simpleRegAlloc _ _ _ [] = Just []
84 simpleRegAlloc free live env (instr:instrs)
85 = if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
86 Just (instr3 : instrs3)
90 instr3 = patchRegs instr (lookup env2)
92 (srcs, dsts) = case regUsage instr of { RU s d -> (regSetToList s, regSetToList d) }
94 lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x}
96 deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
97 newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
99 newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
100 (free2, new) = case newAlloc of Just x -> x
102 env2 = env `addListToFM` new
104 live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
106 instrs2 = simpleRegAlloc free2 live2 env2 instrs
107 instrs3 = case instrs2 of Just x -> x
111 -> Maybe (MRegsState, [(Reg, Reg)])
112 -> Maybe (MRegsState, [(Reg, Reg)])
114 allocateNewReg _ Nothing = Nothing
116 allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) =
117 if null choices then Nothing
118 else Just (free2, prs2)
120 choices = possibleMRegs pk free
122 free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
123 prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
126 Here is the ``clever'' bit. First go backward (i.e. left), looking for
127 the last use of dynamic registers. Then go forward (i.e. right), filling
128 registers with static placements.
137 hairyRegAlloc regs reserve_regs instrs
138 = case mapAccumB (doRegAlloc reserve_regs)
139 (RH regs' 1 emptyFM) noFuture instrs
140 of (RH _ loc' _, _, instrs') ->
141 if loc' == 1 then instrs' else
142 case mapAccumB do_RegAlloc_Nil
143 (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs'))
144 of ((RH _ loc'' _),_,instrs'') ->
145 if loc'' == loc' then instrs'' else panic "runRegAllocate"
147 regs' = regs `useMRegs` reserve_regs
148 regs'' = mkMRegsState reserve_regs
150 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
152 :: RegHistory MRegsState
155 -> (RegHistory MRegsState, RegFuture, Instr)
157 noFuture :: RegFuture
158 noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
161 Here we patch instructions that reference ``registers'' which are really in
162 memory somewhere (the mapping is under the control of the machine-specific
163 code generator). We place the appropriate load sequences before any instructions
164 that use memory registers as sources, and we place the appropriate spill sequences
165 after any instructions that use memory registers as destinations. The offending
166 instructions are rewritten with new dynamic registers, so we have to run register
167 allocation again after all of this is said and done.
170 patchMem :: [Instr] -> InstrList
172 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
174 patchMem' :: Instr -> InstrList
177 = if null memSrcs && null memDsts then mkUnitList instr
179 (foldr mkParList mkEmptyList loadSrcs)
181 (foldr mkParList mkEmptyList spillDsts))
184 (RU srcs dsts) = regUsage instr
186 memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
187 memToDyn other = other
189 memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
190 memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
192 loadSrcs = map load memSrcs
193 spillDsts = map spill memDsts
195 load mem = loadReg mem (memToDyn mem)
196 spill mem = spillReg (memToDyn mem) mem
198 instr' = mkUnitList (patchRegs instr memToDyn)
204 -> RegHistory MRegsState
207 -> (RegHistory MRegsState, RegFuture, Instr)
209 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
211 (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
212 (in_use', info) = getUsage in_use instr
219 -> (RegFuture, RegInfo Instr)
221 getUsage (RF next_in_use future reg_conflicts) instr
222 = (RF in_use' future' reg_conflicts',
223 RI in_use' srcs dsts last_used reg_conflicts')
224 where (RU srcs dsts) = regUsage instr
225 (RL in_use future') = regLiveness instr (RL next_in_use future)
226 live_through = in_use `minusRegSet` dsts
227 last_used = [ r | r <- regSetToList srcs,
228 not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)]
229 in_use' = srcs `unionRegSets` live_through
230 reg_conflicts' = case new_conflicts of
232 _ -> addListToFM reg_conflicts new_conflicts
233 new_conflicts = if isEmptyRegSet live_dynamics then []
234 else [ (r, merge_conflicts r)
235 | r <- extractMappedRegNos (regSetToList dsts) ]
236 merge_conflicts reg = case lookupFM reg_conflicts reg of
237 Nothing -> live_dynamics
238 Just conflicts -> conflicts `unionRegSets` live_dynamics
239 live_dynamics = mkRegSet
240 [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
244 -> RegHistory MRegsState
247 -> (RegHistory MRegsState, Instr)
249 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
251 (RH frs'' loc' env'', patchRegs instr dynToStatic)
255 -- free up new registers
257 free = extractMappedRegNos (map dynToStatic lastu)
259 -- (1) free registers that are used last as source operands in this instruction
260 frs_not_in_use = frs `useMRegs` (extractMappedRegNos (regSetToList in_use))
261 frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
263 -- (2) allocate new registers for the destination operands
264 -- allocate registers for new dynamics
266 new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ]
268 (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
270 env' = addListToFM env new
272 env'' = delListFromFM env' lastu
274 dynToStatic :: Reg -> Reg
275 dynToStatic dyn@(UnmappedReg _ _) =
276 case lookupFM env' dyn of
278 Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
279 dynToStatic other = other
282 :: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)])
284 allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
285 where (fs', f, mem') = case acceptable fs of
286 [] -> (fs, MemoryReg mem pk, mem + 1)
287 (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
289 acceptable regs = filter no_conflict (possibleMRegs pk regs)
290 no_conflict reg = case lookupFM conflicts reg of
292 Just conflicts -> not (d `elementOfRegSet` conflicts)
295 We keep a local copy of the Prelude function \tr{notElem},
296 so that it can be specialised. (Hack me gently. [WDP 94/11])
299 not_elem x (y:ys) = x /= y && not_elem x ys