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