compiler/nativeGen/RegSpill.hs

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