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