ghc/compiler/nativeGen/AsmRegAlloc.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   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 FiniteMap        ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
  17 import Maybes           ( maybeToBool )
  18 import OrdList          ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
  19                           flattenOrdList, OrdList
  20                         )
  21 import Unique           ( mkBuiltinUnique )
  22 import Util             ( mapAccumB, panic, trace )
  23 import Outputable
  24 \end{code}
  25
  26 This is the generic register allocator.
  27
  28 First we try something extremely simple.  If that fails, we have to do
  29 things the hard way.
  30
  31 \begin{code}
  32 runRegAllocate
  33     :: MRegsState
  34     -> [RegNo]
  35     -> InstrList
  36     -> [Instr]
  37
  38 runRegAllocate regs reserve_regs instrs
  39   = case simpleAlloc of
  40         Just x  -> x
  41         Nothing -> hairyAlloc
  42   where
  43     flatInstrs  = flattenOrdList instrs
  44     simpleAlloc = simpleRegAlloc regs [] emptyFM   flatInstrs
  45     hairyAlloc  = hairyRegAlloc  regs reserve_regs flatInstrs
  46
  47 runHairyRegAllocate             -- use only hairy for i386!
  48     :: MRegsState
  49     -> [RegNo]
  50     -> InstrList
  51     -> [Instr]
  52
  53 runHairyRegAllocate regs reserve_regs instrs
  54   = hairyRegAlloc regs reserve_regs flatInstrs
  55   where
  56     flatInstrs  = flattenOrdList instrs
  57 \end{code}
  58
  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
  64 we generate.
  65
  66 \begin{code}
  67 simpleRegAlloc
  68     :: MRegsState       -- registers to select from
  69     -> [Reg]            -- live static registers
  70     -> RegAssignment    -- mapping of dynamics to statics
  71     -> [Instr]          -- code
  72     -> Maybe [Instr]
  73
  74 simpleRegAlloc _ _ _ [] = Just []
  75
  76 simpleRegAlloc free live env (instr:instrs)
  77  | null deadSrcs        &&
  78    maybeToBool newAlloc &&
  79    maybeToBool instrs2
  80  = Just (instr3 : instrs3)
  81  | otherwise
  82  = Nothing
  83   where
  84     instr3 = patchRegs instr (lookup env2)
  85
  86     (srcs, dsts) = case regUsage instr of (RU s d) -> (regSetToList s, regSetToList d)
  87
  88     lookup env x = case lookupFM env x of Just y -> y; Nothing -> x
  89
  90     deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
  91     newDsts  = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
  92
  93     newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
  94     (free2, new) = case newAlloc of Just x -> x
  95
  96     env2 = env `addListToFM` new
  97
  98     live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
  99
 100     instrs2 = simpleRegAlloc free2 live2 env2 instrs
 101     instrs3 = case instrs2 of Just x -> x
 102
 103     allocateNewReg
 104         :: Reg
 105         -> Maybe (MRegsState, [(Reg, Reg)])
 106         -> Maybe (MRegsState, [(Reg, Reg)])
 107
 108     allocateNewReg _ Nothing = Nothing
 109
 110     allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs))
 111       | null choices = Nothing
 112       | otherwise    = Just (free2, prs2)
 113       where
 114         choices = possibleMRegs pk free
 115         reg     = head choices
 116         free2   = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
 117         prs2    = ((d,  MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
 118 \end{code}
 119
 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.
 123
 124 \begin{code}
 125 hairyRegAlloc
 126     :: MRegsState
 127     -> [RegNo]
 128     -> [Instr]
 129     -> [Instr]
 130
 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'
 135      | otherwise  ->
 136       let
 137        instrs_patched' = patchMem instrs'
 138        instrs_patched  = flattenOrdList instrs_patched'
 139       in
 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)
 145   where
 146     regs'  = regs `useMRegs` reserve_regs
 147     regs'' = mkMRegsState reserve_regs
 148
 149 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
 150 do_RegAlloc_Nil
 151     :: RegHistory MRegsState
 152     -> RegFuture
 153     -> Instr
 154     -> (RegHistory MRegsState, RegFuture, Instr)
 155
 156 noFuture :: RegFuture
 157 noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
 158 \end{code}
 159
 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.
 167
 168 \begin{code}
 169 patchMem :: [Instr] -> InstrList
 170
 171 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
 172
 173 patchMem' :: Instr -> InstrList
 174
 175 patchMem' instr
 176  | null memSrcs && null memDsts = mkUnitList instr
 177  | otherwise =
 178     mkSeqList
 179       (foldr mkParList mkEmptyList loadSrcs)
 180       (mkSeqList instr'
 181                  (foldr mkParList mkEmptyList spillDsts))
 182
 183     where
 184         (RU srcs dsts) = regUsage instr
 185
 186         memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
 187         memToDyn other            = other
 188
 189         memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
 190         memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
 191
 192         loadSrcs = map load memSrcs
 193         spillDsts = map spill memDsts
 194
 195         load mem = loadReg mem (memToDyn mem)
 196         spill mem = spillReg (memToDyn mem) mem
 197
 198         instr' = mkUnitList (patchRegs instr memToDyn)
 199 \end{code}
 200
 201 \begin{code}
 202 doRegAlloc
 203     :: [RegNo]
 204     -> RegHistory MRegsState
 205     -> RegFuture
 206     -> Instr
 207     -> (RegHistory MRegsState, RegFuture, Instr)
 208
 209 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
 210   where
 211       (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
 212       (in_use', info) = getUsage in_use instr
 213 \end{code}
 214
 215 \begin{code}
 216 getUsage
 217     :: RegFuture
 218     -> Instr
 219     -> (RegFuture, RegInfo Instr)
 220
 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
 230                in_use' = srcs `unionRegSets` live_through
 231
 232                reg_conflicts' =
 233                 case new_conflicts of
 234                   [] -> reg_conflicts
 235                   _  -> addListToFM reg_conflicts new_conflicts
 236
 237                new_conflicts
 238                 | isEmptyRegSet live_dynamics = []
 239                 | otherwise =
 240                   [ (r, merge_conflicts r)
 241                   | r <- extractMappedRegNos (regSetToList dsts) ]
 242
 243                merge_conflicts reg =
 244                 case lookupFM reg_conflicts reg of
 245                   Nothing        -> live_dynamics
 246                   Just conflicts -> conflicts `unionRegSets` live_dynamics
 247
 248                live_dynamics = mkRegSet [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
 249
 250 doRegAlloc'
 251     :: [RegNo]
 252     -> RegHistory MRegsState
 253     -> RegInfo Instr
 254     -> Instr
 255     -> (RegHistory MRegsState, Instr)
 256
 257 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
 258
 259     (RH frs'' loc' env'', patchRegs instr dynToStatic)
 260
 261     where
 262
 263       -- free up new registers
 264       free :: [RegNo]
 265       free = extractMappedRegNos (map dynToStatic lastu)
 266
 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
 270
 271       -- (2) allocate new registers for the destination operands
 272       -- allocate registers for new dynamics
 273
 274       new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ]
 275
 276       (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
 277
 278       env' = addListToFM env new
 279
 280       env'' = delListFromFM env' lastu
 281
 282       dynToStatic :: Reg -> Reg
 283       dynToStatic dyn@(UnmappedReg _ _) =
 284         case lookupFM env' dyn of
 285             Just r -> r
 286             Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
 287       dynToStatic other = other
 288
 289       allocateNewRegs :: Reg
 290                       -> (MRegsState, Int, [(Reg, Reg)])
 291                       -> (MRegsState, Int, [(Reg, Reg)])
 292
 293       allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
 294         where
 295          (fs', f, mem') =
 296            case acceptable fs of
 297             []           -> (fs, MemoryReg mem pk, mem + 1)
 298             (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
 299
 300          acceptable regs = filter no_conflict (possibleMRegs pk regs)
 301
 302          no_conflict reg =
 303            case lookupFM conflicts reg of
 304              Nothing        -> True
 305              Just conflicts -> not (d `elementOfRegSet` conflicts)
 306 \end{code}
 307
 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])
 310 \begin{code}
 311 not_elem x []       =  True
 312 not_elem x (y:ys)   =  x /= y && not_elem x ys
 313 \end{code}