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 -> trace (spillMsg True) (Just instrs'')
 167                      -- no; we have to give up
 168                      | otherwise      -> trace (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 \end{code}
 186
 187 Here we patch instructions that reference ``registers'' which are
 188 really in memory somewhere (the mapping is under the control of the
 189 machine-specific code generator).  We place the appropriate load
 190 sequences before any instructions that use memory registers as
 191 sources, and we place the appropriate spill sequences after any
 192 instructions that use memory registers as destinations.  The offending
 193 instructions are rewritten with new dynamic registers, so we have to
 194 run register allocation again after all of this is said and done.
 195
 196 On some architectures (x86, currently), we do without a frame-pointer,
 197 and instead spill relative to the stack pointer (%esp on x86).
 198 Because the stack pointer may move, the patcher needs to keep track of
 199 the current stack pointer "delta".  That's easy, because all it needs
 200 to do is spot the DELTA bogus-insns which will have been inserted by
 201 the relevant insn selector precisely so as to notify the spiller of
 202 stack-pointer movement.  The delta is passed to loadReg and spillReg,
 203 since they generate the actual spill code.  We expect the final delta
 204 to be the same as the starting one (zero), reflecting the fact that
 205 changes to the stack pointer should not extend beyond a basic block.
 206
 207 \begin{code}
 208 patchMem :: [Instr] -> [Instr]
 209 patchMem cs
 210    = let (final_stack_delta, css) = mapAccumL patchMem' 0 cs
 211      in
 212          if   final_stack_delta == 0
 213          then concat css
 214          else pprPanic "patchMem: non-zero final delta"
 215                        (int final_stack_delta)
 216
 217 patchMem' :: Int -> Instr -> (Int, [Instr])
 218 patchMem' delta instr
 219
 220  | null memSrcs && null memDsts
 221  = (delta', [instr])
 222
 223  | otherwise
 224  = (delta', loadSrcs ++ [instr'] ++ spillDsts)
 225    where
 226         delta' = case instr of DELTA d -> d ; _ -> delta
 227
 228         (RU srcs dsts) = regUsage instr
 229
 230         memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
 231         memToDyn other            = other
 232
 233         memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
 234         memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
 235
 236         loadSrcs  = map load memSrcs
 237         spillDsts = map spill memDsts
 238
 239         load mem  = loadReg  delta  mem (memToDyn mem)
 240         spill mem = spillReg delta' (memToDyn mem) mem
 241
 242         instr'    = patchRegs instr memToDyn
 243 \end{code}
 244
 245 \begin{code}
 246 doRegAlloc
 247     :: [RegNo]
 248     -> RegHistory MRegsState
 249     -> RegFuture
 250     -> Instr
 251     -> (RegHistory MRegsState, RegFuture, Instr)
 252
 253 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
 254   where
 255       (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
 256       (in_use', info) = getUsage in_use instr
 257 \end{code}
 258
 259 \begin{code}
 260 getUsage
 261     :: RegFuture
 262     -> Instr
 263     -> (RegFuture, RegInfo Instr)
 264
 265 getUsage (RF next_in_use future reg_conflicts) instr
 266   = (RF in_use' future' reg_conflicts',
 267      RI in_use' srcs dsts last_used reg_conflicts')
 268          where (RU srcs dsts) = regUsage instr
 269                (RL in_use future') = regLiveness instr (RL next_in_use future)
 270                live_through = in_use `minusRegSet` dsts
 271                last_used = [ r | r <- regSetToList srcs,
 272                              not (r `elementOfRegSet` (fstFL future)
 273                                   || r `elementOfRegSet` in_use)]
 274
 275                in_use' = srcs `unionRegSets` live_through
 276
 277                reg_conflicts' =
 278                 case new_conflicts of
 279                   [] -> reg_conflicts
 280                   _  -> addListToFM reg_conflicts new_conflicts
 281
 282                new_conflicts
 283                 | isEmptyRegSet live_dynamics = []
 284                 | otherwise =
 285                   [ (r, merge_conflicts r)
 286                   | r <- extractMappedRegNos (regSetToList dsts) ]
 287
 288                merge_conflicts reg =
 289                 case lookupFM reg_conflicts reg of
 290                   Nothing        -> live_dynamics
 291                   Just conflicts -> conflicts `unionRegSets` live_dynamics
 292
 293                live_dynamics
 294                   = mkRegSet [ r | r@(UnmappedReg _ _)
 295                                       <- regSetToList live_through ]
 296
 297 doRegAlloc'
 298     :: [RegNo]
 299     -> RegHistory MRegsState
 300     -> RegInfo Instr
 301     -> Instr
 302     -> (RegHistory MRegsState, Instr)
 303
 304 doRegAlloc' reserved (RH frs loc env)
 305                      (RI in_use srcs dsts lastu conflicts) instr =
 306
 307     (RH frs'' loc' env'', patchRegs instr dynToStatic)
 308
 309     where
 310
 311       -- free up new registers
 312       free :: [RegNo]
 313       free = extractMappedRegNos (map dynToStatic lastu)
 314
 315       -- (1) free registers that are used last as
 316       --     source operands in this instruction
 317       frs_not_in_use = frs `useMRegs`
 318                        (extractMappedRegNos (regSetToList in_use))
 319       frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
 320
 321       -- (2) allocate new registers for the destination operands
 322       -- allocate registers for new dynamics
 323
 324       new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts,
 325                           r `not_elem` keysFM env ]
 326
 327       (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
 328
 329       env' = addListToFM env new
 330
 331       env'' = delListFromFM env' lastu
 332
 333       dynToStatic :: Reg -> Reg
 334       dynToStatic dyn@(UnmappedReg _ _) =
 335         case lookupFM env' dyn of
 336             Just r -> r
 337             Nothing -> trace ("Lost register; possibly a floating point"
 338                               ++" type error in a _ccall_?") dyn
 339       dynToStatic other = other
 340
 341       allocateNewRegs :: Reg
 342                       -> (MRegsState, Int, [(Reg, Reg)])
 343                       -> (MRegsState, Int, [(Reg, Reg)])
 344
 345       allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst)
 346          = (fs', mem', (d, f) : lst)
 347         where
 348          (fs', f, mem') =
 349            case acceptable fs of
 350             []           -> (fs, MemoryReg mem pk, mem + 1)
 351             (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
 352
 353          acceptable regs = filter no_conflict (possibleMRegs pk regs)
 354
 355          no_conflict reg =
 356            case lookupFM conflicts reg of
 357              Nothing        -> True
 358              Just conflicts -> not (d `elementOfRegSet` conflicts)
 359 \end{code}
 360
 361 We keep a local copy of the Prelude function \tr{notElem},
 362 so that it can be specialised.  (Hack me gently.  [WDP 94/11])
 363 \begin{code}
 364 not_elem x []       =  True
 365 not_elem x (y:ys)   =  x /= y && not_elem x ys
 366 \end{code}