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