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