compiler/nativeGen/RegSpillClean.hs

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