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