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