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 PprMach          ( pprUserReg ) -- debugging
  14 import MachRegs
  15 import RegAllocInfo
  16
  17 import FiniteMap        ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
  18 import Maybes           ( maybeToBool )
  19 import OrdList          ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
  20                           flattenOrdList, OrdList
  21                         )
  22 import Unique           ( mkBuiltinUnique )
  23 import Util             ( mapAccumB )
  24 import Outputable
  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     -> InstrList
  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       = flattenOrdList instrs
  53     simpleAlloc      = simpleRegAlloc regs [] emptyFM   flatInstrs
  54     hairyAlloc resvd = hairyRegAlloc  regs resvd flatInstrs
  55
  56
  57 runHairyRegAllocate
  58     :: MRegsState
  59     -> [RegNo]
  60     -> InstrList
  61     -> Maybe [Instr]
  62
  63 runHairyRegAllocate regs reserve_regs instrs
  64   = hairyRegAlloc regs reserve_regs flatInstrs
  65   where
  66     flatInstrs  = flattenOrdList 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                instrs_patched  = flattenOrdList instrs_patched'
 162            in
 163                case mapAccumB (doRegAlloc []) (RH regs'' mloc1 emptyFM)
 164                     noFuture instrs_patched of
 165                   ((RH _ mloc2 _),_,instrs'')
 166                      -- successfully allocated the patched code
 167                      | mloc2 == mloc1 -> trace (spillMsg True) (Just instrs'')
 168                      -- no; we have to give up
 169                      | otherwise      -> trace (spillMsg False) Nothing
 170                        -- instrs''
 171   where
 172     regs'  = regs `useMRegs` reserve_regs
 173     regs'' = mkMRegsState reserve_regs
 174
 175     noFuture :: RegFuture
 176     noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM
 177
 178     spillMsg success
 179        = "nativeGen: spilling "
 180          ++ (if success then "succeeded" else "failed   ")
 181          ++ " using "
 182          ++ showSDoc (hsep (map (pprUserReg.toMappedReg)
 183                                 (reverse reserve_regs)))
 184          where
 185             toMappedReg (I# i) = MappedReg i
 186 \end{code}
 187
 188 Here we patch instructions that reference ``registers'' which are really in
 189 memory somewhere (the mapping is under the control of the machine-specific
 190 code generator).  We place the appropriate load sequences before any instructions
 191 that use memory registers as sources, and we place the appropriate spill sequences
 192 after any instructions that use memory registers as destinations.  The offending
 193 instructions are rewritten with new dynamic registers, so we have to run register
 194 allocation again after all of this is said and done.
 195
 196 \begin{code}
 197 patchMem :: [Instr] -> InstrList
 198
 199 patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
 200
 201 patchMem' :: Instr -> InstrList
 202
 203 patchMem' instr
 204  | null memSrcs && null memDsts = mkUnitList instr
 205  | otherwise =
 206     mkSeqList
 207       (foldr mkParList mkEmptyList loadSrcs)
 208       (mkSeqList instr'
 209                  (foldr mkParList mkEmptyList spillDsts))
 210
 211     where
 212         (RU srcs dsts) = regUsage instr
 213
 214         memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk
 215         memToDyn other            = other
 216
 217         memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs]
 218         memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts]
 219
 220         loadSrcs = map load memSrcs
 221         spillDsts = map spill memDsts
 222
 223         load mem = loadReg mem (memToDyn mem)
 224         spill mem = spillReg (memToDyn mem) mem
 225
 226         instr' = mkUnitList (patchRegs instr memToDyn)
 227 \end{code}
 228
 229 \begin{code}
 230 doRegAlloc
 231     :: [RegNo]
 232     -> RegHistory MRegsState
 233     -> RegFuture
 234     -> Instr
 235     -> (RegHistory MRegsState, RegFuture, Instr)
 236
 237 doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr')
 238   where
 239       (free_env', instr') = doRegAlloc' reserved_regs free_env info instr
 240       (in_use', info) = getUsage in_use instr
 241 \end{code}
 242
 243 \begin{code}
 244 getUsage
 245     :: RegFuture
 246     -> Instr
 247     -> (RegFuture, RegInfo Instr)
 248
 249 getUsage (RF next_in_use future reg_conflicts) instr
 250   = (RF in_use' future' reg_conflicts',
 251      RI in_use' srcs dsts last_used reg_conflicts')
 252          where (RU srcs dsts) = regUsage instr
 253                (RL in_use future') = regLiveness instr (RL next_in_use future)
 254                live_through = in_use `minusRegSet` dsts
 255                last_used = [ r | r <- regSetToList srcs,
 256                              not (r `elementOfRegSet` (fstFL future)
 257                                   || r `elementOfRegSet` in_use)]
 258
 259                in_use' = srcs `unionRegSets` live_through
 260
 261                reg_conflicts' =
 262                 case new_conflicts of
 263                   [] -> reg_conflicts
 264                   _  -> addListToFM reg_conflicts new_conflicts
 265
 266                new_conflicts
 267                 | isEmptyRegSet live_dynamics = []
 268                 | otherwise =
 269                   [ (r, merge_conflicts r)
 270                   | r <- extractMappedRegNos (regSetToList dsts) ]
 271
 272                merge_conflicts reg =
 273                 case lookupFM reg_conflicts reg of
 274                   Nothing        -> live_dynamics
 275                   Just conflicts -> conflicts `unionRegSets` live_dynamics
 276
 277                live_dynamics
 278                   = mkRegSet [ r | r@(UnmappedReg _ _)
 279                                       <- regSetToList live_through ]
 280
 281 doRegAlloc'
 282     :: [RegNo]
 283     -> RegHistory MRegsState
 284     -> RegInfo Instr
 285     -> Instr
 286     -> (RegHistory MRegsState, Instr)
 287
 288 doRegAlloc' reserved (RH frs loc env)
 289                      (RI in_use srcs dsts lastu conflicts) instr =
 290
 291     (RH frs'' loc' env'', patchRegs instr dynToStatic)
 292
 293     where
 294
 295       -- free up new registers
 296       free :: [RegNo]
 297       free = extractMappedRegNos (map dynToStatic lastu)
 298
 299       -- (1) free registers that are used last as
 300       --     source operands in this instruction
 301       frs_not_in_use = frs `useMRegs`
 302                        (extractMappedRegNos (regSetToList in_use))
 303       frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved
 304
 305       -- (2) allocate new registers for the destination operands
 306       -- allocate registers for new dynamics
 307
 308       new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts,
 309                           r `not_elem` keysFM env ]
 310
 311       (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix
 312
 313       env' = addListToFM env new
 314
 315       env'' = delListFromFM env' lastu
 316
 317       dynToStatic :: Reg -> Reg
 318       dynToStatic dyn@(UnmappedReg _ _) =
 319         case lookupFM env' dyn of
 320             Just r -> r
 321             Nothing -> trace ("Lost register; possibly a floating point"
 322                               ++" type error in a _ccall_?") dyn
 323       dynToStatic other = other
 324
 325       allocateNewRegs :: Reg
 326                       -> (MRegsState, Int, [(Reg, Reg)])
 327                       -> (MRegsState, Int, [(Reg, Reg)])
 328
 329       allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst)
 330          = (fs', mem', (d, f) : lst)
 331         where
 332          (fs', f, mem') =
 333            case acceptable fs of
 334             []           -> (fs, MemoryReg mem pk, mem + 1)
 335             (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
 336
 337          acceptable regs = filter no_conflict (possibleMRegs pk regs)
 338
 339          no_conflict reg =
 340            case lookupFM conflicts reg of
 341              Nothing        -> True
 342              Just conflicts -> not (d `elementOfRegSet` conflicts)
 343 \end{code}
 344
 345 We keep a local copy of the Prelude function \tr{notElem},
 346 so that it can be specialised.  (Hack me gently.  [WDP 94/11])
 347 \begin{code}
 348 not_elem x []       =  True
 349 not_elem x (y:ys)   =  x /= y && not_elem x ys
 350 \end{code}