compiler/nativeGen/RegAlloc/Graph/Spill.hs

   1
   2 {-# OPTIONS -fno-warn-missing-signatures #-}
   3
   4 module RegAlloc.Graph.Spill (
   5         regSpill,
   6         SpillStats(..),
   7         accSpillSL
   8 )
   9
  10 where
  11
  12 import RegAlloc.Liveness
  13 import Instruction
  14 import Reg
  15 import Cmm
  16
  17 import State
  18 import Unique
  19 import UniqFM
  20 import UniqSet
  21 import UniqSupply
  22 import Outputable
  23
  24 import Data.List
  25 import Data.Maybe
  26
  27
  28 -- | Spill all these virtual regs to memory
  29 --      TODO:   see if we can split some of the live ranges instead of just globally
  30 --              spilling the virtual reg.
  31 --
  32 --      TODO:   On ciscy x86 and x86_64 we don't nessesarally have to add a mov instruction
  33 --              when making spills. If an instr is using a spilled virtual we may be able to
  34 --              address the spill slot directly.
  35 --
  36 regSpill
  37         :: Instruction instr
  38         => [LiveCmmTop instr]           -- ^ the code
  39         -> UniqSet Int                  -- ^ available stack slots
  40         -> UniqSet Reg                  -- ^ the regs to spill
  41         -> UniqSM
  42                 ([LiveCmmTop instr]     -- 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
  80         :: Instruction instr
  81         => UniqFM Int
  82         -> LiveInstr instr -> SpillM [LiveInstr instr]
  83
  84 -- | The thing we're spilling shouldn't already have spill or reloads in it
  85 regSpill_instr  _ SPILL{}
  86         = panic "regSpill_instr: unexpected SPILL"
  87
  88 regSpill_instr  _ RELOAD{}
  89         = panic "regSpill_instr: unexpected RELOAD"
  90
  91
  92 regSpill_instr _        li@(Instr _ Nothing)
  93  = do   return [li]
  94
  95 regSpill_instr regSlotMap
  96         (Instr instr (Just _))
  97  = do
  98         -- work out which regs are read and written in this instr
  99         let RU rlRead rlWritten = regUsageOfInstr instr
 100
 101         -- sometimes a register is listed as being read more than once,
 102         --      nub this so we don't end up inserting two lots of spill code.
 103         let rsRead_             = nub rlRead
 104         let rsWritten_          = nub rlWritten
 105
 106         -- if a reg is modified, it appears in both lists, want to undo this..
 107         let rsRead              = rsRead_    \\ rsWritten_
 108         let rsWritten           = rsWritten_ \\ rsRead_
 109         let rsModify            = intersect rsRead_ rsWritten_
 110
 111         -- work out if any of the regs being used are currently being spilled.
 112         let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
 113         let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
 114         let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
 115
 116         -- rewrite the instr and work out spill code.
 117         (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
 118         (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
 119         (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
 120
 121         let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)
 122         let prefixes                    = concat mPrefixes
 123         let postfixes                   = concat mPostfixes
 124
 125         -- final code
 126         let instrs'     =  prefixes
 127                         ++ [Instr instr3 Nothing]
 128                         ++ postfixes
 129
 130         return
 131 {-              $ pprTrace "* regSpill_instr spill"
 132                         (  text "instr  = " <> ppr instr
 133                         $$ text "read   = " <> ppr rsSpillRead
 134                         $$ text "write  = " <> ppr rsSpillWritten
 135                         $$ text "mod    = " <> ppr rsSpillModify
 136                         $$ text "-- out"
 137                         $$ (vcat $ map ppr instrs')
 138                         $$ text " ")
 139 -}
 140                 $ instrs'
 141
 142
 143 spillRead regSlotMap instr reg
 144         | Just slot     <- lookupUFM regSlotMap reg
 145         = do    (instr', nReg)  <- patchInstr reg instr
 146
 147                 modify $ \s -> s
 148                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
 149
 150                 return  ( instr'
 151                         , ( [RELOAD slot nReg]
 152                           , []) )
 153
 154         | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
 155
 156
 157 spillWrite regSlotMap instr reg
 158         | Just slot     <- lookupUFM regSlotMap reg
 159         = do    (instr', nReg)  <- patchInstr reg instr
 160
 161                 modify $ \s -> s
 162                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
 163
 164                 return  ( instr'
 165                         , ( []
 166                           , [SPILL nReg slot]))
 167
 168         | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
 169
 170
 171 spillModify regSlotMap instr reg
 172         | Just slot     <- lookupUFM regSlotMap reg
 173         = do    (instr', nReg)  <- patchInstr reg instr
 174
 175                 modify $ \s -> s
 176                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
 177
 178                 return  ( instr'
 179                         , ( [RELOAD slot nReg]
 180                           , [SPILL nReg slot]))
 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
 188         :: Instruction instr
 189         => Reg -> instr -> SpillM (instr, Reg)
 190
 191 patchInstr reg instr
 192  = do   nUnique         <- newUnique
 193         let nReg        = renameVirtualReg nUnique reg
 194         let instr'      = patchReg1 reg nReg instr
 195         return          (instr', nReg)
 196
 197 patchReg1
 198         :: Instruction instr
 199         => Reg -> Reg -> instr -> instr
 200
 201 patchReg1 old new instr
 202  = let  patchF r
 203                 | r == old      = new
 204                 | otherwise     = r
 205    in   patchRegsOfInstr instr patchF
 206
 207
 208 ------------------------------------------------------
 209 -- Spiller monad
 210
 211 data SpillS
 212         = SpillS
 213         { stateUS       :: UniqSupply
 214         , stateSpillSL  :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
 215
 216 initSpillS uniqueSupply
 217         = SpillS
 218         { stateUS       = uniqueSupply
 219         , stateSpillSL  = emptyUFM }
 220
 221 type SpillM a   = State SpillS a
 222
 223 newUnique :: SpillM Unique
 224 newUnique
 225  = do   us      <- gets stateUS
 226         case splitUniqSupply us of
 227          (us1, us2)
 228           -> do let uniq = uniqFromSupply us1
 229                 modify $ \s -> s { stateUS = us2 }
 230                 return uniq
 231
 232 accSpillSL (r1, s1, l1) (_, s2, l2)
 233         = (r1, s1 + s2, l1 + l2)
 234
 235
 236 ----------------------------------------------------
 237 -- Spiller stats
 238
 239 data SpillStats
 240         = SpillStats
 241         { spillStoreLoad        :: UniqFM (Reg, Int, Int) }
 242
 243 makeSpillStats :: SpillS -> SpillStats
 244 makeSpillStats s
 245         = SpillStats
 246         { spillStoreLoad        = stateSpillSL s }
 247
 248 instance Outputable SpillStats where
 249  ppr stats
 250         = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
 251                         $ eltsUFM (spillStoreLoad stats))
 252