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