ghc /compiler/nativeGen/RegAlloc/Graph/Spill.hs

Language Haskell Lines 344
MD5 Hash 53eccff17178a9b34f8de4fb701a4c48 Estimated Cost $5,510 (why?)
Repository https://bitbucket.org/carter/ghc.git View Raw File View Project SPDX
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
-- | When there aren't enough registers to hold all the vregs we have to spill some of those
--   vregs to slots on the stack. This module is used modify the code to use those slots.
--
module RegAlloc.Graph.Spill (
        regSpill,
        SpillStats(..),
        accSpillSL
)
where
import RegAlloc.Liveness
import Instruction
import Reg
import OldCmm hiding (RegSet)
import BlockId

import State
import Unique
import UniqFM
import UniqSet
import UniqSupply
import Outputable
import Platform

import Data.List
import Data.Maybe
import Data.Map                 (Map)
import Data.Set                 (Set)
import qualified Data.Map       as Map
import qualified Data.Set       as Set


-- | Spill all these virtual regs to stack slots.
--
--   TODO: See if we can split some of the live ranges instead of just globally
--         spilling the virtual reg. This might make the spill cleaner's job easier.
--
--   TODO: On CISCy x86 and x86_64 we don't nessesarally have to add a mov instruction
--         when making spills. If an instr is using a spilled virtual we may be able to
--         address the spill slot directly.
--
regSpill
        :: Instruction instr
        => Platform
        -> [LiveCmmDecl statics instr]  -- ^ the code
        -> UniqSet Int                  -- ^ available stack slots
        -> UniqSet VirtualReg           -- ^ the regs to spill
        -> UniqSM
                ([LiveCmmDecl statics instr] -- code with SPILL and RELOAD meta instructions added.
                , UniqSet Int               -- left over slots
                , SpillStats )              -- stats about what happened during spilling

regSpill platform code slotsFree regs

        -- not enough slots to spill these regs
        | sizeUniqSet slotsFree < sizeUniqSet regs
        = pprPanic "regSpill: out of spill slots!"
                (  text "   regs to spill = " <> ppr (sizeUniqSet regs)
                $$ text "   slots left    = " <> ppr (sizeUniqSet slotsFree))

        | otherwise
        = do
                -- allocate a slot for each of the spilled regs
                let slots       = take (sizeUniqSet regs) $ uniqSetToList slotsFree
                let regSlotMap  = listToUFM
                                $ zip (uniqSetToList regs) slots

                -- grab the unique supply from the monad
                us      <- getUs

                -- run the spiller on all the blocks
                let (code', state')     =
                        runState (mapM (regSpill_top platform regSlotMap) code)
                                 (initSpillS us)

                return  ( code'
                        , minusUniqSet slotsFree (mkUniqSet slots)
                        , makeSpillStats state')


-- | Spill some registers to stack slots in a top-level thing.
regSpill_top
        :: Instruction instr
        => Platform
        -> RegMap Int                   -- ^ map of vregs to slots they're being spilled to.
        -> LiveCmmDecl statics instr    -- ^ the top level thing.
        -> SpillM (LiveCmmDecl statics instr)

regSpill_top platform regSlotMap cmm
 = case cmm of
        CmmData{}
         -> return cmm

        CmmProc info label sccs
         |  LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info
         -> do
                -- We should only passed Cmms with the liveness maps filled in,  but we'll
                -- create empty ones if they're not there just in case.
                let liveVRegsOnEntry    = fromMaybe mapEmpty mLiveVRegsOnEntry

                -- The liveVRegsOnEntry contains the set of vregs that are live on entry to
                -- each basic block. If we spill one of those vregs we remove it from that
                -- set and add the corresponding slot number to the liveSlotsOnEntry set.
                -- The spill cleaner needs this information to erase unneeded spill and
                -- reload instructions after we've done a successful allocation.
                let liveSlotsOnEntry' :: Map BlockId (Set Int)
                    liveSlotsOnEntry'
                        = mapFoldWithKey patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry

                let info'
                        = LiveInfo static firstId
                                (Just liveVRegsOnEntry)
                                liveSlotsOnEntry'

                -- Apply the spiller to all the basic blocks in the CmmProc.
                sccs'           <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs

                return  $ CmmProc info' label sccs'

 where  -- | Given a BlockId and the set of registers live in it,
        --   if registers in this block are being spilled to stack slots,
        --   then record the fact that these slots are now live in those blocks
        --   in the given slotmap.
        patchLiveSlot :: BlockId -> RegSet -> Map BlockId (Set Int) -> Map BlockId (Set Int)
        patchLiveSlot blockId regsLive slotMap
         = let  curSlotsLive    = fromMaybe Set.empty
                                $ Map.lookup blockId slotMap

                moreSlotsLive   = Set.fromList
                                $ catMaybes
                                $ map (lookupUFM regSlotMap)
                                $ uniqSetToList regsLive

                slotMap'        = Map.insert blockId (Set.union curSlotsLive moreSlotsLive) slotMap

           in   slotMap'



-- | Spill some registers to stack slots in a basic block.
regSpill_block
        :: Instruction instr
        => Platform
        -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
        -> LiveBasicBlock instr
        -> SpillM (LiveBasicBlock instr)

regSpill_block platform regSlotMap (BasicBlock i instrs)
 = do   instrss'        <- mapM (regSpill_instr platform regSlotMap) instrs
        return  $ BasicBlock i (concat instrss')


-- | Spill some registers to stack slots in a single instruction.  If the instruction
--   uses registers that need to be spilled, then it is prefixed (or postfixed) with
--   the appropriate RELOAD or SPILL meta instructions.
regSpill_instr
        :: Instruction instr
        => Platform
        -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
        -> LiveInstr instr
        -> SpillM [LiveInstr instr]

regSpill_instr _ _ li@(LiveInstr _ Nothing)
 = do   return [li]

regSpill_instr platform regSlotMap
        (LiveInstr instr (Just _))
 = do
        -- work out which regs are read and written in this instr
        let RU rlRead rlWritten = regUsageOfInstr platform instr

        -- sometimes a register is listed as being read more than once,
        --      nub this so we don't end up inserting two lots of spill code.
        let rsRead_             = nub rlRead
        let rsWritten_          = nub rlWritten

        -- if a reg is modified, it appears in both lists, want to undo this..
        let rsRead              = rsRead_    \\ rsWritten_
        let rsWritten           = rsWritten_ \\ rsRead_
        let rsModify            = intersect rsRead_ rsWritten_

        -- work out if any of the regs being used are currently being spilled.
        let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
        let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
        let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify

        -- rewrite the instr and work out spill code.
        (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
        (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
        (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify

        let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)
        let prefixes                    = concat mPrefixes
        let postfixes                   = concat mPostfixes

        -- final code
        let instrs'     =  prefixes
                        ++ [LiveInstr instr3 Nothing]
                        ++ postfixes

        return
{-              $ pprTrace "* regSpill_instr spill"
                        (  text "instr  = " <> ppr instr
                        $$ text "read   = " <> ppr rsSpillRead
                        $$ text "write  = " <> ppr rsSpillWritten
                        $$ text "mod    = " <> ppr rsSpillModify
                        $$ text "-- out"
                        $$ (vcat $ map ppr instrs')
                        $$ text " ")
-}
                $ instrs'


spillRead
        :: Instruction instr
        => UniqFM Int
        -> instr
        -> Reg
        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillRead regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg
        = do    (instr', nReg)  <- patchInstr reg instr

                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }

                return  ( instr'
                        , ( [LiveInstr (RELOAD slot nReg) Nothing]
                          , []) )

        | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"


spillWrite
        :: Instruction instr
        => UniqFM Int
        -> instr
        -> Reg
        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillWrite regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg
        = do    (instr', nReg)  <- patchInstr reg instr

                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }

                return  ( instr'
                        , ( []
                          , [LiveInstr (SPILL nReg slot) Nothing]))

        | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"


spillModify
        :: Instruction instr
        => UniqFM Int
        -> instr
        -> Reg
        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
spillModify regSlotMap instr reg
        | Just slot     <- lookupUFM regSlotMap reg
        = do    (instr', nReg)  <- patchInstr reg instr

                modify $ \s -> s
                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }

                return  ( instr'
                        , ( [LiveInstr (RELOAD slot nReg) Nothing]
                          , [LiveInstr (SPILL nReg slot) Nothing]))

        | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"



-- | Rewrite uses of this virtual reg in an instr to use a different virtual reg
patchInstr
        :: Instruction instr
        => Reg -> instr -> SpillM (instr, Reg)

patchInstr reg instr
 = do   nUnique         <- newUnique
        let nReg        = case reg of
                                RegVirtual vr   -> RegVirtual (renameVirtualReg nUnique vr)
                                RegReal{}       -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
        let instr'      = patchReg1 reg nReg instr
        return          (instr', nReg)

patchReg1
        :: Instruction instr
        => Reg -> Reg -> instr -> instr

patchReg1 old new instr
 = let  patchF r
                | r == old      = new
                | otherwise     = r
   in   patchRegsOfInstr instr patchF


-- Spiller monad --------------------------------------------------------------
data SpillS
        = SpillS
        { -- | unique supply for generating fresh vregs.
          stateUS       :: UniqSupply

          -- | spilled vreg vs the number of times it was loaded, stored
        , stateSpillSL  :: UniqFM (Reg, Int, Int) }

initSpillS :: UniqSupply -> SpillS
initSpillS uniqueSupply
        = SpillS
        { stateUS       = uniqueSupply
        , stateSpillSL  = emptyUFM }

type SpillM a   = State SpillS a

newUnique :: SpillM Unique
newUnique
 = do   us      <- gets stateUS
        case takeUniqFromSupply us of
         (uniq, us')
          -> do modify $ \s -> s { stateUS = us' }
                return uniq

accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
accSpillSL (r1, s1, l1) (_, s2, l2)
        = (r1, s1 + s2, l1 + l2)


-- Spiller stats --------------------------------------------------------------
data SpillStats
        = SpillStats
        { spillStoreLoad        :: UniqFM (Reg, Int, Int) }

makeSpillStats :: SpillS -> SpillStats
makeSpillStats s
        = SpillStats
        { spillStoreLoad        = stateSpillSL s }

instance Outputable SpillStats where
 ppr stats
        = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
                        $ eltsUFM (spillStoreLoad stats))
Back to Top