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 VirtualReg           -- ^ 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        = case reg of
 194                                 RegVirtual vr   -> RegVirtual (renameVirtualReg nUnique vr)
 195                                 RegReal{}       -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
 196         let instr'      = patchReg1 reg nReg instr
 197         return          (instr', nReg)
 198
 199 patchReg1
 200         :: Instruction instr
 201         => Reg -> Reg -> instr -> instr
 202
 203 patchReg1 old new instr
 204  = let  patchF r
 205                 | r == old      = new
 206                 | otherwise     = r
 207    in   patchRegsOfInstr instr patchF
 208
 209
 210 ------------------------------------------------------
 211 -- Spiller monad
 212
 213 data SpillS
 214         = SpillS
 215         { stateUS       :: UniqSupply
 216         , stateSpillSL  :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
 217
 218 initSpillS uniqueSupply
 219         = SpillS
 220         { stateUS       = uniqueSupply
 221         , stateSpillSL  = emptyUFM }
 222
 223 type SpillM a   = State SpillS a
 224
 225 newUnique :: SpillM Unique
 226 newUnique
 227  = do   us      <- gets stateUS
 228         case splitUniqSupply us of
 229          (us1, us2)
 230           -> do let uniq = uniqFromSupply us1
 231                 modify $ \s -> s { stateUS = us2 }
 232                 return uniq
 233
 234 accSpillSL (r1, s1, l1) (_, s2, l2)
 235         = (r1, s1 + s2, l1 + l2)
 236
 237
 238 ----------------------------------------------------
 239 -- Spiller stats
 240
 241 data SpillStats
 242         = SpillStats
 243         { spillStoreLoad        :: UniqFM (Reg, Int, Int) }
 244
 245 makeSpillStats :: SpillS -> SpillStats
 246 makeSpillStats s
 247         = SpillStats
 248         { spillStoreLoad        = stateSpillSL s }
 249
 250 instance Outputable SpillStats where
 251  ppr stats
 252         = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
 253                         $ eltsUFM (spillStoreLoad stats))
 254