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 IMP_Ubiq(){-uitous-}
  12
  13 import MachCode         ( SYN_IE(InstrList) )
  14 import MachMisc         ( Instr )
  15 import MachRegs
  16
  17 import RegAllocInfo
  18
  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
  25                         )
  26 import Stix             ( StixTree )
  27 import Unique           ( mkBuiltinUnique )
  28 import Util             ( mapAccumB, panic )
  29 \end{code}
  30
  31 This is the generic register allocator.
  32
  33 First we try something extremely simple.  If that fails, we have to do
  34 things the hard way.
  35
  36 \begin{code}
  37 runRegAllocate
  38     :: MRegsState
  39     -> [RegNo]
  40     -> InstrList
  41     -> [Instr]
  42
  43 runRegAllocate regs reserve_regs instrs
  44   = case simpleAlloc of
  45         Just x  -> x
  46         Nothing -> hairyAlloc
  47   where
  48     flatInstrs  = flattenOrdList instrs
  49     simpleAlloc = simpleRegAlloc regs [] emptyFM   flatInstrs
  50     hairyAlloc  = hairyRegAlloc  regs reserve_regs flatInstrs
  51
  52 runHairyRegAllocate             -- use only hairy for i386!
  53     :: MRegsState
  54     -> [RegNo]
  55     -> InstrList
  56     -> [Instr]
  57
  58 runHairyRegAllocate regs reserve_regs instrs
  59   = hairyRegAlloc regs reserve_regs flatInstrs
  60   where
  61     flatInstrs  = flattenOrdList instrs
  62 \end{code}
  63
  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
  69 we generate.
  70
  71 \begin{code}
  72 simpleRegAlloc
  73     :: MRegsState       -- registers to select from
  74     -> [Reg]            -- live static registers
  75     -> RegAssignment    -- mapping of dynamics to statics
  76     -> [Instr]          -- code
  77     -> Maybe [Instr]
  78
  79 simpleRegAlloc _ _ _ [] = Just []
  80
  81 simpleRegAlloc free live env (instr:instrs)
  82   = if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
  83         Just (instr3 : instrs3)
  84     else
  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         if null choices then Nothing
 115         else 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)
 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"
 143   where
 144     regs'  = regs `useMRegs` reserve_regs
 145     regs'' = mkMRegsState reserve_regs
 146
 147 do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh)
 148 do_RegAlloc_Nil
 149     :: RegHistory MRegsState
 150     -> RegFuture
 151     -> Instr
 152     -> (RegHistory MRegsState, RegFuture, Instr)
 153
 154 noFuture :: RegFuture
 155 noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
 156 \end{code}
 157
 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.
 165
 166 \begin{code}
 167 patchMem :: [Instr] -> InstrList
 168
 169 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
 170
 171 patchMem' :: Instr -> InstrList
 172
 173 patchMem' instr
 174   = if null memSrcs && null memDsts then mkUnitList instr
 175     else mkSeqList
 176             (foldr mkParList mkEmptyList loadSrcs)
 177             (mkSeqList instr'
 178                 (foldr mkParList mkEmptyList spillDsts))
 179
 180     where
 181         (RU srcs dsts) = regUsage instr
 182
 183         memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
 184         memToDyn other            = other
 185
 186         memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
 187         memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
 188
 189         loadSrcs = map load memSrcs
 190         spillDsts = map spill memDsts
 191
 192         load mem = loadReg mem (memToDyn mem)
 193         spill mem = spillReg (memToDyn mem) mem
 194
 195         instr' = mkUnitList (patchRegs instr memToDyn)
 196 \end{code}
 197
 198 \begin{code}
 199 doRegAlloc
 200     :: [RegNo]
 201     -> RegHistory MRegsState
 202     -> RegFuture
 203     -> Instr
 204     -> (RegHistory MRegsState, RegFuture, Instr)
 205
 206 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
 207   where
 208       (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
 209       (in_use', info) = getUsage in_use instr
 210 \end{code}
 211
 212 \begin{code}
 213 getUsage
 214     :: RegFuture
 215     -> Instr
 216     -> (RegFuture, RegInfo Instr)
 217
 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
 228                     [] -> reg_conflicts
 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 ]
 238
 239 doRegAlloc'
 240     :: [RegNo]
 241     -> RegHistory MRegsState
 242     -> RegInfo Instr
 243     -> Instr
 244     -> (RegHistory MRegsState, Instr)
 245
 246 doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr =
 247
 248     (RH frs'' loc' env'', patchRegs instr dynToStatic)
 249
 250     where
 251
 252       -- free up new registers
 253       free :: [RegNo]
 254       free = extractMappedRegNos (map dynToStatic lastu)
 255
 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
 259
 260       -- (2) allocate new registers for the destination operands
 261       -- allocate registers for new dynamics
 262
 263       new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ]
 264
 265       (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
 266
 267       env' = addListToFM env new
 268
 269       env'' = delListFromFM env' lastu
 270
 271       dynToStatic :: Reg -> Reg
 272       dynToStatic dyn@(UnmappedReg _ _) =
 273         case lookupFM env' dyn of
 274             Just r -> r
 275             Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
 276       dynToStatic other = other
 277
 278       allocateNewRegs
 279         :: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)])
 280
 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)
 285
 286               acceptable regs = filter no_conflict (possibleMRegs pk regs)
 287               no_conflict reg = case lookupFM conflicts reg of
 288                     Nothing -> True
 289                     Just conflicts -> not (d `elementOfRegSet` conflicts)
 290 \end{code}
 291
 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])
 294 \begin{code}
 295 not_elem x []       =  True
 296 not_elem x (y:ys)   =  x /= y && not_elem x ys
 297 \end{code}