compiler/nativeGen/RegSpill.hs

   1
   2 {-# OPTIONS_GHC -w #-}
   3 -- The above warning supression flag is a temporary kludge.
   4 -- While working on this module you are encouraged to remove it and fix
   5 -- any warnings in the module. See
   6 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
   7 -- for details
   8
   9 module RegSpill (
  10         regSpill,
  11         SpillStats(..),
  12         accSpillSL
  13 )
  14
  15 where
  16
  17 #include "HsVersions.h"
  18
  19 import RegLiveness
  20 import RegAllocInfo
  21 import MachRegs
  22 import MachInstrs
  23 import Cmm
  24
  25 import State
  26 import Unique
  27 import UniqFM
  28 import UniqSet
  29 import UniqSupply
  30 import Outputable
  31
  32 import Data.List
  33 import Data.Maybe
  34
  35
  36 -- | Spill all these virtual regs to memory
  37 --      TODO:   see if we can split some of the live ranges instead of just globally
  38 --              spilling the virtual reg.
  39 --
  40 --      TODO:   On ciscy x86 and x86_64 we don't nessesarally have to add a mov instruction
  41 --              when making spills. If an instr is using a spilled virtual we may be able to
  42 --              address the spill slot directly.
  43 --
  44 regSpill
  45         :: [LiveCmmTop]                 -- ^ the code
  46         -> UniqSet Int                  -- ^ available stack slots
  47         -> UniqSet Reg                  -- ^ the regs to spill
  48         -> UniqSM
  49                 ([LiveCmmTop]           -- code will spill instructions
  50                 , UniqSet Int           -- left over slots
  51                 , SpillStats )          -- stats about what happened during spilling
  52
  53 regSpill code slotsFree regs
  54
  55         -- not enough slots to spill these regs
  56         | sizeUniqSet slotsFree < sizeUniqSet regs
  57         = pprPanic "regSpill: out of spill slots!"
  58                 (  text "   regs to spill = " <> ppr (sizeUniqSet regs)
  59                 $$ text "   slots left    = " <> ppr (sizeUniqSet slotsFree))
  60
  61         | otherwise
  62         = do
  63                 -- allocate a slot for each of the spilled regs
  64                 let slots       = take (sizeUniqSet regs) $ uniqSetToList slotsFree
  65                 let regSlotMap  = listToUFM
  66                                 $ zip (uniqSetToList regs) slots
  67
  68                 -- grab the unique supply from the monad
  69                 us      <- getUs
  70
  71                 -- run the spiller on all the blocks
  72                 let (code', state')     =
  73                         runState (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
  74                                  (initSpillS us)
  75
  76                 return  ( code'
  77                         , minusUniqSet slotsFree (mkUniqSet slots)
  78                         , makeSpillStats state')
  79
  80
  81 regSpill_block regSlotMap (BasicBlock i instrs)
  82  = do   instrss'        <- mapM (regSpill_instr regSlotMap) instrs
  83         return  $ BasicBlock i (concat instrss')
  84
  85 regSpill_instr _        li@(Instr _ Nothing)
  86  = do   return [li]
  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    (instr', nReg)  <- patchInstr reg instr
 139
 140                 modify $ \s -> s
 141                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
 142
 143                 return  ( instr'
 144                         , ( [RELOAD slot nReg]
 145                           , []) )
 146
 147         | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
 148
 149 spillWrite regSlotMap instr reg
 150         | Just slot     <- lookupUFM regSlotMap reg
 151         = do    (instr', nReg)  <- patchInstr reg instr
 152
 153                 modify $ \s -> s
 154                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
 155
 156                 return  ( instr'
 157                         , ( []
 158                           , [SPILL nReg slot]))
 159
 160         | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
 161
 162 spillModify regSlotMap instr reg
 163         | Just slot     <- lookupUFM regSlotMap reg
 164         = do    (instr', nReg)  <- patchInstr reg instr
 165
 166                 modify $ \s -> s
 167                         { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
 168
 169                 return  ( instr'
 170                         , ( [RELOAD slot nReg]
 171                           , [SPILL nReg slot]))
 172
 173         | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
 174
 175
 176
 177 -- | rewrite uses of this virtual reg in an instr to use a different virtual reg
 178 patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
 179 patchInstr reg instr
 180  = do   nUnique         <- newUnique
 181         let nReg        = renameVirtualReg nUnique reg
 182         let instr'      = patchReg1 reg nReg instr
 183         return          (instr', nReg)
 184
 185 patchReg1 :: Reg -> Reg -> Instr -> Instr
 186 patchReg1 old new instr
 187  = let  patchF r
 188                 | r == old      = new
 189                 | otherwise     = r
 190    in   patchRegs instr patchF
 191
 192
 193 ------------------------------------------------------
 194 -- Spiller monad
 195
 196 data SpillS
 197         = SpillS
 198         { stateUS       :: UniqSupply
 199         , stateSpillSL  :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
 200
 201 initSpillS uniqueSupply
 202         = SpillS
 203         { stateUS       = uniqueSupply
 204         , stateSpillSL  = emptyUFM }
 205
 206 type SpillM a   = State SpillS a
 207
 208 newUnique :: SpillM Unique
 209 newUnique
 210  = do   us      <- gets stateUS
 211         case splitUniqSupply us of
 212          (us1, us2)
 213           -> do let uniq = uniqFromSupply us1
 214                 modify $ \s -> s { stateUS = us2 }
 215                 return uniq
 216
 217 accSpillSL (r1, s1, l1) (r2, s2, l2)
 218         = (r1, s1 + s2, l1 + l2)
 219
 220
 221 ----------------------------------------------------
 222 -- Spiller stats
 223
 224 data SpillStats
 225         = SpillStats
 226         { spillStoreLoad        :: UniqFM (Reg, Int, Int) }
 227
 228 makeSpillStats :: SpillS -> SpillStats
 229 makeSpillStats s
 230         = SpillStats
 231         { spillStoreLoad        = stateSpillSL s }
 232
 233 instance Outputable SpillStats where
 234  ppr stats
 235         = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
 236                         $ eltsUFM (spillStoreLoad stats))
 237