2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[AsmRegAlloc]{Register allocator}
7 module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
9 #include "HsVersions.h"
11 import MachCode ( InstrList )
12 import MachMisc ( Instr )
16 import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
17 import Maybes ( maybeToBool )
18 import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
19 flattenOrdList, OrdList
21 import Unique ( mkBuiltinUnique )
22 import Util ( mapAccumB )
26 This is the generic register allocator.
28 First we try something extremely simple. If that fails, we have to do
38 runRegAllocate regs reserve_regs instrs
43 flatInstrs = flattenOrdList instrs
44 simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
45 hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs
47 runHairyRegAllocate -- use only hairy for i386!
53 runHairyRegAllocate regs reserve_regs instrs
54 = hairyRegAlloc regs reserve_regs flatInstrs
56 flatInstrs = flattenOrdList instrs
59 Here is the simple register allocator. Just dole out registers until
60 we run out, or until one gets clobbered before its last use. Don't
61 do anything fancy with branches. Just pretend that you've got a block
62 of straight-line code and hope for the best. Experience indicates that
63 this approach will suffice for about 96 percent of the code blocks that
68 :: MRegsState -- registers to select from
69 -> [Reg] -- live static registers
70 -> RegAssignment -- mapping of dynamics to statics
74 simpleRegAlloc _ _ _ [] = Just []
76 simpleRegAlloc free live env (instr:instrs)
78 maybeToBool newAlloc &&
80 = Just (instr3 : instrs3)
84 instr3 = patchRegs instr (lookup env2)
86 (srcs, dsts) = case regUsage instr of (RU s d) -> (regSetToList s, regSetToList d)
88 lookup env x = case lookupFM env x of Just y -> y; Nothing -> x
90 deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
91 newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
93 newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
94 (free2, new) = case newAlloc of Just x -> x
96 env2 = env `addListToFM` new
98 live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
100 instrs2 = simpleRegAlloc free2 live2 env2 instrs
101 instrs3 = case instrs2 of Just x -> x
105 -> Maybe (MRegsState, [(Reg, Reg)])
106 -> Maybe (MRegsState, [(Reg, Reg)])
108 allocateNewReg _ Nothing = Nothing
110 allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs))
111 | null choices = Nothing
112 | otherwise = Just (free2, prs2)
114 choices = possibleMRegs pk free
116 free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
117 prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
120 Here is the ``clever'' bit. First go backward (i.e. left), looking for
121 the last use of dynamic registers. Then go forward (i.e. right), filling
122 registers with static placements.
131 hairyRegAlloc regs reserve_regs instrs =
132 case mapAccumB (doRegAlloc reserve_regs) (RH regs' 1 emptyFM) noFuture instrs of
133 (RH _ mloc1 _, _, instrs')
134 | mloc1 == 1 -> instrs'
137 instrs_patched' = patchMem instrs'
138 instrs_patched = flattenOrdList instrs_patched'
140 case mapAccumB do_RegAlloc_Nil (RH regs'' mloc1 emptyFM) noFuture instrs_patched of
141 ((RH _ mloc2 _),_,instrs'')
142 | mloc2 == mloc1 -> instrs''
143 | otherwise -> instrs''
144 --pprPanic "runRegAllocate" (ppr mloc2 <+> ppr mloc1)
146 regs' = regs `useMRegs` reserve_regs
147 regs'' = mkMRegsState reserve_regs
149 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
151 :: RegHistory MRegsState
154 -> (RegHistory MRegsState, RegFuture, Instr)
156 noFuture :: RegFuture
157 noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
160 Here we patch instructions that reference ``registers'' which are really in
161 memory somewhere (the mapping is under the control of the machine-specific
162 code generator). We place the appropriate load sequences before any instructions
163 that use memory registers as sources, and we place the appropriate spill sequences
164 after any instructions that use memory registers as destinations. The offending
165 instructions are rewritten with new dynamic registers, so we have to run register
166 allocation again after all of this is said and done.
169 patchMem :: [Instr] -> InstrList
171 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
173 patchMem' :: Instr -> InstrList
176 | null memSrcs && null memDsts = 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)]
230 in_use' = srcs `unionRegSets` live_through
233 case new_conflicts of
235 _ -> addListToFM reg_conflicts new_conflicts
238 | isEmptyRegSet live_dynamics = []
240 [ (r, merge_conflicts r)
241 | r <- extractMappedRegNos (regSetToList dsts) ]
243 merge_conflicts reg =
244 case lookupFM reg_conflicts reg of
245 Nothing -> live_dynamics
246 Just conflicts -> conflicts `unionRegSets` live_dynamics
248 live_dynamics = mkRegSet [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
252 -> RegHistory MRegsState
255 -> (RegHistory MRegsState, Instr)
257 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
259 (RH frs'' loc' env'', patchRegs instr dynToStatic)
263 -- free up new registers
265 free = extractMappedRegNos (map dynToStatic lastu)
267 -- (1) free registers that are used last as source operands in this instruction
268 frs_not_in_use = frs `useMRegs` (extractMappedRegNos (regSetToList in_use))
269 frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
271 -- (2) allocate new registers for the destination operands
272 -- allocate registers for new dynamics
274 new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ]
276 (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
278 env' = addListToFM env new
280 env'' = delListFromFM env' lastu
282 dynToStatic :: Reg -> Reg
283 dynToStatic dyn@(UnmappedReg _ _) =
284 case lookupFM env' dyn of
286 Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
287 dynToStatic other = other
289 allocateNewRegs :: Reg
290 -> (MRegsState, Int, [(Reg, Reg)])
291 -> (MRegsState, Int, [(Reg, Reg)])
293 allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
296 case acceptable fs of
297 [] -> (fs, MemoryReg mem pk, mem + 1)
298 (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
300 acceptable regs = filter no_conflict (possibleMRegs pk regs)
303 case lookupFM conflicts reg of
305 Just conflicts -> not (d `elementOfRegSet` conflicts)
308 We keep a local copy of the Prelude function \tr{notElem},
309 so that it can be specialised. (Hack me gently. [WDP 94/11])
312 not_elem x (y:ys) = x /= y && not_elem x ys