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