compiler/nativeGen/RegSpill.hs

   1
   2 module RegSpill (
   3         regSpill
   4 )
   5
   6 where
   7
   8 #include "HsVersions.h"
   9
  10 import RegLiveness
  11 import RegAllocInfo
  12 import MachRegs
  13 import MachInstrs
  14 import Cmm
  15
  16 import Unique
  17 import UniqFM
  18 import UniqSet
  19 import UniqSupply
  20 import Outputable
  21
  22 import Data.List
  23 import Data.Maybe
  24
  25
  26 -- | Spill all these virtual regs to memory
  27 --      TODO:   see if we can split some of the live ranges instead of just globally
  28 --              spilling the virtual reg.
  29 --
  30 --      TODO:   On ciscy x86 and x86_64 we don't nessesarally have to add a mov instruction
  31 --              when making spills. If an instr is using a spilled virtual we may be able to
  32 --              address the spill slot directly.
  33 --
  34 regSpill
  35         :: [LiveCmmTop]                 -- ^ the code
  36         -> UniqSet Int                  -- ^ available stack slots
  37         -> UniqSet Reg                  -- ^ the regs to spill
  38         -> UniqSM
  39                 ([LiveCmmTop]           -- ^ code will spill instructions
  40                 , UniqSet Int)          -- ^ left over slots
  41
  42 regSpill code slotsFree regs
  43
  44         -- not enough slots to spill these regs
  45         | sizeUniqSet slotsFree < sizeUniqSet regs
  46         = pprPanic "regSpill: out of spill slots!"
  47                 (  text "   regs to spill = " <> ppr (sizeUniqSet regs)
  48                 $$ text "   slots left    = " <> ppr (sizeUniqSet slotsFree))
  49
  50         | otherwise
  51         = do
  52                 -- allocate a slot for each of the spilled regs
  53                 let slots       = take (sizeUniqSet regs) $ uniqSetToList slotsFree
  54                 let regSlotMap  = listToUFM
  55                                 $ zip (uniqSetToList regs) slots
  56
  57                 -- grab the unique supply from the monad
  58                 us      <- getUs
  59
  60                 -- run the spiller on all the blocks
  61                 let (# code', _ #)      =
  62                         runSpill (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
  63                                  (initSpillS us)
  64
  65                 return  ( code'
  66                         , minusUniqSet slotsFree (mkUniqSet slots) )
  67
  68
  69 regSpill_block regSlotMap (BasicBlock i instrs)
  70  = do   instrss'        <- mapM (regSpill_instr regSlotMap) instrs
  71         return  $ BasicBlock i (concat instrss')
  72
  73
  74 regSpill_instr _        li@(Instr (DELTA delta) _)
  75  = do
  76         setDelta delta
  77         return [li]
  78
  79 regSpill_instr _        li@(Instr _ Nothing)
  80  = do   return [li]
  81
  82
  83 regSpill_instr regSlotMap
  84         (Instr instr (Just live))
  85  = do
  86         -- work out which regs are read and written in this instr
  87         let RU rlRead rlWritten = regUsage instr
  88
  89         -- sometimes a register is listed as being read more than once,
  90         --      nub this so we don't end up inserting two lots of spill code.
  91         let rsRead_             = nub rlRead
  92         let rsWritten_          = nub rlWritten
  93
  94         -- if a reg is modified, it appears in both lists, want to undo this..
  95         let rsRead              = rsRead_    \\ rsWritten_
  96         let rsWritten           = rsWritten_ \\ rsRead_
  97         let rsModify            = intersect rsRead_ rsWritten_
  98
  99         -- work out if any of the regs being used are currently being spilled.
 100         let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
 101         let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
 102         let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
 103
 104         -- rewrite the instr and work out spill code.
 105         (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
 106         (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
 107         (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
 108
 109         let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)
 110         let prefixes                    = concat mPrefixes
 111         let postfixes                   = concat mPostfixes
 112
 113         -- final code
 114         let instrs'     =  map (\i -> Instr i Nothing) prefixes
 115                         ++ [ Instr instr3 Nothing ]
 116                         ++ map (\i -> Instr i Nothing) postfixes
 117
 118         return
 119 {-              $ pprTrace "* regSpill_instr spill"
 120                         (  text "instr  = " <> ppr instr
 121                         $$ text "read   = " <> ppr rsSpillRead
 122                         $$ text "write  = " <> ppr rsSpillWritten
 123                         $$ text "mod    = " <> ppr rsSpillModify
 124                         $$ text "-- out"
 125                         $$ (vcat $ map ppr instrs')
 126                         $$ text " ")
 127 -}
 128                 $ instrs'
 129
 130
 131 spillRead regSlotMap instr reg
 132         | Just slot     <- lookupUFM regSlotMap reg
 133         = do    delta           <- getDelta
 134                 (instr', nReg)  <- patchInstr reg instr
 135
 136                 let pre         = [ COMMENT FSLIT("spill read")
 137                                   , mkLoadInstr nReg delta slot ]
 138
 139                 return  ( instr', (pre, []))
 140
 141         | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
 142
 143 spillWrite regSlotMap instr reg
 144         | Just slot     <- lookupUFM regSlotMap reg
 145         = do    delta           <- getDelta
 146                 (instr', nReg)  <- patchInstr reg instr
 147
 148                 let post        = [ COMMENT FSLIT("spill write")
 149                                   , mkSpillInstr nReg delta slot ]
 150
 151                 return  ( instr', ([], post))
 152
 153         | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
 154
 155 spillModify regSlotMap instr reg
 156         | Just slot     <- lookupUFM regSlotMap reg
 157         = do    delta           <- getDelta
 158                 (instr', nReg)  <- patchInstr reg instr
 159
 160                 let pre         = [ COMMENT FSLIT("spill mod load")
 161                                   , mkLoadInstr  nReg delta slot ]
 162
 163                 let post        = [ COMMENT FSLIT("spill mod write")
 164                                   , mkSpillInstr nReg delta slot ]
 165
 166                 return  ( instr', (pre, post))
 167
 168         | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
 169
 170
 171 -- | rewrite uses of this virtual reg in an instr to use a different virtual reg
 172 patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
 173 patchInstr reg instr
 174  = do   nUnique         <- newUnique
 175         let nReg        = renameVirtualReg nUnique reg
 176         let instr'      = patchReg1 reg nReg instr
 177         return          (instr', nReg)
 178
 179 patchReg1 :: Reg -> Reg -> Instr -> Instr
 180 patchReg1 old new instr
 181  = let  patchF r
 182                 | r == old      = new
 183                 | otherwise     = r
 184    in   patchRegs instr patchF
 185
 186
 187 -------------------------------------------------------------------------------------------
 188 -- Spiller monad
 189
 190 data SpillS
 191         = SpillS
 192         { stateDelta    :: Int
 193         , stateUS       :: UniqSupply }
 194
 195 initSpillS uniqueSupply
 196         = SpillS
 197         { stateDelta    = 0
 198         , stateUS       = uniqueSupply }
 199
 200 newtype SpillM a
 201         = SpillM
 202         { runSpill :: SpillS  -> (# a, SpillS #) }
 203
 204 instance Monad SpillM where
 205     return x    = SpillM $ \s -> (# x, s #)
 206
 207     m >>= n     = SpillM $ \s ->
 208                         case runSpill m s of
 209                           (# r, s' #)   -> runSpill (n r) s'
 210
 211 setDelta :: Int -> SpillM ()
 212 setDelta delta
 213         = SpillM $ \s -> (# (), s { stateDelta = delta } #)
 214
 215 getDelta  :: SpillM Int
 216 getDelta = SpillM $ \s -> (# stateDelta s, s #)
 217
 218 newUnique :: SpillM Unique
 219 newUnique
 220         = SpillM $ \s
 221         -> case splitUniqSupply (stateUS s) of
 222                 (us1, us2)
 223                   ->    (# uniqFromSupply us1
 224                         , s { stateUS = us2 } #)
 225
 226 mapAccumLM _ s []       = return (s, [])
 227 mapAccumLM f s (x:xs)
 228  = do
 229         (s1, x')        <- f s x
 230         (s2, xs')       <- mapAccumLM f s1 xs
 231         return          (s2, x' : xs')
 232
 233