ghc/compiler/nativeGen/AsmRegAlloc.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[AsmRegAlloc]{Register allocator}
   5
   6 \begin{code}
   7 module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
   8
   9 #include "HsVersions.h"
  10
  11 import MachCode         ( InstrList )
  12 import MachMisc         ( Instr )
  13 import MachRegs
  14 import RegAllocInfo
  15
  16 import AbsCSyn          ( MagicId )
  17 import BitSet           ( BitSet )
  18 import FiniteMap        ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
  19 import Maybes           ( maybeToBool )
  20 import OrdList          ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
  21                           flattenOrdList, OrdList
  22                         )
  23 import Stix             ( StixTree )
  24 import Unique           ( mkBuiltinUnique )
  25 import Util             ( mapAccumB, panic, trace )
  26 import Outputable
  27 \end{code}
  28
  29 This is the generic register allocator.
  30
  31 First we try something extremely simple.  If that fails, we have to do
  32 things the hard way.
  33
  34 \begin{code}
  35 runRegAllocate
  36     :: MRegsState
  37     -> [RegNo]
  38     -> InstrList
  39     -> [Instr]
  40
  41 runRegAllocate regs reserve_regs instrs
  42   = case simpleAlloc of
  43         Just x  -> x
  44         Nothing -> hairyAlloc
  45   where
  46     flatInstrs  = flattenOrdList instrs
  47     simpleAlloc = simpleRegAlloc regs [] emptyFM   flatInstrs
  48     hairyAlloc  = hairyRegAlloc  regs reserve_regs flatInstrs
  49
  50 runHairyRegAllocate             -- use only hairy for i386!
  51     :: MRegsState
  52     -> [RegNo]
  53     -> InstrList
  54     -> [Instr]
  55
  56 runHairyRegAllocate regs reserve_regs instrs
  57   = hairyRegAlloc regs reserve_regs flatInstrs
  58   where
  59     flatInstrs  = flattenOrdList instrs
  60 \end{code}
  61
  62 Here is the simple register allocator.  Just dole out registers until
  63 we run out, or until one gets clobbered before its last use.  Don't
  64 do anything fancy with branches.  Just pretend that you've got a block
  65 of straight-line code and hope for the best.  Experience indicates that
  66 this approach will suffice for about 96 percent of the code blocks that
  67 we generate.
  68
  69 \begin{code}
  70 simpleRegAlloc
  71     :: MRegsState       -- registers to select from
  72     -> [Reg]            -- live static registers
  73     -> RegAssignment    -- mapping of dynamics to statics
  74     -> [Instr]          -- code
  75     -> Maybe [Instr]
  76
  77 simpleRegAlloc _ _ _ [] = Just []
  78
  79 simpleRegAlloc free live env (instr:instrs)
  80  | null deadSrcs        &&
  81    maybeToBool newAlloc &&
  82    maybeToBool instrs2
  83  = Just (instr3 : instrs3)
  84  | otherwise
  85  = Nothing
  86   where
  87     instr3 = patchRegs instr (lookup env2)
  88
  89     (srcs, dsts) = case regUsage instr of (RU s d) -> (regSetToList s, regSetToList d)
  90
  91     lookup env x = case lookupFM env x of Just y -> y; Nothing -> x
  92
  93     deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
  94     newDsts  = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
  95
  96     newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
  97     (free2, new) = case newAlloc of Just x -> x
  98
  99     env2 = env `addListToFM` new
 100
 101     live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
 102
 103     instrs2 = simpleRegAlloc free2 live2 env2 instrs
 104     instrs3 = case instrs2 of Just x -> x
 105
 106     allocateNewReg
 107         :: Reg
 108         -> Maybe (MRegsState, [(Reg, Reg)])
 109         -> Maybe (MRegsState, [(Reg, Reg)])
 110
 111     allocateNewReg _ Nothing = Nothing
 112
 113     allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs))
 114       | null choices = Nothing
 115       | otherwise    = Just (free2, prs2)
 116       where
 117         choices = possibleMRegs pk free
 118         reg     = head choices
 119         free2   = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
 120         prs2    = ((d,  MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
 121 \end{code}
 122
 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.
 126
 127 \begin{code}
 128 hairyRegAlloc
 129     :: MRegsState
 130     -> [RegNo]
 131     -> [Instr]
 132     -> [Instr]
 133
 134 hairyRegAlloc regs reserve_regs instrs =
 135   case mapAccumB (doRegAlloc reserve_regs) (RH regs' 1 emptyFM) noFuture instrs of
 136    (RH _ mloc1 _, _, instrs')
 137      | mloc1 == 1 -> instrs'
 138      | otherwise  ->
 139       let
 140        instrs_patched' = patchMem instrs'
 141        instrs_patched  = flattenOrdList instrs_patched'
 142       in
 143       case mapAccumB do_RegAlloc_Nil (RH regs'' mloc1 emptyFM) noFuture instrs_patched of
 144          ((RH _ mloc2 _),_,instrs'')
 145             | mloc2 == mloc1 -> instrs''
 146             | otherwise      -> instrs''
 147                --pprPanic "runRegAllocate" (ppr mloc2 <+> ppr mloc1)
 148   where
 149     regs'  = regs `useMRegs` reserve_regs
 150     regs'' = mkMRegsState reserve_regs
 151
 152 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
 153 do_RegAlloc_Nil
 154     :: RegHistory MRegsState
 155     -> RegFuture
 156     -> Instr
 157     -> (RegHistory MRegsState, RegFuture, Instr)
 158
 159 noFuture :: RegFuture
 160 noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
 161 \end{code}
 162
 163 Here we patch instructions that reference ``registers'' which are really in
 164 memory somewhere (the mapping is under the control of the machine-specific
 165 code generator).  We place the appropriate load sequences before any instructions
 166 that use memory registers as sources, and we place the appropriate spill sequences
 167 after any instructions that use memory registers as destinations.  The offending
 168 instructions are rewritten with new dynamic registers, so we have to run register
 169 allocation again after all of this is said and done.
 170
 171 \begin{code}
 172 patchMem :: [Instr] -> InstrList
 173
 174 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
 175
 176 patchMem' :: Instr -> InstrList
 177
 178 patchMem' instr
 179  | null memSrcs && null memDsts = mkUnitList instr
 180  | otherwise =
 181     mkSeqList
 182       (foldr mkParList mkEmptyList loadSrcs)
 183       (mkSeqList instr'
 184                  (foldr mkParList mkEmptyList spillDsts))
 185
 186     where
 187         (RU srcs dsts) = regUsage instr
 188
 189         memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
 190         memToDyn other            = other
 191
 192         memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
 193         memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
 194
 195         loadSrcs = map load memSrcs
 196         spillDsts = map spill memDsts
 197
 198         load mem = loadReg mem (memToDyn mem)
 199         spill mem = spillReg (memToDyn mem) mem
 200
 201         instr' = mkUnitList (patchRegs instr memToDyn)
 202 \end{code}
 203
 204 \begin{code}
 205 doRegAlloc
 206     :: [RegNo]
 207     -> RegHistory MRegsState
 208     -> RegFuture
 209     -> Instr
 210     -> (RegHistory MRegsState, RegFuture, Instr)
 211
 212 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
 213   where
 214       (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
 215       (in_use', info) = getUsage in_use instr
 216 \end{code}
 217
 218 \begin{code}
 219 getUsage
 220     :: RegFuture
 221     -> Instr
 222     -> (RegFuture, RegInfo Instr)
 223
 224 getUsage (RF next_in_use future reg_conflicts) instr
 225   = (RF in_use' future' reg_conflicts',
 226      RI in_use' srcs dsts last_used reg_conflicts')
 227          where (RU srcs dsts) = regUsage instr
 228                (RL in_use future') = regLiveness instr (RL next_in_use future)
 229                live_through = in_use `minusRegSet` dsts
 230                last_used = [ r | r <- regSetToList srcs,
 231                              not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)]
 232
 233                in_use' = srcs `unionRegSets` live_through
 234
 235                reg_conflicts' =
 236                 case new_conflicts of
 237                   [] -> reg_conflicts
 238                   _  -> addListToFM reg_conflicts new_conflicts
 239
 240                new_conflicts
 241                 | isEmptyRegSet live_dynamics = []
 242                 | otherwise =
 243                   [ (r, merge_conflicts r)
 244                   | r <- extractMappedRegNos (regSetToList dsts) ]
 245
 246                merge_conflicts reg =
 247                 case lookupFM reg_conflicts reg of
 248                   Nothing        -> live_dynamics
 249                   Just conflicts -> conflicts `unionRegSets` live_dynamics
 250
 251                live_dynamics = mkRegSet [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
 252
 253 doRegAlloc'
 254     :: [RegNo]
 255     -> RegHistory MRegsState
 256     -> RegInfo Instr
 257     -> Instr
 258     -> (RegHistory MRegsState, Instr)
 259
 260 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
 261
 262     (RH frs'' loc' env'', patchRegs instr dynToStatic)
 263
 264     where
 265
 266       -- free up new registers
 267       free :: [RegNo]
 268       free = extractMappedRegNos (map dynToStatic lastu)
 269
 270       -- (1) free registers that are used last as source operands in this instruction
 271       frs_not_in_use = frs `useMRegs` (extractMappedRegNos (regSetToList in_use))
 272       frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
 273
 274       -- (2) allocate new registers for the destination operands
 275       -- allocate registers for new dynamics
 276
 277       new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ]
 278
 279       (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
 280
 281       env' = addListToFM env new
 282
 283       env'' = delListFromFM env' lastu
 284
 285       dynToStatic :: Reg -> Reg
 286       dynToStatic dyn@(UnmappedReg _ _) =
 287         case lookupFM env' dyn of
 288             Just r -> r
 289             Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
 290       dynToStatic other = other
 291
 292       allocateNewRegs :: Reg
 293                       -> (MRegsState, Int, [(Reg, Reg)])
 294                       -> (MRegsState, Int, [(Reg, Reg)])
 295
 296       allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
 297         where
 298          (fs', f, mem') =
 299            case acceptable fs of
 300             []           -> (fs, MemoryReg mem pk, mem + 1)
 301             (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
 302
 303          acceptable regs = filter no_conflict (possibleMRegs pk regs)
 304
 305          no_conflict reg =
 306            case lookupFM conflicts reg of
 307              Nothing        -> True
 308              Just conflicts -> not (d `elementOfRegSet` conflicts)
 309 \end{code}
 310
 311 We keep a local copy of the Prelude function \tr{notElem},
 312 so that it can be specialised.  (Hack me gently.  [WDP 94/11])
 313 \begin{code}
 314 not_elem x []       =  True
 315 not_elem x (y:ys)   =  x /= y && not_elem x ys
 316 \end{code}