2 % (c) The AQUA Project, Glasgow University, 1993-1995
6 #include "HsVersions.h"
7 #include "../../includes/platform.h"
8 #include "../../includes/GhcConstants.h"
11 FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..),
12 MachineRegisters(..), MachineCode(..),
14 mkReg, runRegAllocate, runHairyRegAllocate,
17 -- And, for self-sufficiency
20 import CLabel ( CLabel )
23 import Maybes ( maybeToBool, Maybe(..) )
24 import OrdList -- ( mkUnitList, mkSeqList, mkParList, OrdList )
28 import Unique ( Unique )
31 #if ! OMIT_NATIVE_CODEGEN
33 # if alpha_TARGET_ARCH
34 import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing
37 runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr]
42 import I386Code -- ( I386Instr, I386Regs ) -- for specializing
45 runRegAllocate :: I386Regs -> [Int] -> (OrdList I386Instr) -> [I386Instr]
49 # if sparc_TARGET_ARCH
50 import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing
53 runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr]
61 %************************************************************************
63 \subsection[Reg]{Real registers}
65 %************************************************************************
67 Static Registers correspond to actual machine registers. These should
68 be avoided until the last possible moment.
70 Dynamic registers are allocated on the fly, usually to represent a single
71 value in the abstract assembly code (i.e. dynamic registers are usually
72 single assignment). Ultimately, they are mapped to available machine
73 registers before spitting out the code.
77 data Reg = FixedReg FAST_INT -- A pre-allocated machine register
79 | MappedReg FAST_INT -- A dynamically allocated machine register
81 | MemoryReg Int PrimRep -- A machine "register" actually held in a memory
82 -- allocated table of registers which didn't fit
85 | UnmappedReg Unique PrimRep -- One of an infinite supply of registers,
86 -- always mapped to one of the earlier two
88 -- No thanks: deriving (Eq)
90 mkReg :: Unique -> PrimRep -> Reg
93 instance Text Reg where
94 showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i)
95 showsPrec _ (MappedReg i) = showString "%" . shows IBOX(i)
96 showsPrec _ (MemoryReg i _) = showString "%M" . shows i
97 showsPrec _ (UnmappedReg i _) = showString "%U" . shows i
100 instance Outputable Reg where
101 ppr sty r = ppStr (show r)
104 cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
105 cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i'
106 cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i'
107 cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmp u u'
112 if tag1 _LT_ tag2 then LT_ else GT_
114 tagReg (FixedReg _) = (ILIT(1) :: FAST_INT)
115 tagReg (MappedReg _) = ILIT(2)
116 tagReg (MemoryReg _ _) = ILIT(3)
117 tagReg (UnmappedReg _ _) = ILIT(4)
119 cmp_i :: Int -> Int -> TAG_
120 cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_
122 cmp_ihash :: FAST_INT -> FAST_INT -> TAG_
123 cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_
125 instance Eq Reg where
126 a == b = case cmpReg a b of { EQ_ -> True; _ -> False }
127 a /= b = case cmpReg a b of { EQ_ -> False; _ -> True }
129 instance Ord Reg where
130 a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
131 a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
132 a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
133 a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
134 _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
136 instance NamedThing Reg where
137 -- the *only* method that should be defined is "getItsUnique"!
138 -- (so we can use UniqFMs/UniqSets on Regs
139 getItsUnique (UnmappedReg u _) = u
140 getItsUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
141 getItsUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
142 getItsUnique (MemoryReg i _) = mkPseudoUnique3 i
145 This is the generic register allocator.
147 %************************************************************************
149 \subsection[RegPlace]{Map Stix registers to {\em real} registers}
151 %************************************************************************
153 An important point: The @regUsage@ function for a particular assembly language
154 must not refer to fixed registers, such as Hp, SpA, etc. The source and destination
155 lists should only refer to dynamically allocated registers or static registers
156 from the free list. As far as we are concerned, the fixed registers simply don't
157 exist (for allocation purposes, anyway).
161 class MachineRegisters a where
162 mkMRegs :: [Int] -> a
163 possibleMRegs :: PrimRep -> a -> [Int]
164 useMReg :: a -> FAST_INT -> a
165 useMRegs :: a -> [Int] -> a
166 freeMReg :: a -> FAST_INT -> a
167 freeMRegs :: a -> [Int] -> a
169 type RegAssignment = FiniteMap Reg Reg
170 type RegConflicts = FiniteMap Int (UniqSet Reg)
174 (FiniteMap CLabel (UniqSet Reg))
183 = RF (UniqSet Reg) -- in use
188 = RI (UniqSet Reg) -- in use
189 (UniqSet Reg) -- sources
190 (UniqSet Reg) -- destinations
202 class MachineCode a where
203 regUsage :: a -> RegUsage
204 regLiveness :: a -> RegLiveness -> RegLiveness
205 patchRegs :: a -> (Reg -> Reg) -> a
206 spillReg :: Reg -> Reg -> OrdList a
207 loadReg :: Reg -> Reg -> OrdList a
210 First we try something extremely simple.
211 If that fails, we have to do things the hard way.
215 :: (MachineRegisters a, MachineCode b)
221 runRegAllocate regs reserve_regs instrs =
224 Nothing -> hairyAlloc
226 flatInstrs = flattenOrdList instrs
227 simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
228 hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs
230 runHairyRegAllocate -- use only hairy for i386!
231 :: (MachineRegisters a, MachineCode b)
237 runHairyRegAllocate regs reserve_regs instrs
238 = hairyRegAlloc regs reserve_regs flatInstrs
240 flatInstrs = flattenOrdList instrs
243 Here is the simple register allocator. Just dole out registers until
244 we run out, or until one gets clobbered before its last use. Don't
245 do anything fancy with branches. Just pretend that you've got a block
246 of straight-line code and hope for the best. Experience indicates that
247 this approach will suffice for about 96 percent of the code blocks that
253 :: (MachineRegisters a, MachineCode b)
254 => a -- registers to select from
255 -> [Reg] -- live static registers
256 -> RegAssignment -- mapping of dynamics to statics
260 simpleRegAlloc _ _ _ [] = Just []
261 simpleRegAlloc free live env (instr:instrs) =
262 if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
263 Just (instr3 : instrs3)
267 instr3 = patchRegs instr (lookup env2)
269 (srcs, dsts) = case regUsage instr of { RU s d -> (uniqSetToList s, uniqSetToList d) }
271 lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x}
273 deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
274 newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
276 newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
277 (free2, new) = case newAlloc of Just x -> x
279 env2 = env `addListToFM` new
281 live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
283 instrs2 = simpleRegAlloc free2 live2 env2 instrs
284 instrs3 = case instrs2 of Just x -> x
287 :: MachineRegisters a
289 -> Maybe (a, [(Reg, Reg)])
290 -> Maybe (a, [(Reg, Reg)])
292 allocateNewReg _ Nothing = Nothing
294 allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) =
295 if null choices then Nothing
296 else Just (free2, prs2)
298 choices = possibleMRegs pk free
300 free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
301 prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
305 Here is the ``clever'' bit. First go backward (i.e. left), looking for
306 the last use of dynamic registers. Then go forward (i.e. right), filling
307 registers with static placements.
312 :: (MachineRegisters a, MachineCode b)
318 hairyRegAlloc regs reserve_regs instrs =
319 case mapAccumB (doRegAlloc reserve_regs)
320 (RH regs' 1 emptyFM) noFuture instrs
321 of (RH _ loc' _, _, instrs') ->
322 if loc' == 1 then instrs' else
323 case mapAccumB do_RegAlloc_Nil
324 (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs'))
325 of ((RH _ loc'' _),_,instrs'') ->
326 if loc'' == loc' then instrs'' else panic "runRegAllocate"
328 regs' = regs `useMRegs` reserve_regs
329 regs'' = mkMRegs reserve_regs `asTypeOf` regs
331 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
333 :: (MachineRegisters a, MachineCode b)
337 -> (RegHistory a, RegFuture, b)
339 noFuture :: RegFuture
340 noFuture = RF emptyUniqSet (FL emptyUniqSet emptyFM) emptyFM
343 Here we patch instructions that reference ``registers'' which are really in
344 memory somewhere (the mapping is under the control of the machine-specific
345 code generator). We place the appropriate load sequences before any instructions
346 that use memory registers as sources, and we place the appropriate spill sequences
347 after any instructions that use memory registers as destinations. The offending
348 instructions are rewritten with new dynamic registers, so we have to run register
349 allocation again after all of this is said and done.
358 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
366 if null memSrcs && null memDsts then mkUnitList instr
368 (foldr mkParList mkEmptyList loadSrcs)
370 (foldr mkParList mkEmptyList spillDsts))
373 (RU srcs dsts) = regUsage instr
375 memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
376 memToDyn other = other
378 memSrcs = [ r | r@(MemoryReg _ _) <- uniqSetToList srcs]
379 memDsts = [ r | r@(MemoryReg _ _) <- uniqSetToList dsts]
381 loadSrcs = map load memSrcs
382 spillDsts = map spill memDsts
384 load mem = loadReg mem (memToDyn mem)
385 spill mem = spillReg (memToDyn mem) mem
387 instr' = mkUnitList (patchRegs instr memToDyn)
394 :: (MachineRegisters a, MachineCode b)
399 -> (RegHistory a, RegFuture, b)
401 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
403 (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
404 (in_use', info) = getUsage in_use instr
414 -> (RegFuture, RegInfo a)
416 getUsage (RF next_in_use future reg_conflicts) instr =
417 (RF in_use' future' reg_conflicts',
418 RI in_use' srcs dsts last_used reg_conflicts')
419 where (RU srcs dsts) = regUsage instr
420 (RL in_use future') = regLiveness instr (RL next_in_use future)
421 live_through = in_use `minusUniqSet` dsts
422 last_used = [ r | r <- uniqSetToList srcs,
423 not (r `elementOfUniqSet` (fstFL future) || r `elementOfUniqSet` in_use)]
424 in_use' = srcs `unionUniqSets` live_through
425 reg_conflicts' = case new_conflicts of
427 _ -> addListToFM reg_conflicts new_conflicts
428 new_conflicts = if isEmptyUniqSet live_dynamics then []
429 else [ (r, merge_conflicts r)
430 | r <- extractMappedRegNos (uniqSetToList dsts) ]
431 merge_conflicts reg = case lookupFM reg_conflicts reg of
432 Nothing -> live_dynamics
433 Just conflicts -> conflicts `unionUniqSets` live_dynamics
434 live_dynamics = mkUniqSet
435 [ r | r@(UnmappedReg _ _) <- uniqSetToList live_through ]
438 :: (MachineRegisters a, MachineCode b)
445 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
447 (RH frs'' loc' env'', patchRegs instr dynToStatic)
451 -- free up new registers
453 free = extractMappedRegNos (map dynToStatic lastu)
455 -- (1) free registers that are used last as source operands in this instruction
456 frs_not_in_use = frs `useMRegs` (extractMappedRegNos (uniqSetToList in_use))
457 frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
459 -- (2) allocate new registers for the destination operands
460 -- allocate registers for new dynamics
462 new_dynamix = [ r | r@(UnmappedReg _ _) <- uniqSetToList dsts, r `not_elem` keysFM env ]
464 (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
466 env' = addListToFM env new
468 env'' = delListFromFM env' lastu
470 dynToStatic :: Reg -> Reg
471 dynToStatic dyn@(UnmappedReg _ _) =
472 case lookupFM env' dyn of
474 Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
475 dynToStatic other = other
478 :: MachineRegisters a
479 => Reg -> (a, Int, [(Reg, Reg)]) -> (a, Int, [(Reg, Reg)])
481 allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
482 where (fs', f, mem') = case acceptable fs of
483 [] -> (fs, MemoryReg mem pk, mem + 1)
484 (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
486 acceptable regs = filter no_conflict (possibleMRegs pk regs)
487 no_conflict reg = case lookupFM conflicts reg of
489 Just conflicts -> not (d `elementOfUniqSet` conflicts)
493 extractMappedRegNos :: [Reg] -> [Int]
495 extractMappedRegNos regs
498 ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it
499 ex _ acc = acc -- leave it out
502 We keep a local copy of the Prelude function \tr{notElem},
503 so that it can be specialised. (Hack me gently. [WDP 94/11])
506 not_elem x (y:ys) = x /= y && not_elem x ys