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