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         lifetimeCount,
  27         eraseDeltasLive,
  28         patchEraseLive,
  29         patchRegsLiveInstr,
  30         regLiveness
  31
  32   ) where
  33
  34 #include "HsVersions.h"
  35
  36 import MachRegs
  37 import MachInstrs
  38 import PprMach
  39 import RegAllocInfo
  40 import Cmm hiding (RegSet)
  41
  42 import Digraph
  43 import Outputable
  44 import Unique
  45 import UniqSet
  46 import UniqFM
  47 import UniqSupply
  48 import Bag
  49 import State
  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 --      TODO: This only works intra-block at the momement. It's be nice to join up the mappings
 258 --            across blocks also.
 259 --
 260 slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg)
 261 slurpReloadCoalesce live
 262         = slurpCmm emptyBag live
 263
 264  where  slurpCmm cs CmmData{}   = cs
 265         slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
 266                 = foldl' slurpComp cs blocks
 267
 268         slurpComp  cs (BasicBlock _ blocks)
 269                 = foldl' slurpBlock cs blocks
 270
 271         slurpBlock cs (BasicBlock _ instrs)
 272          = let  (_, mMoves)     = mapAccumL slurpLI emptyUFM instrs
 273            in   unionBags cs (listToBag $ catMaybes mMoves)
 274
 275         slurpLI :: UniqFM Reg -> LiveInstr -> (UniqFM Reg, Maybe (Reg, Reg))
 276         slurpLI slotMap (Instr instr _)
 277
 278                 -- remember what reg was stored into the slot
 279                 | SPILL reg slot        <- instr
 280                 , slotMap'              <- addToUFM slotMap slot reg
 281                 = (slotMap', Nothing)
 282
 283                 -- add an edge betwen the this reg and the last one stored into the slot
 284                 | RELOAD slot reg       <- instr
 285                 = case lookupUFM slotMap slot of
 286                         Just reg2       -> (slotMap, Just (reg, reg2))
 287                         Nothing         -> (slotMap, Nothing)
 288
 289                 | otherwise
 290                 = (slotMap, Nothing)
 291
 292
 293 -- | Strip away liveness information, yielding NatCmmTop
 294
 295 stripLive :: LiveCmmTop -> NatCmmTop
 296 stripLive live
 297         = stripCmm live
 298
 299  where  stripCmm (CmmData sec ds)       = CmmData sec ds
 300         stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
 301                 = CmmProc info label params (ListGraph $ concatMap stripComp comps)
 302
 303         stripComp  (BasicBlock _ blocks)        = map stripBlock blocks
 304         stripBlock (BasicBlock i instrs)        = BasicBlock i (map stripLI instrs)
 305         stripLI    (Instr instr _)              = instr
 306
 307
 308 -- | Make real spill instructions out of SPILL, RELOAD pseudos
 309
 310 spillNatBlock :: NatBasicBlock -> NatBasicBlock
 311 spillNatBlock (BasicBlock i is)
 312  =      BasicBlock i instrs'
 313  where  (instrs', _)
 314                 = runState (spillNat [] is) 0
 315
 316         spillNat acc []
 317          =      return (reverse acc)
 318
 319         spillNat acc (DELTA i : instrs)
 320          = do   put i
 321                 spillNat acc instrs
 322
 323         spillNat acc (SPILL reg slot : instrs)
 324          = do   delta   <- get
 325                 spillNat (mkSpillInstr reg delta slot : acc) instrs
 326
 327         spillNat acc (RELOAD slot reg : instrs)
 328          = do   delta   <- get
 329                 spillNat (mkLoadInstr reg delta slot : acc) instrs
 330
 331         spillNat acc (instr : instrs)
 332          =      spillNat (instr : acc) instrs
 333
 334
 335 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
 336
 337 lifetimeCount
 338         :: LiveCmmTop
 339         -> UniqFM (Reg, Int)    -- ^ reg -> (reg, count)
 340
 341 lifetimeCount cmm
 342         = countCmm emptyUFM cmm
 343  where
 344         countCmm fm  CmmData{}          = fm
 345         countCmm fm (CmmProc info _ _ (ListGraph blocks))
 346                 = foldl' (countComp info) fm blocks
 347
 348         countComp info fm (BasicBlock _ blocks)
 349                 = foldl' (countBlock info) fm blocks
 350
 351         countBlock info fm (BasicBlock blockId instrs)
 352                 | LiveInfo _ _ blockLive        <- info
 353                 , Just rsLiveEntry              <- lookupUFM blockLive blockId
 354                 = countLIs rsLiveEntry fm instrs
 355
 356                 | otherwise
 357                 = error "RegLiveness.countBlock: bad block"
 358
 359         countLIs _      fm []                           = fm
 360         countLIs rsLive fm (Instr _ Nothing : lis)      = countLIs rsLive fm lis
 361
 362         countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
 363          = let
 364                 rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
 365
 366                 rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
 367                                                  `minusUniqSet` (liveDieWrite live)
 368
 369                 add r fm        = addToUFM_C
 370                                         (\(r1, l1) (_, l2) -> (r1, l1 + l2))
 371                                         fm r (r, 1)
 372
 373                 fm'             = foldUniqSet add fm rsLiveEntry
 374            in   countLIs rsLiveNext fm' lis
 375
 376
 377 -- | Erase Delta instructions.
 378
 379 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
 380 eraseDeltasLive cmm
 381         = mapBlockTop eraseBlock cmm
 382  where
 383         isDelta (DELTA _)       = True
 384         isDelta _               = False
 385
 386         eraseBlock (BasicBlock id lis)
 387                 = BasicBlock id
 388                 $ filter (\(Instr i _) -> not $ isDelta i)
 389                 $ lis
 390
 391
 392 -- | Patch the registers in this code according to this register mapping.
 393 --      also erase reg -> reg moves when the reg is the same.
 394 --      also erase reg -> reg moves when the destination dies in this instr.
 395
 396 patchEraseLive
 397         :: (Reg -> Reg)
 398         -> LiveCmmTop -> LiveCmmTop
 399
 400 patchEraseLive patchF cmm
 401         = patchCmm cmm
 402  where
 403         patchCmm cmm@CmmData{}  = cmm
 404
 405         patchCmm (CmmProc info label params (ListGraph comps))
 406          | LiveInfo static id blockMap  <- info
 407          = let  patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
 408                 blockMap'       = mapUFM patchRegSet blockMap
 409
 410                 info'           = LiveInfo static id blockMap'
 411            in   CmmProc info' label params $ ListGraph $ map patchComp comps
 412
 413         patchComp (BasicBlock id blocks)
 414                 = BasicBlock id $ map patchBlock blocks
 415
 416         patchBlock (BasicBlock id lis)
 417                 = BasicBlock id $ patchInstrs lis
 418
 419         patchInstrs []          = []
 420         patchInstrs (li : lis)
 421
 422                 | Instr i (Just live)   <- li'
 423                 , Just (r1, r2) <- isRegRegMove i
 424                 , eatMe r1 r2 live
 425                 = patchInstrs lis
 426
 427                 | otherwise
 428                 = li' : patchInstrs lis
 429
 430                 where   li'     = patchRegsLiveInstr patchF li
 431
 432         eatMe   r1 r2 live
 433                 -- source and destination regs are the same
 434                 | r1 == r2      = True
 435
 436                 -- desination reg is never used
 437                 | elementOfUniqSet r2 (liveBorn live)
 438                 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
 439                 = True
 440
 441                 | otherwise     = False
 442
 443
 444 -- | Patch registers in this LiveInstr, including the liveness information.
 445 --
 446 patchRegsLiveInstr
 447         :: (Reg -> Reg)
 448         -> LiveInstr -> LiveInstr
 449
 450 patchRegsLiveInstr patchF li
 451  = case li of
 452         Instr instr Nothing
 453          -> Instr (patchRegs instr patchF) Nothing
 454
 455         Instr instr (Just live)
 456          -> Instr
 457                 (patchRegs instr patchF)
 458                 (Just live
 459                         { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
 460                           liveBorn      = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
 461                         , liveDieRead   = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
 462                         , liveDieWrite  = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
 463
 464
 465 ---------------------------------------------------------------------------------
 466 -- Annotate code with register liveness information
 467 --
 468 regLiveness
 469         :: NatCmmTop
 470         -> UniqSM LiveCmmTop
 471
 472 regLiveness (CmmData i d)
 473         = returnUs $ CmmData i d
 474
 475 regLiveness (CmmProc info lbl params (ListGraph []))
 476         = returnUs $ CmmProc
 477                         (LiveInfo info Nothing emptyUFM)
 478                         lbl params (ListGraph [])
 479
 480 regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
 481  = let  first_id                = blockId first
 482         sccs                    = sccBlocks blocks
 483         (ann_sccs, block_live)  = computeLiveness sccs
 484
 485         liveBlocks
 486          = map (\scc -> case scc of
 487                         AcyclicSCC  b@(BasicBlock l _)          -> BasicBlock l [b]
 488                         CyclicSCC  bs@(BasicBlock l _ : _)      -> BasicBlock l bs
 489                         CyclicSCC  []
 490                          -> panic "RegLiveness.regLiveness: no blocks in scc list")
 491                  $ ann_sccs
 492
 493    in   returnUs $ CmmProc
 494                         (LiveInfo info (Just first_id) block_live)
 495                         lbl params (ListGraph liveBlocks)
 496
 497
 498 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
 499 sccBlocks blocks = stronglyConnComp graph
 500   where
 501         getOutEdges :: [Instr] -> [BlockId]
 502         getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
 503
 504         graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
 505                 | block@(BasicBlock id instrs) <- blocks ]
 506
 507
 508 -- -----------------------------------------------------------------------------
 509 -- Computing liveness
 510
 511 computeLiveness
 512    :: [SCC NatBasicBlock]
 513    -> ([SCC LiveBasicBlock],            -- instructions annotated with list of registers
 514                                         -- which are "dead after this instruction".
 515        BlockMap RegSet)                 -- blocks annontated with set of live registers
 516                                         -- on entry to the block.
 517
 518   -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
 519   -- control to earlier ones only.  The SCCs returned are in the *opposite*
 520   -- order, which is exactly what we want for the next pass.
 521
 522 computeLiveness sccs
 523         = livenessSCCs emptyBlockMap [] sccs
 524
 525
 526 livenessSCCs
 527        :: BlockMap RegSet
 528        -> [SCC LiveBasicBlock]          -- accum
 529        -> [SCC NatBasicBlock]
 530        -> ([SCC LiveBasicBlock], BlockMap RegSet)
 531
 532 livenessSCCs blockmap done [] = (done, blockmap)
 533
 534 livenessSCCs blockmap done (AcyclicSCC block : sccs)
 535  = let  (blockmap', block')     = livenessBlock blockmap block
 536    in   livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
 537
 538 livenessSCCs blockmap done
 539         (CyclicSCC blocks : sccs) =
 540         livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
 541  where      (blockmap', blocks')
 542                 = iterateUntilUnchanged linearLiveness equalBlockMaps
 543                                       blockmap blocks
 544
 545             iterateUntilUnchanged
 546                 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
 547                 -> a -> b
 548                 -> (a,c)
 549
 550             iterateUntilUnchanged f eq a b
 551                 = head $
 552                   concatMap tail $
 553                   groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
 554                   iterate (\(a, _) -> f a b) $
 555                   (a, error "RegisterAlloc.livenessSCCs")
 556
 557
 558             linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
 559                            -> (BlockMap RegSet, [LiveBasicBlock])
 560             linearLiveness = mapAccumL livenessBlock
 561
 562                 -- probably the least efficient way to compare two
 563                 -- BlockMaps for equality.
 564             equalBlockMaps a b
 565                 = a' == b'
 566               where a' = map f $ ufmToList a
 567                     b' = map f $ ufmToList b
 568                     f (key,elt) = (key, uniqSetToList elt)
 569
 570
 571
 572 -- | Annotate a basic block with register liveness information.
 573 --
 574 livenessBlock
 575         :: BlockMap RegSet
 576         -> NatBasicBlock
 577         -> (BlockMap RegSet, LiveBasicBlock)
 578
 579 livenessBlock blockmap (BasicBlock block_id instrs)
 580  = let
 581         (regsLiveOnEntry, instrs1)
 582                 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
 583         blockmap'       = addToUFM blockmap block_id regsLiveOnEntry
 584
 585         instrs2         = livenessForward regsLiveOnEntry instrs1
 586
 587         output          = BasicBlock block_id instrs2
 588
 589    in   ( blockmap', output)
 590
 591 -- | Calculate liveness going forwards,
 592 --      filling in when regs are born
 593
 594 livenessForward
 595         :: RegSet                       -- regs live on this instr
 596         -> [LiveInstr] -> [LiveInstr]
 597
 598 livenessForward _           []  = []
 599 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
 600         | Nothing               <- mLive
 601         = li : livenessForward rsLiveEntry lis
 602
 603         | Just live     <- mLive
 604         , RU _ written  <- regUsage instr
 605         = let
 606                 -- Regs that are written to but weren't live on entry to this instruction
 607                 --      are recorded as being born here.
 608                 rsBorn          = mkUniqSet
 609                                 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
 610
 611                 rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
 612                                         `minusUniqSet` (liveDieRead live)
 613                                         `minusUniqSet` (liveDieWrite live)
 614
 615         in Instr instr (Just live { liveBorn = rsBorn })
 616                 : livenessForward rsLiveNext lis
 617
 618 livenessForward _ _             = panic "RegLiveness.livenessForward: no match"
 619
 620
 621 -- | Calculate liveness going backwards,
 622 --      filling in when regs die, and what regs are live across each instruction
 623
 624 livenessBack
 625         :: RegSet                       -- regs live on this instr
 626         -> BlockMap RegSet              -- regs live on entry to other BBs
 627         -> [LiveInstr]                  -- instructions (accum)
 628         -> [Instr]                      -- instructions
 629         -> (RegSet, [LiveInstr])
 630
 631 livenessBack liveregs _        done []  = (liveregs, done)
 632
 633 livenessBack liveregs blockmap acc (instr : instrs)
 634  = let  (liveregs', instr')     = liveness1 liveregs blockmap instr
 635    in   livenessBack liveregs' blockmap (instr' : acc) instrs
 636
 637 -- don't bother tagging comments or deltas with liveness
 638 liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr)
 639 liveness1 liveregs _   (instr@COMMENT{})
 640         = (liveregs, Instr instr Nothing)
 641
 642 liveness1 liveregs _   (instr@DELTA{})
 643         = (liveregs, Instr instr Nothing)
 644
 645 liveness1 liveregs blockmap instr
 646
 647       | not_a_branch
 648       = (liveregs1, Instr instr
 649                         (Just $ Liveness
 650                         { liveBorn      = emptyUniqSet
 651                         , liveDieRead   = mkUniqSet r_dying
 652                         , liveDieWrite  = mkUniqSet w_dying }))
 653
 654       | otherwise
 655       = (liveregs_br, Instr instr
 656                         (Just $ Liveness
 657                         { liveBorn      = emptyUniqSet
 658                         , liveDieRead   = mkUniqSet r_dying_br
 659                         , liveDieWrite  = mkUniqSet w_dying }))
 660
 661       where
 662             RU read written = regUsage instr
 663
 664             -- registers that were written here are dead going backwards.
 665             -- registers that were read here are live going backwards.
 666             liveregs1   = (liveregs `delListFromUniqSet` written)
 667                                     `addListToUniqSet` read
 668
 669             -- registers that are not live beyond this point, are recorded
 670             --  as dying here.
 671             r_dying     = [ reg | reg <- read, reg `notElem` written,
 672                               not (elementOfUniqSet reg liveregs) ]
 673
 674             w_dying     = [ reg | reg <- written,
 675                              not (elementOfUniqSet reg liveregs) ]
 676
 677             -- union in the live regs from all the jump destinations of this
 678             -- instruction.
 679             targets      = jumpDests instr [] -- where we go from here
 680             not_a_branch = null targets
 681
 682             targetLiveRegs target
 683                   = case lookupUFM blockmap target of
 684                                 Just ra -> ra
 685                                 Nothing -> emptyBlockMap
 686
 687             live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
 688
 689             liveregs_br = liveregs1 `unionUniqSets` live_from_branch
 690
 691             -- registers that are live only in the branch targets should
 692             -- be listed as dying here.
 693             live_branch_only = live_from_branch `minusUniqSet` liveregs
 694             r_dying_br  = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
 695                                         live_branch_only)
 696
 697
 698
 699