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 #include "HsVersions.h"
   8
   9 module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
  10
  11 import Ubiq{-uitous-}
  12
  13 import MachCode         ( InstrList(..) )
  14 import MachMisc         ( Instr )
  15 import MachRegs
  16 import RegAllocInfo
  17
  18 import BitSet           ( BitSet )
  19 import FiniteMap        ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
  20 import Maybes           ( maybeToBool )
  21 import OrdList          ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
  22                           flattenOrdList, OrdList
  23                         )
  24 import Stix             ( StixTree )
  25 import UniqSupply       ( mkBuiltinUnique )
  26 import Util             ( mapAccumB, panic )
  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   = if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
  81         Just (instr3 : instrs3)
  82     else
  83         Nothing
  84   where
  85     instr3 = patchRegs instr (lookup env2)
  86
  87     (srcs, dsts) = case regUsage instr of { RU s d -> (regSetToList s, regSetToList d) }
  88
  89     lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x}
  90
  91     deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
  92     newDsts  = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
  93
  94     newAlloc = foldr allocateNewReg (Just (free, [])) newDsts
  95     (free2, new) = case newAlloc of Just x -> x
  96
  97     env2 = env `addListToFM` new
  98
  99     live2 = map snd new ++ [x | x <- live, x `not_elem` dsts]
 100
 101     instrs2 = simpleRegAlloc free2 live2 env2 instrs
 102     instrs3 = case instrs2 of Just x -> x
 103
 104     allocateNewReg
 105         :: Reg
 106         -> Maybe (MRegsState, [(Reg, Reg)])
 107         -> Maybe (MRegsState, [(Reg, Reg)])
 108
 109     allocateNewReg _ Nothing = Nothing
 110
 111     allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) =
 112         if null choices then Nothing
 113         else Just (free2, prs2)
 114       where
 115         choices = possibleMRegs pk free
 116         reg = head choices
 117         free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
 118         prs2 = ((d,  MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
 119 \end{code}
 120
 121 Here is the ``clever'' bit. First go backward (i.e. left), looking for
 122 the last use of dynamic registers. Then go forward (i.e. right), filling
 123 registers with static placements.
 124
 125 \begin{code}
 126 hairyRegAlloc
 127     :: MRegsState
 128     -> [RegNo]
 129     -> [Instr]
 130     -> [Instr]
 131
 132 hairyRegAlloc regs reserve_regs instrs
 133   = case mapAccumB (doRegAlloc reserve_regs)
 134             (RH regs' 1 emptyFM) noFuture instrs
 135     of (RH _ loc' _, _, instrs') ->
 136         if loc' == 1 then instrs' else
 137         case mapAccumB do_RegAlloc_Nil
 138                 (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs'))
 139         of ((RH _ loc'' _),_,instrs'') ->
 140             if loc'' == loc' then instrs'' else panic "runRegAllocate"
 141   where
 142     regs'  = regs `useMRegs` reserve_regs
 143     regs'' = mkMRegsState reserve_regs
 144
 145 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
 146 do_RegAlloc_Nil
 147     :: RegHistory MRegsState
 148     -> RegFuture
 149     -> Instr
 150     -> (RegHistory MRegsState, RegFuture, Instr)
 151
 152 noFuture :: RegFuture
 153 noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
 154 \end{code}
 155
 156 Here we patch instructions that reference ``registers'' which are really in
 157 memory somewhere (the mapping is under the control of the machine-specific
 158 code generator).  We place the appropriate load sequences before any instructions
 159 that use memory registers as sources, and we place the appropriate spill sequences
 160 after any instructions that use memory registers as destinations.  The offending
 161 instructions are rewritten with new dynamic registers, so we have to run register
 162 allocation again after all of this is said and done.
 163
 164 \begin{code}
 165 patchMem :: [Instr] -> InstrList
 166
 167 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
 168
 169 patchMem' :: Instr -> InstrList
 170
 171 patchMem' instr
 172   = if null memSrcs && null memDsts then mkUnitList instr
 173     else mkSeqList
 174             (foldr mkParList mkEmptyList loadSrcs)
 175             (mkSeqList instr'
 176                 (foldr mkParList mkEmptyList spillDsts))
 177
 178     where
 179         (RU srcs dsts) = regUsage instr
 180
 181         memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
 182         memToDyn other            = other
 183
 184         memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
 185         memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
 186
 187         loadSrcs = map load memSrcs
 188         spillDsts = map spill memDsts
 189
 190         load mem = loadReg mem (memToDyn mem)
 191         spill mem = spillReg (memToDyn mem) mem
 192
 193         instr' = mkUnitList (patchRegs instr memToDyn)
 194 \end{code}
 195
 196 \begin{code}
 197 doRegAlloc
 198     :: [RegNo]
 199     -> RegHistory MRegsState
 200     -> RegFuture
 201     -> Instr
 202     -> (RegHistory MRegsState, RegFuture, Instr)
 203
 204 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
 205   where
 206       (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
 207       (in_use', info) = getUsage in_use instr
 208 \end{code}
 209
 210 \begin{code}
 211 getUsage
 212     :: RegFuture
 213     -> Instr
 214     -> (RegFuture, RegInfo Instr)
 215
 216 getUsage (RF next_in_use future reg_conflicts) instr
 217   = (RF in_use' future' reg_conflicts',
 218      RI in_use' srcs dsts last_used reg_conflicts')
 219          where (RU srcs dsts) = regUsage instr
 220                (RL in_use future') = regLiveness instr (RL next_in_use future)
 221                live_through = in_use `minusRegSet` dsts
 222                last_used = [ r | r <- regSetToList srcs,
 223                              not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)]
 224                in_use' = srcs `unionRegSets` live_through
 225                reg_conflicts' = case new_conflicts of
 226                     [] -> reg_conflicts
 227                     _ -> addListToFM reg_conflicts new_conflicts
 228                new_conflicts = if isEmptyRegSet live_dynamics then []
 229                                else [ (r, merge_conflicts r)
 230                                         | r <- extractMappedRegNos (regSetToList dsts) ]
 231                merge_conflicts reg = case lookupFM reg_conflicts reg of
 232                             Nothing -> live_dynamics
 233                             Just conflicts -> conflicts `unionRegSets` live_dynamics
 234                live_dynamics = mkRegSet
 235                             [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
 236
 237 doRegAlloc'
 238     :: [RegNo]
 239     -> RegHistory MRegsState
 240     -> RegInfo Instr
 241     -> Instr
 242     -> (RegHistory MRegsState, Instr)
 243
 244 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
 245
 246     (RH frs'' loc' env'', patchRegs instr dynToStatic)
 247
 248     where
 249
 250       -- free up new registers
 251       free :: [RegNo]
 252       free = extractMappedRegNos (map dynToStatic lastu)
 253
 254       -- (1) free registers that are used last as source operands in this instruction
 255       frs_not_in_use = frs `useMRegs` (extractMappedRegNos (regSetToList in_use))
 256       frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
 257
 258       -- (2) allocate new registers for the destination operands
 259       -- allocate registers for new dynamics
 260
 261       new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ]
 262
 263       (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
 264
 265       env' = addListToFM env new
 266
 267       env'' = delListFromFM env' lastu
 268
 269       dynToStatic :: Reg -> Reg
 270       dynToStatic dyn@(UnmappedReg _ _) =
 271         case lookupFM env' dyn of
 272             Just r -> r
 273             Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
 274       dynToStatic other = other
 275
 276       allocateNewRegs
 277         :: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)])
 278
 279       allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
 280         where (fs', f, mem') = case acceptable fs of
 281                 [] -> (fs, MemoryReg mem pk, mem + 1)
 282                 (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
 283
 284               acceptable regs = filter no_conflict (possibleMRegs pk regs)
 285               no_conflict reg = case lookupFM conflicts reg of
 286                     Nothing -> True
 287                     Just conflicts -> not (d `elementOfRegSet` conflicts)
 288 \end{code}
 289
 290 We keep a local copy of the Prelude function \tr{notElem},
 291 so that it can be specialised.  (Hack me gently.  [WDP 94/11])
 292 \begin{code}
 293 not_elem x []       =  True
 294 not_elem x (y:ys)   =  x /= y && not_elem x ys
 295 \end{code}