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