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