compiler/nativeGen/RegLiveness.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- The register liveness determinator
   4 --
   5 -- (c) The University of Glasgow 2004
   6 --
   7 -----------------------------------------------------------------------------
   8 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   9
  10 module RegLiveness (
  11         RegSet,
  12         RegMap, emptyRegMap,
  13         BlockMap, emptyBlockMap,
  14         LiveCmmTop,
  15         LiveInstr (..),
  16         Liveness (..),
  17         LiveInfo (..),
  18         LiveBasicBlock,
  19
  20         mapBlockTop,    mapBlockTopM,
  21         mapGenBlockTop, mapGenBlockTopM,
  22         stripLive,
  23         spillNatBlock,
  24         slurpConflicts,
  25         slurpReloadCoalesce,
  26         eraseDeltasLive,
  27         patchEraseLive,
  28         patchRegsLiveInstr,
  29         regLiveness
  30
  31   ) where
  32
  33 import MachRegs
  34 import MachInstrs
  35 import PprMach
  36 import RegAllocInfo
  37 import Cmm hiding (RegSet)
  38
  39 import Digraph
  40 import Outputable
  41 import Unique
  42 import UniqSet
  43 import UniqFM
  44 import UniqSupply
  45 import Bag
  46 import State
  47 import FastString
  48
  49 import Data.List
  50 import Data.Maybe
  51
  52 -----------------------------------------------------------------------------
  53 type RegSet = UniqSet Reg
  54
  55 type RegMap a = UniqFM a
  56
  57 emptyRegMap :: UniqFM a
  58 emptyRegMap = emptyUFM
  59
  60 type BlockMap a = UniqFM a
  61
  62 emptyBlockMap :: UniqFM a
  63 emptyBlockMap = emptyUFM
  64
  65
  66 -- | A top level thing which carries liveness information.
  67 type LiveCmmTop
  68         = GenCmmTop
  69                 CmmStatic
  70                 LiveInfo
  71                 (ListGraph (GenBasicBlock LiveInstr))
  72                         -- the "instructions" here are actually more blocks,
  73                         --      single blocks are acyclic
  74                         --      multiple blocks are taken to be cyclic.
  75
  76 -- | An instruction with liveness information.
  77 data LiveInstr
  78         = Instr Instr (Maybe Liveness)
  79
  80 -- | Liveness information.
  81 --      The regs which die are ones which are no longer live in the *next* instruction
  82 --      in this sequence.
  83 --      (NB. if the instruction is a jump, these registers might still be live
  84 --      at the jump target(s) - you have to check the liveness at the destination
  85 --      block to find out).
  86
  87 data Liveness
  88         = Liveness
  89         { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).
  90         , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.
  91         , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.
  92
  93
  94 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
  95 data LiveInfo
  96         = LiveInfo
  97                 [CmmStatic]             -- cmm static stuff
  98                 (Maybe BlockId)         -- id of the first block
  99                 (BlockMap RegSet)       -- argument locals live on entry to this block
 100
 101 -- | A basic block with liveness information.
 102 type LiveBasicBlock
 103         = GenBasicBlock LiveInstr
 104
 105
 106 instance Outputable LiveInstr where
 107         ppr (Instr instr Nothing)
 108          = ppr instr
 109
 110         ppr (Instr instr (Just live))
 111          =  ppr instr
 112                 $$ (nest 8
 113                         $ vcat
 114                         [ pprRegs (ptext (sLit "# born:    ")) (liveBorn live)
 115                         , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
 116                         , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
 117                     $+$ space)
 118
 119          where  pprRegs :: SDoc -> RegSet -> SDoc
 120                 pprRegs name regs
 121                  | isEmptyUniqSet regs  = empty
 122                  | otherwise            = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
 123
 124
 125 instance Outputable LiveInfo where
 126         ppr (LiveInfo static firstId liveOnEntry)
 127                 =  (vcat $ map ppr static)
 128                 $$ text "# firstId     = " <> ppr firstId
 129                 $$ text "# liveOnEntry = " <> ppr liveOnEntry
 130
 131
 132 -- | map a function across all the basic blocks in this code
 133 --
 134 mapBlockTop
 135         :: (LiveBasicBlock -> LiveBasicBlock)
 136         -> LiveCmmTop -> LiveCmmTop
 137
 138 mapBlockTop f cmm
 139         = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
 140
 141
 142 -- | map a function across all the basic blocks in this code (monadic version)
 143 --
 144 mapBlockTopM
 145         :: Monad m
 146         => (LiveBasicBlock -> m LiveBasicBlock)
 147         -> LiveCmmTop -> m LiveCmmTop
 148
 149 mapBlockTopM _ cmm@(CmmData{})
 150         = return cmm
 151
 152 mapBlockTopM f (CmmProc header label params (ListGraph comps))
 153  = do   comps'  <- mapM (mapBlockCompM f) comps
 154         return  $ CmmProc header label params (ListGraph comps')
 155
 156 mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a')
 157 mapBlockCompM f (BasicBlock i blocks)
 158  = do   blocks' <- mapM f blocks
 159         return  $ BasicBlock i blocks'
 160
 161
 162 -- map a function across all the basic blocks in this code
 163 mapGenBlockTop
 164         :: (GenBasicBlock             i -> GenBasicBlock            i)
 165         -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
 166
 167 mapGenBlockTop f cmm
 168         = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
 169
 170
 171 -- | map a function across all the basic blocks in this code (monadic version)
 172 mapGenBlockTopM
 173         :: Monad m
 174         => (GenBasicBlock            i  -> m (GenBasicBlock            i))
 175         -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
 176
 177 mapGenBlockTopM _ cmm@(CmmData{})
 178         = return cmm
 179
 180 mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
 181  = do   blocks' <- mapM f blocks
 182         return  $ CmmProc header label params (ListGraph blocks')
 183
 184
 185 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
 186 --      Slurping of conflicts and moves is wrapped up together so we don't have
 187 --      to make two passes over the same code when we want to build the graph.
 188 --
 189 slurpConflicts :: LiveCmmTop -> (Bag (UniqSet Reg), Bag (Reg, Reg))
 190 slurpConflicts live
 191         = slurpCmm (emptyBag, emptyBag) live
 192
 193  where  slurpCmm   rs  CmmData{}                = rs
 194         slurpCmm   rs (CmmProc info _ _ (ListGraph blocks))
 195                 = foldl' (slurpComp info) rs blocks
 196
 197         slurpComp  info rs (BasicBlock _ blocks)
 198                 = foldl' (slurpBlock info) rs blocks
 199
 200         slurpBlock info rs (BasicBlock blockId instrs)
 201                 | LiveInfo _ _ blockLive        <- info
 202                 , Just rsLiveEntry              <- lookupUFM blockLive blockId
 203                 , (conflicts, moves)            <- slurpLIs rsLiveEntry rs instrs
 204                 = (consBag rsLiveEntry conflicts, moves)
 205
 206                 | otherwise
 207                 = panic "RegLiveness.slurpBlock: bad block"
 208
 209         slurpLIs rsLive (conflicts, moves) []
 210                 = (consBag rsLive conflicts, moves)
 211
 212         slurpLIs rsLive rs (Instr _ Nothing     : lis)  = slurpLIs rsLive rs lis
 213
 214         slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
 215          = let
 216                 -- regs that die because they are read for the last time at the start of an instruction
 217                 --      are not live across it.
 218                 rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
 219
 220                 -- regs live on entry to the next instruction.
 221                 --      be careful of orphans, make sure to delete dying regs _after_ unioning
 222                 --      in the ones that are born here.
 223                 rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
 224                                                 `minusUniqSet`  (liveDieWrite live)
 225
 226                 -- orphan vregs are the ones that die in the same instruction they are born in.
 227                 --      these are likely to be results that are never used, but we still
 228                 --      need to assign a hreg to them..
 229                 rsOrphans       = intersectUniqSets
 230                                         (liveBorn live)
 231                                         (unionUniqSets (liveDieWrite live) (liveDieRead live))
 232
 233                 --
 234                 rsConflicts     = unionUniqSets rsLiveNext rsOrphans
 235
 236           in    case isRegRegMove instr of
 237                  Just rr        -> slurpLIs rsLiveNext
 238                                         ( consBag rsConflicts conflicts
 239                                         , consBag rr moves) lis
 240
 241                  Nothing        -> slurpLIs rsLiveNext
 242                                         ( consBag rsConflicts conflicts
 243                                         , moves) lis
 244
 245
 246 -- | For spill/reloads
 247 --
 248 --      SPILL  v1, slot1
 249 --      ...
 250 --      RELOAD slot1, v2
 251 --
 252 --      If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
 253 --      the spill/reload instrs can be cleaned and replaced by a nop reg-reg move.
 254 --
 255 --
 256 slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg)
 257 slurpReloadCoalesce live
 258         = slurpCmm emptyBag live
 259
 260  where  slurpCmm cs CmmData{}   = cs
 261         slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
 262                 = foldl' slurpComp cs blocks
 263
 264         slurpComp  cs comp
 265          = let  (moveBags, _)   = runState (slurpCompM comp) emptyUFM
 266            in   unionManyBags (cs : moveBags)
 267
 268         slurpCompM (BasicBlock _ blocks)
 269          = do   -- run the analysis once to record the mapping across jumps.
 270                 mapM_   (slurpBlock False) blocks
 271
 272                 -- run it a second time while using the information from the last pass.
 273                 --      We /could/ run this many more times to deal with graphical control
 274                 --      flow and propagating info across multiple jumps, but it's probably
 275                 --      not worth the trouble.
 276                 mapM    (slurpBlock True) blocks
 277
 278         slurpBlock propagate (BasicBlock blockId instrs)
 279          = do   -- grab the slot map for entry to this block
 280                 slotMap         <- if propagate
 281                                         then getSlotMap blockId
 282                                         else return emptyUFM
 283
 284                 (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
 285                 return $ listToBag $ catMaybes mMoves
 286
 287         slurpLI :: UniqFM Reg                           -- current slotMap
 288                 -> LiveInstr
 289                 -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]
 290                                                         --      for tracking slotMaps across jumps
 291
 292                          ( UniqFM Reg                   -- new slotMap
 293                          , Maybe (Reg, Reg))            -- maybe a new coalesce edge
 294
 295         slurpLI slotMap (Instr instr _)
 296
 297                 -- remember what reg was stored into the slot
 298                 | SPILL reg slot        <- instr
 299                 , slotMap'              <- addToUFM slotMap slot reg
 300                 = return (slotMap', Nothing)
 301
 302                 -- add an edge betwen the this reg and the last one stored into the slot
 303                 | RELOAD slot reg       <- instr
 304                 = case lookupUFM slotMap slot of
 305                         Just reg2
 306                          | reg /= reg2  -> return (slotMap, Just (reg, reg2))
 307                          | otherwise    -> return (slotMap, Nothing)
 308
 309                         Nothing         -> return (slotMap, Nothing)
 310
 311                 -- if we hit a jump, remember the current slotMap
 312                 | targets       <- jumpDests instr []
 313                 , not $ null targets
 314                 = do    mapM_   (accSlotMap slotMap) targets
 315                         return  (slotMap, Nothing)
 316
 317                 | otherwise
 318                 = return (slotMap, Nothing)
 319
 320         -- record a slotmap for an in edge to this block
 321         accSlotMap slotMap blockId
 322                 = modify (\s -> addToUFM_C (++) s blockId [slotMap])
 323
 324         -- work out the slot map on entry to this block
 325         --      if we have slot maps for multiple in-edges then we need to merge them.
 326         getSlotMap blockId
 327          = do   map             <- get
 328                 let slotMaps    = fromMaybe [] (lookupUFM map blockId)
 329                 return          $ foldr mergeSlotMaps emptyUFM slotMaps
 330
 331         mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
 332         mergeSlotMaps map1 map2
 333                 = listToUFM
 334                 $ [ (k, r1)     | (k, r1)       <- ufmToList map1
 335                                 , case lookupUFM map2 k of
 336                                         Nothing -> False
 337                                         Just r2 -> r1 == r2 ]
 338
 339
 340 -- | Strip away liveness information, yielding NatCmmTop
 341
 342 stripLive :: LiveCmmTop -> NatCmmTop
 343 stripLive live
 344         = stripCmm live
 345
 346  where  stripCmm (CmmData sec ds)       = CmmData sec ds
 347         stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
 348                 = CmmProc info label params (ListGraph $ concatMap stripComp comps)
 349
 350         stripComp  (BasicBlock _ blocks)        = map stripBlock blocks
 351         stripBlock (BasicBlock i instrs)        = BasicBlock i (map stripLI instrs)
 352         stripLI    (Instr instr _)              = instr
 353
 354
 355 -- | Make real spill instructions out of SPILL, RELOAD pseudos
 356
 357 spillNatBlock :: NatBasicBlock -> NatBasicBlock
 358 spillNatBlock (BasicBlock i is)
 359  =      BasicBlock i instrs'
 360  where  (instrs', _)
 361                 = runState (spillNat [] is) 0
 362
 363         spillNat acc []
 364          =      return (reverse acc)
 365
 366         spillNat acc (DELTA i : instrs)
 367          = do   put i
 368                 spillNat acc instrs
 369
 370         spillNat acc (SPILL reg slot : instrs)
 371          = do   delta   <- get
 372                 spillNat (mkSpillInstr reg delta slot : acc) instrs
 373
 374         spillNat acc (RELOAD slot reg : instrs)
 375          = do   delta   <- get
 376                 spillNat (mkLoadInstr reg delta slot : acc) instrs
 377
 378         spillNat acc (instr : instrs)
 379          =      spillNat (instr : acc) instrs
 380
 381
 382 -- | Erase Delta instructions.
 383
 384 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
 385 eraseDeltasLive cmm
 386         = mapBlockTop eraseBlock cmm
 387  where
 388         isDelta (DELTA _)       = True
 389         isDelta _               = False
 390
 391         eraseBlock (BasicBlock id lis)
 392                 = BasicBlock id
 393                 $ filter (\(Instr i _) -> not $ isDelta i)
 394                 $ lis
 395
 396
 397 -- | Patch the registers in this code according to this register mapping.
 398 --      also erase reg -> reg moves when the reg is the same.
 399 --      also erase reg -> reg moves when the destination dies in this instr.
 400
 401 patchEraseLive
 402         :: (Reg -> Reg)
 403         -> LiveCmmTop -> LiveCmmTop
 404
 405 patchEraseLive patchF cmm
 406         = patchCmm cmm
 407  where
 408         patchCmm cmm@CmmData{}  = cmm
 409
 410         patchCmm (CmmProc info label params (ListGraph comps))
 411          | LiveInfo static id blockMap  <- info
 412          = let  patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
 413                 blockMap'       = mapUFM patchRegSet blockMap
 414
 415                 info'           = LiveInfo static id blockMap'
 416            in   CmmProc info' label params $ ListGraph $ map patchComp comps
 417
 418         patchComp (BasicBlock id blocks)
 419                 = BasicBlock id $ map patchBlock blocks
 420
 421         patchBlock (BasicBlock id lis)
 422                 = BasicBlock id $ patchInstrs lis
 423
 424         patchInstrs []          = []
 425         patchInstrs (li : lis)
 426
 427                 | Instr i (Just live)   <- li'
 428                 , Just (r1, r2) <- isRegRegMove i
 429                 , eatMe r1 r2 live
 430                 = patchInstrs lis
 431
 432                 | otherwise
 433                 = li' : patchInstrs lis
 434
 435                 where   li'     = patchRegsLiveInstr patchF li
 436
 437         eatMe   r1 r2 live
 438                 -- source and destination regs are the same
 439                 | r1 == r2      = True
 440
 441                 -- desination reg is never used
 442                 | elementOfUniqSet r2 (liveBorn live)
 443                 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
 444                 = True
 445
 446                 | otherwise     = False
 447
 448
 449 -- | Patch registers in this LiveInstr, including the liveness information.
 450 --
 451 patchRegsLiveInstr
 452         :: (Reg -> Reg)
 453         -> LiveInstr -> LiveInstr
 454
 455 patchRegsLiveInstr patchF li
 456  = case li of
 457         Instr instr Nothing
 458          -> Instr (patchRegs instr patchF) Nothing
 459
 460         Instr instr (Just live)
 461          -> Instr
 462                 (patchRegs instr patchF)
 463                 (Just live
 464                         { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
 465                           liveBorn      = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
 466                         , liveDieRead   = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
 467                         , liveDieWrite  = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
 468
 469
 470 ---------------------------------------------------------------------------------
 471 -- Annotate code with register liveness information
 472 --
 473 regLiveness
 474         :: NatCmmTop
 475         -> UniqSM LiveCmmTop
 476
 477 regLiveness (CmmData i d)
 478         = returnUs $ CmmData i d
 479
 480 regLiveness (CmmProc info lbl params (ListGraph []))
 481         = returnUs $ CmmProc
 482                         (LiveInfo info Nothing emptyUFM)
 483                         lbl params (ListGraph [])
 484
 485 regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
 486  = let  first_id                = blockId first
 487         sccs                    = sccBlocks blocks
 488         (ann_sccs, block_live)  = computeLiveness sccs
 489
 490         liveBlocks
 491          = map (\scc -> case scc of
 492                         AcyclicSCC  b@(BasicBlock l _)          -> BasicBlock l [b]
 493                         CyclicSCC  bs@(BasicBlock l _ : _)      -> BasicBlock l bs
 494                         CyclicSCC  []
 495                          -> panic "RegLiveness.regLiveness: no blocks in scc list")
 496                  $ ann_sccs
 497
 498    in   returnUs $ CmmProc
 499                         (LiveInfo info (Just first_id) block_live)
 500                         lbl params (ListGraph liveBlocks)
 501
 502
 503 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
 504 sccBlocks blocks = stronglyConnComp graph
 505   where
 506         getOutEdges :: [Instr] -> [BlockId]
 507         getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
 508
 509         graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
 510                 | block@(BasicBlock id instrs) <- blocks ]
 511
 512
 513 -- -----------------------------------------------------------------------------
 514 -- Computing liveness
 515
 516 computeLiveness
 517    :: [SCC NatBasicBlock]
 518    -> ([SCC LiveBasicBlock],            -- instructions annotated with list of registers
 519                                         -- which are "dead after this instruction".
 520        BlockMap RegSet)                 -- blocks annontated with set of live registers
 521                                         -- on entry to the block.
 522
 523   -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
 524   -- control to earlier ones only.  The SCCs returned are in the *opposite*
 525   -- order, which is exactly what we want for the next pass.
 526
 527 computeLiveness sccs
 528         = livenessSCCs emptyBlockMap [] sccs
 529
 530
 531 livenessSCCs
 532        :: BlockMap RegSet
 533        -> [SCC LiveBasicBlock]          -- accum
 534        -> [SCC NatBasicBlock]
 535        -> ([SCC LiveBasicBlock], BlockMap RegSet)
 536
 537 livenessSCCs blockmap done [] = (done, blockmap)
 538
 539 livenessSCCs blockmap done (AcyclicSCC block : sccs)
 540  = let  (blockmap', block')     = livenessBlock blockmap block
 541    in   livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
 542
 543 livenessSCCs blockmap done
 544         (CyclicSCC blocks : sccs) =
 545         livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
 546  where      (blockmap', blocks')
 547                 = iterateUntilUnchanged linearLiveness equalBlockMaps
 548                                       blockmap blocks
 549
 550             iterateUntilUnchanged
 551                 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
 552                 -> a -> b
 553                 -> (a,c)
 554
 555             iterateUntilUnchanged f eq a b
 556                 = head $
 557                   concatMap tail $
 558                   groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
 559                   iterate (\(a, _) -> f a b) $
 560                   (a, panic "RegLiveness.livenessSCCs")
 561
 562
 563             linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
 564                            -> (BlockMap RegSet, [LiveBasicBlock])
 565             linearLiveness = mapAccumL livenessBlock
 566
 567                 -- probably the least efficient way to compare two
 568                 -- BlockMaps for equality.
 569             equalBlockMaps a b
 570                 = a' == b'
 571               where a' = map f $ ufmToList a
 572                     b' = map f $ ufmToList b
 573                     f (key,elt) = (key, uniqSetToList elt)
 574
 575
 576
 577 -- | Annotate a basic block with register liveness information.
 578 --
 579 livenessBlock
 580         :: BlockMap RegSet
 581         -> NatBasicBlock
 582         -> (BlockMap RegSet, LiveBasicBlock)
 583
 584 livenessBlock blockmap (BasicBlock block_id instrs)
 585  = let
 586         (regsLiveOnEntry, instrs1)
 587                 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
 588         blockmap'       = addToUFM blockmap block_id regsLiveOnEntry
 589
 590         instrs2         = livenessForward regsLiveOnEntry instrs1
 591
 592         output          = BasicBlock block_id instrs2
 593
 594    in   ( blockmap', output)
 595
 596 -- | Calculate liveness going forwards,
 597 --      filling in when regs are born
 598
 599 livenessForward
 600         :: RegSet                       -- regs live on this instr
 601         -> [LiveInstr] -> [LiveInstr]
 602
 603 livenessForward _           []  = []
 604 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
 605         | Nothing               <- mLive
 606         = li : livenessForward rsLiveEntry lis
 607
 608         | Just live     <- mLive
 609         , RU _ written  <- regUsage instr
 610         = let
 611                 -- Regs that are written to but weren't live on entry to this instruction
 612                 --      are recorded as being born here.
 613                 rsBorn          = mkUniqSet
 614                                 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
 615
 616                 rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
 617                                         `minusUniqSet` (liveDieRead live)
 618                                         `minusUniqSet` (liveDieWrite live)
 619
 620         in Instr instr (Just live { liveBorn = rsBorn })
 621                 : livenessForward rsLiveNext lis
 622
 623 livenessForward _ _             = panic "RegLiveness.livenessForward: no match"
 624
 625
 626 -- | Calculate liveness going backwards,
 627 --      filling in when regs die, and what regs are live across each instruction
 628
 629 livenessBack
 630         :: RegSet                       -- regs live on this instr
 631         -> BlockMap RegSet              -- regs live on entry to other BBs
 632         -> [LiveInstr]                  -- instructions (accum)
 633         -> [Instr]                      -- instructions
 634         -> (RegSet, [LiveInstr])
 635
 636 livenessBack liveregs _        done []  = (liveregs, done)
 637
 638 livenessBack liveregs blockmap acc (instr : instrs)
 639  = let  (liveregs', instr')     = liveness1 liveregs blockmap instr
 640    in   livenessBack liveregs' blockmap (instr' : acc) instrs
 641
 642 -- don't bother tagging comments or deltas with liveness
 643 liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr)
 644 liveness1 liveregs _   (instr@COMMENT{})
 645         = (liveregs, Instr instr Nothing)
 646
 647 liveness1 liveregs _   (instr@DELTA{})
 648         = (liveregs, Instr instr Nothing)
 649
 650 liveness1 liveregs blockmap instr
 651
 652       | not_a_branch
 653       = (liveregs1, Instr instr
 654                         (Just $ Liveness
 655                         { liveBorn      = emptyUniqSet
 656                         , liveDieRead   = mkUniqSet r_dying
 657                         , liveDieWrite  = mkUniqSet w_dying }))
 658
 659       | otherwise
 660       = (liveregs_br, Instr instr
 661                         (Just $ Liveness
 662                         { liveBorn      = emptyUniqSet
 663                         , liveDieRead   = mkUniqSet r_dying_br
 664                         , liveDieWrite  = mkUniqSet w_dying }))
 665
 666       where
 667             RU read written = regUsage instr
 668
 669             -- registers that were written here are dead going backwards.
 670             -- registers that were read here are live going backwards.
 671             liveregs1   = (liveregs `delListFromUniqSet` written)
 672                                     `addListToUniqSet` read
 673
 674             -- registers that are not live beyond this point, are recorded
 675             --  as dying here.
 676             r_dying     = [ reg | reg <- read, reg `notElem` written,
 677                               not (elementOfUniqSet reg liveregs) ]
 678
 679             w_dying     = [ reg | reg <- written,
 680                              not (elementOfUniqSet reg liveregs) ]
 681
 682             -- union in the live regs from all the jump destinations of this
 683             -- instruction.
 684             targets      = jumpDests instr [] -- where we go from here
 685             not_a_branch = null targets
 686
 687             targetLiveRegs target
 688                   = case lookupUFM blockmap target of
 689                                 Just ra -> ra
 690                                 Nothing -> emptyBlockMap
 691
 692             live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
 693
 694             liveregs_br = liveregs1 `unionUniqSets` live_from_branch
 695
 696             -- registers that are live only in the branch targets should
 697             -- be listed as dying here.
 698             live_branch_only = live_from_branch `minusUniqSet` liveregs
 699             r_dying_br  = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
 700                                         live_branch_only)
 701
 702
 703
 704