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