ghc/compiler/nativeGen/AsmRegAlloc.lhs

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