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