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 )
19 import AbsCSyn ( MagicId )
20 import BitSet ( BitSet )
21 import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
22 import Maybes ( maybeToBool )
23 import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
24 flattenOrdList, OrdList
26 import Stix ( StixTree )
27 import Unique ( mkBuiltinUnique )
28 import Util ( mapAccumB, panic )
31 This is the generic register allocator.
33 First we try something extremely simple. If that fails, we have to do
43 runRegAllocate regs reserve_regs instrs
48 flatInstrs = flattenOrdList instrs
49 simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
50 hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs
52 runHairyRegAllocate -- use only hairy for i386!
58 runHairyRegAllocate regs reserve_regs instrs
59 = hairyRegAlloc regs reserve_regs flatInstrs
61 flatInstrs = flattenOrdList instrs
64 Here is the simple register allocator. Just dole out registers until
65 we run out, or until one gets clobbered before its last use. Don't
66 do anything fancy with branches. Just pretend that you've got a block
67 of straight-line code and hope for the best. Experience indicates that
68 this approach will suffice for about 96 percent of the code blocks that
73 :: MRegsState -- registers to select from
74 -> [Reg] -- live static registers
75 -> RegAssignment -- mapping of dynamics to statics
79 simpleRegAlloc _ _ _ [] = Just []
81 simpleRegAlloc free live env (instr:instrs)
82 = if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
83 Just (instr3 : instrs3)
87 instr3 = patchRegs instr (lookup env2)
89 (srcs, dsts) = case regUsage instr of { RU s d -> (regSetToList s, regSetToList d) }
91 lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x}
93 deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
94 newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
96 newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
97 (free2, new) = case newAlloc of Just x -> x
99 env2 = env `addListToFM` new
101 live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
103 instrs2 = simpleRegAlloc free2 live2 env2 instrs
104 instrs3 = case instrs2 of Just x -> x
108 -> Maybe (MRegsState, [(Reg, Reg)])
109 -> Maybe (MRegsState, [(Reg, Reg)])
111 allocateNewReg _ Nothing = Nothing
113 allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) =
114 if null choices then Nothing
115 else Just (free2, prs2)
117 choices = possibleMRegs pk free
119 free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
120 prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
123 Here is the ``clever'' bit. First go backward (i.e. left), looking for
124 the last use of dynamic registers. Then go forward (i.e. right), filling
125 registers with static placements.
134 hairyRegAlloc regs reserve_regs instrs
135 = case mapAccumB (doRegAlloc reserve_regs)
136 (RH regs' 1 emptyFM) noFuture instrs
137 of (RH _ loc' _, _, instrs') ->
138 if loc' == 1 then instrs' else
139 case mapAccumB do_RegAlloc_Nil
140 (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs'))
141 of ((RH _ loc'' _),_,instrs'') ->
142 if loc'' == loc' then instrs'' else panic "runRegAllocate"
144 regs' = regs `useMRegs` reserve_regs
145 regs'' = mkMRegsState reserve_regs
147 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
149 :: RegHistory MRegsState
152 -> (RegHistory MRegsState, RegFuture, Instr)
154 noFuture :: RegFuture
155 noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
158 Here we patch instructions that reference ``registers'' which are really in
159 memory somewhere (the mapping is under the control of the machine-specific
160 code generator). We place the appropriate load sequences before any instructions
161 that use memory registers as sources, and we place the appropriate spill sequences
162 after any instructions that use memory registers as destinations. The offending
163 instructions are rewritten with new dynamic registers, so we have to run register
164 allocation again after all of this is said and done.
167 patchMem :: [Instr] -> InstrList
169 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
171 patchMem' :: Instr -> InstrList
174 = if null memSrcs && null memDsts then mkUnitList instr
176 (foldr mkParList mkEmptyList loadSrcs)
178 (foldr mkParList mkEmptyList spillDsts))
181 (RU srcs dsts) = regUsage instr
183 memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
184 memToDyn other = other
186 memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
187 memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
189 loadSrcs = map load memSrcs
190 spillDsts = map spill memDsts
192 load mem = loadReg mem (memToDyn mem)
193 spill mem = spillReg (memToDyn mem) mem
195 instr' = mkUnitList (patchRegs instr memToDyn)
201 -> RegHistory MRegsState
204 -> (RegHistory MRegsState, RegFuture, Instr)
206 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
208 (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
209 (in_use', info) = getUsage in_use instr
216 -> (RegFuture, RegInfo Instr)
218 getUsage (RF next_in_use future reg_conflicts) instr
219 = (RF in_use' future' reg_conflicts',
220 RI in_use' srcs dsts last_used reg_conflicts')
221 where (RU srcs dsts) = regUsage instr
222 (RL in_use future') = regLiveness instr (RL next_in_use future)
223 live_through = in_use `minusRegSet` dsts
224 last_used = [ r | r <- regSetToList srcs,
225 not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)]
226 in_use' = srcs `unionRegSets` live_through
227 reg_conflicts' = case new_conflicts of
229 _ -> addListToFM reg_conflicts new_conflicts
230 new_conflicts = if isEmptyRegSet live_dynamics then []
231 else [ (r, merge_conflicts r)
232 | r <- extractMappedRegNos (regSetToList dsts) ]
233 merge_conflicts reg = case lookupFM reg_conflicts reg of
234 Nothing -> live_dynamics
235 Just conflicts -> conflicts `unionRegSets` live_dynamics
236 live_dynamics = mkRegSet
237 [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
241 -> RegHistory MRegsState
244 -> (RegHistory MRegsState, Instr)
246 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
248 (RH frs'' loc' env'', patchRegs instr dynToStatic)
252 -- free up new registers
254 free = extractMappedRegNos (map dynToStatic lastu)
256 -- (1) free registers that are used last as source operands in this instruction
257 frs_not_in_use = frs `useMRegs` (extractMappedRegNos (regSetToList in_use))
258 frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
260 -- (2) allocate new registers for the destination operands
261 -- allocate registers for new dynamics
263 new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ]
265 (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
267 env' = addListToFM env new
269 env'' = delListFromFM env' lastu
271 dynToStatic :: Reg -> Reg
272 dynToStatic dyn@(UnmappedReg _ _) =
273 case lookupFM env' dyn of
275 Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
276 dynToStatic other = other
279 :: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)])
281 allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
282 where (fs', f, mem') = case acceptable fs of
283 [] -> (fs, MemoryReg mem pk, mem + 1)
284 (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
286 acceptable regs = filter no_conflict (possibleMRegs pk regs)
287 no_conflict reg = case lookupFM conflicts reg of
289 Just conflicts -> not (d `elementOfRegSet` conflicts)
292 We keep a local copy of the Prelude function \tr{notElem},
293 so that it can be specialised. (Hack me gently. [WDP 94/11])
296 not_elem x (y:ys) = x /= y && not_elem x ys