compiler/nativeGen/RegSpillClean.hs

   1 -- | Clean out unneeded spill/reload instrs
   2 --
   3 -- * Handling of join points
   4 --
   5 --   B1:                          B2:
   6 --    ...                          ...
   7 --       RELOAD SLOT(0), %r1          RELOAD SLOT(0), %r1
   8 --       ... A ...                    ... B ...
   9 --       jump B3                      jump B3
  10 --
  11 --                B3: ... C ...
  12 --                    RELOAD SLOT(0), %r1
  13 --                    ...
  14 --
  15 -- the plan:
  16 --      So long as %r1 hasn't been written to in A, B or C then we don't need the
  17 --      reload in B3.
  18 --
  19 --      What we really care about here is that on the entry to B3, %r1 will always
  20 --      have the same value that is in SLOT(0) (ie, %r1 is _valid_)
  21 --
  22 --      This also works if the reloads in B1/B2 were spills instead, because
  23 --      spilling %r1 to a slot makes that slot have the same value as %r1.
  24 --
  25
  26 module RegSpillClean (
  27         cleanSpills
  28 )
  29 where
  30
  31 import RegLiveness
  32 import RegAllocInfo
  33 import MachRegs
  34 import MachInstrs
  35 import Cmm
  36
  37 import UniqSet
  38 import UniqFM
  39 import Unique
  40 import State
  41 import Outputable
  42 import Util
  43
  44 import Data.Maybe
  45 import Data.List        ( find, nub )
  46
  47 -- | Clean out unneeded spill/reloads from this top level thing.
  48 cleanSpills :: LiveCmmTop -> LiveCmmTop
  49 cleanSpills cmm
  50         = evalState (cleanSpin 0 cmm) initCleanS
  51
  52 -- | do one pass of cleaning
  53 cleanSpin :: Int -> LiveCmmTop -> CleanM LiveCmmTop
  54
  55 {-
  56 cleanSpin spinCount code
  57  = do   jumpValid       <- gets sJumpValid
  58         pprTrace "cleanSpin"
  59                 (  int spinCount
  60                 $$ text "--- code"
  61                 $$ ppr code
  62                 $$ text "--- joins"
  63                 $$ ppr jumpValid)
  64          $ cleanSpin' spinCount code
  65 -}
  66
  67 cleanSpin spinCount code
  68  = do
  69         -- init count of cleaned spills/reloads
  70         modify $ \s -> s
  71                 { sCleanedSpillsAcc     = 0
  72                 , sCleanedReloadsAcc    = 0 }
  73
  74         code'   <- mapBlockTopM cleanBlock code
  75
  76         -- During the cleaning of each block we collected information about what regs
  77         --      were valid across each jump. Based on this, work out whether it will be
  78         --      safe to erase reloads after join points for the next pass.
  79         collateJoinPoints
  80
  81         -- remember how many spills/reloads we cleaned in this pass
  82         spills          <- gets sCleanedSpillsAcc
  83         reloads         <- gets sCleanedReloadsAcc
  84         modify $ \s -> s
  85                 { sCleanedCount = (spills, reloads) : sCleanedCount s }
  86
  87         -- if nothing was cleaned in this pass or the last one
  88         --      then we're done and it's time to bail out
  89         cleanedCount    <- gets sCleanedCount
  90         if take 2 cleanedCount == [(0, 0), (0, 0)]
  91            then return code
  92
  93         -- otherwise go around again
  94            else cleanSpin (spinCount + 1) code'
  95
  96
  97 -- | Clean one basic block
  98 cleanBlock :: LiveBasicBlock -> CleanM LiveBasicBlock
  99 cleanBlock (BasicBlock id instrs)
 100  = do   jumpValid       <- gets sJumpValid
 101         let assoc       = case lookupUFM jumpValid id of
 102                                 Just assoc      -> assoc
 103                                 Nothing         -> emptyAssoc
 104
 105         instrs_reload   <- cleanFwd    assoc        [] instrs
 106         instrs_spill    <- cleanSpill  emptyUniqSet [] instrs_reload
 107         return  $ BasicBlock id instrs_spill
 108
 109
 110 -- | Clean out unneeded reload instructions.
 111 --      Walking forwards across the code
 112 --        On a reload, if we know a reg already has the same value as a slot
 113 --        then we don't need to do the reload.
 114 --
 115 cleanFwd
 116         :: Assoc Store          -- ^ two store locations are associated if they have the same value
 117         -> [LiveInstr]          -- ^ acc
 118         -> [LiveInstr]          -- ^ instrs to clean (in backwards order)
 119         -> CleanM [LiveInstr]   -- ^ cleaned instrs  (in forward   order)
 120
 121 cleanFwd _ acc []
 122         = return acc
 123
 124 -- write out live range joins via spill slots to just a spill and a reg-reg move
 125 --      hopefully the spill will be also be cleaned in the next pass
 126 --
 127 cleanFwd assoc acc (Instr i1 live1 : Instr i2 _ : instrs)
 128
 129         | SPILL  reg1  slot1    <- i1
 130         , RELOAD slot2 reg2     <- i2
 131         , slot1 == slot2
 132         = do
 133                 modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
 134                 cleanFwd assoc acc
 135                         (Instr i1 live1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
 136
 137
 138 cleanFwd assoc acc (li@(Instr i1 _) : instrs)
 139         | Just (r1, r2) <- isRegRegMove i1
 140         = if r1 == r2
 141                 -- erase any left over nop reg reg moves while we're here
 142                 --      this will also catch any nop moves that the "write out live range joins" case above
 143                 --      happens to add
 144                 then cleanFwd assoc acc instrs
 145
 146                 -- if r1 has the same value as some slots and we copy r1 to r2,
 147                 --      then r2 is now associated with those slots instead
 148                 else do let assoc'      = addAssoc (SReg r1) (SReg r2)
 149                                         $ delAssoc (SReg r2)
 150                                         $ assoc
 151
 152                         cleanFwd assoc' (li : acc) instrs
 153
 154
 155 cleanFwd assoc acc (li@(Instr instr _) : instrs)
 156
 157         | SPILL reg slot        <- instr
 158         = let   assoc'  = addAssoc (SReg reg)  (SSlot slot)     -- doing the spill makes reg and slot the same value
 159                         $ delAssoc (SSlot slot)                 -- slot value changes on spill
 160                         $ assoc
 161           in    cleanFwd assoc' (li : acc) instrs
 162
 163         -- clean a reload instr
 164         | RELOAD{}              <- instr
 165         = do    (assoc', mli)   <- cleanReload assoc li
 166                 case mli of
 167                         Nothing         -> cleanFwd assoc' acc          instrs
 168                         Just li'        -> cleanFwd assoc' (li' : acc)  instrs
 169
 170         -- remember the association over a jump
 171         | targets       <- jumpDests instr []
 172         , not $ null targets
 173         = do    mapM_ (accJumpValid assoc) targets
 174                 cleanFwd assoc (li : acc) instrs
 175
 176         -- writing to a reg changes its value.
 177         | RU _ written  <- regUsage instr
 178         = let assoc'    = foldr delAssoc assoc (map SReg $ nub written)
 179           in  cleanFwd assoc' (li : acc) instrs
 180
 181
 182 -- | Try and rewrite a reload instruction to something more pleasing
 183 --
 184 cleanReload :: Assoc Store -> LiveInstr -> CleanM (Assoc Store, Maybe LiveInstr)
 185 cleanReload assoc li@(Instr (RELOAD slot reg) _)
 186
 187         -- if the reg we're reloading already has the same value as the slot
 188         --      then we can erase the instruction outright
 189         | elemAssoc (SSlot slot) (SReg reg) assoc
 190         = do    modify  $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
 191                 return  (assoc, Nothing)
 192
 193         -- if we can find another reg with the same value as this slot then
 194         --      do a move instead of a reload.
 195         | Just reg2     <- findRegOfSlot assoc slot
 196         = do    modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
 197
 198                 let assoc'      = addAssoc (SReg reg) (SReg reg2)
 199                                 $ delAssoc (SReg reg)
 200                                 $ assoc
 201
 202                 return  (assoc', Just $ Instr (mkRegRegMoveInstr reg2 reg) Nothing)
 203
 204         -- gotta keep this instr
 205         --      update the association
 206         | otherwise
 207         = do    let assoc'      = addAssoc (SReg reg)  (SSlot slot)     -- doing the reload makes reg and slot the same value
 208                                 $ delAssoc (SReg reg)                   -- reg value changes on reload
 209                                 $ assoc
 210
 211                 return  (assoc', Just li)
 212
 213 cleanReload _ _
 214         = panic "RegSpillClean.cleanReload: unhandled instr"
 215
 216
 217 -- | Clean out unneeded spill instructions.
 218 --      Walking backwards across the code.
 219 --       If there were no reloads from a slot between a spill and the last one
 220 --       then the slot was never read and we don't need the spill.
 221
 222 cleanSpill
 223         :: UniqSet Int          -- ^ slots that have been spilled, but not reloaded from
 224         -> [LiveInstr]          -- ^ acc
 225         -> [LiveInstr]          -- ^ instrs to clean (in forwards order)
 226         -> CleanM [LiveInstr]   -- ^ cleaned instrs  (in backwards order)
 227
 228 cleanSpill _      acc []
 229         = return  acc
 230
 231 cleanSpill unused acc (li@(Instr instr _) : instrs)
 232         | SPILL _ slot  <- instr
 233         = if elementOfUniqSet slot unused
 234
 235            -- we can erase this spill because the slot won't be read until after the next one
 236            then do
 237                 modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
 238                 cleanSpill unused acc instrs
 239
 240            else do
 241                 -- slots start off unused
 242                 let unused'     = addOneToUniqSet unused slot
 243                 cleanSpill unused' (li : acc) instrs
 244
 245         -- if we reload from a slot then it's no longer unused
 246         | RELOAD slot _         <- instr
 247         , unused'               <- delOneFromUniqSet unused slot
 248         = cleanSpill unused' (li : acc) instrs
 249
 250         -- some other instruction
 251         | otherwise
 252         = cleanSpill unused (li : acc) instrs
 253
 254
 255 -- collateJoinPoints:
 256 --
 257 -- | combine the associations from all the inward control flow edges.
 258 --
 259 collateJoinPoints :: CleanM ()
 260 collateJoinPoints
 261  = modify $ \s -> s
 262         { sJumpValid    = mapUFM intersects (sJumpValidAcc s)
 263         , sJumpValidAcc = emptyUFM }
 264
 265 intersects :: [Assoc Store]     -> Assoc Store
 266 intersects []           = emptyAssoc
 267 intersects assocs       = foldl1' intersectAssoc assocs
 268
 269
 270 -- | See if we have a reg with the same value as this slot in the association table.
 271 findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
 272 findRegOfSlot assoc slot
 273         | close                 <- closeAssoc (SSlot slot) assoc
 274         , Just (SReg reg)       <- find isStoreReg $ uniqSetToList close
 275         = Just reg
 276
 277         | otherwise
 278         = Nothing
 279
 280
 281 ---------------
 282 type CleanM = State CleanS
 283 data CleanS
 284         = CleanS
 285         { -- regs which are valid at the start of each block.
 286           sJumpValid            :: UniqFM (Assoc Store)
 287
 288           -- collecting up what regs were valid across each jump.
 289           --    in the next pass we can collate these and write the results
 290           --    to sJumpValid.
 291         , sJumpValidAcc         :: UniqFM [Assoc Store]
 292
 293           -- spills/reloads cleaned each pass (latest at front)
 294         , sCleanedCount         :: [(Int, Int)]
 295
 296           -- spills/reloads that have been cleaned in this pass so far.
 297         , sCleanedSpillsAcc     :: Int
 298         , sCleanedReloadsAcc    :: Int }
 299
 300 initCleanS :: CleanS
 301 initCleanS
 302         = CleanS
 303         { sJumpValid            = emptyUFM
 304         , sJumpValidAcc         = emptyUFM
 305
 306         , sCleanedCount         = []
 307
 308         , sCleanedSpillsAcc     = 0
 309         , sCleanedReloadsAcc    = 0 }
 310
 311
 312 -- | Remember the associations before a jump
 313 accJumpValid :: Assoc Store -> BlockId -> CleanM ()
 314 accJumpValid assocs target
 315         = modify $ \s -> s {
 316                 sJumpValidAcc = addToUFM_C (++)
 317                                         (sJumpValidAcc s)
 318                                         target
 319                                         [assocs] }
 320
 321 --------------
 322 -- A store location can be a stack slot or a register
 323 --
 324 data Store
 325         = SSlot Int
 326         | SReg  Reg
 327
 328 -- | Check if this is a reg store
 329 isStoreReg :: Store -> Bool
 330 isStoreReg ss
 331  = case ss of
 332         SSlot _ -> False
 333         SReg  _ -> True
 334
 335 -- spill cleaning is only done once all virtuals have been allocated to realRegs
 336 --
 337 instance Uniquable Store where
 338     getUnique (SReg  r)
 339         | RealReg i     <- r
 340         = mkUnique 'R' i
 341
 342         | otherwise
 343         = error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected."
 344
 345     getUnique (SSlot i)                 = mkUnique 'S' i
 346
 347 instance Outputable Store where
 348         ppr (SSlot i)   = text "slot" <> int i
 349         ppr (SReg  r)   = ppr r
 350
 351
 352 --------------
 353 -- Association graphs.
 354 --      In the spill cleaner, two store locations are associated if they are known
 355 --      to hold the same value.
 356 --
 357 type Assoc a    = UniqFM (UniqSet a)
 358
 359 -- | an empty association
 360 emptyAssoc :: Assoc a
 361 emptyAssoc      = emptyUFM
 362
 363
 364 -- | add an association between these two things
 365 addAssoc :: Uniquable a
 366          => a -> a -> Assoc a -> Assoc a
 367
 368 addAssoc a b m
 369  = let  m1      = addToUFM_C unionUniqSets m  a (unitUniqSet b)
 370         m2      = addToUFM_C unionUniqSets m1 b (unitUniqSet a)
 371    in   m2
 372
 373
 374 -- | delete all associations to a node
 375 delAssoc :: (Outputable a, Uniquable a)
 376          => a -> Assoc a -> Assoc a
 377
 378 delAssoc a m
 379         | Just aSet     <- lookupUFM  m a
 380         , m1            <- delFromUFM m a
 381         = foldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
 382
 383         | otherwise     = m
 384
 385
 386 -- | delete a single association edge (a -> b)
 387 delAssoc1 :: Uniquable a
 388         => a -> a -> Assoc a -> Assoc a
 389
 390 delAssoc1 a b m
 391         | Just aSet     <- lookupUFM m a
 392         = addToUFM m a (delOneFromUniqSet aSet b)
 393
 394         | otherwise     = m
 395
 396
 397 -- | check if these two things are associated
 398 elemAssoc :: (Outputable a, Uniquable a)
 399           => a -> a -> Assoc a -> Bool
 400
 401 elemAssoc a b m
 402         = elementOfUniqSet b (closeAssoc a m)
 403
 404 -- | find the refl. trans. closure of the association from this point
 405 closeAssoc :: (Outputable a, Uniquable a)
 406         => a -> Assoc a -> UniqSet a
 407
 408 closeAssoc a assoc
 409  =      closeAssoc' assoc emptyUniqSet (unitUniqSet a)
 410  where
 411         closeAssoc' assoc visited toVisit
 412          = case uniqSetToList toVisit of
 413
 414                 -- nothing else to visit, we're done
 415                 []      -> visited
 416
 417                 (x:_)
 418
 419                  -- we've already seen this node
 420                  |  elementOfUniqSet x visited
 421                  -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)
 422
 423                  -- haven't seen this node before,
 424                  --     remember to visit all its neighbors
 425                  |  otherwise
 426                  -> let neighbors
 427                          = case lookupUFM assoc x of
 428                                 Nothing         -> emptyUniqSet
 429                                 Just set        -> set
 430
 431                    in closeAssoc' assoc
 432                         (addOneToUniqSet visited x)
 433                         (unionUniqSets   toVisit neighbors)
 434
 435 -- | intersect
 436 intersectAssoc
 437         :: Uniquable a
 438         => Assoc a -> Assoc a -> Assoc a
 439
 440 intersectAssoc a b
 441         = intersectUFM_C (intersectUniqSets) a b
 442