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