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  patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
 469                 blockMap'       = mapBlockEnv patchRegSet blockMap
 470
 471                 info'           = LiveInfo static id blockMap'
 472            in   CmmProc info' label params $ ListGraph $ map patchComp comps
 473
 474         patchComp (BasicBlock id blocks)
 475                 = BasicBlock id $ map patchBlock blocks
 476
 477         patchBlock (BasicBlock id lis)
 478                 = BasicBlock id $ patchInstrs lis
 479
 480         patchInstrs []          = []
 481         patchInstrs (li : lis)
 482
 483                 | Instr i (Just live)   <- li'
 484                 , Just (r1, r2) <- takeRegRegMoveInstr i
 485                 , eatMe r1 r2 live
 486                 = patchInstrs lis
 487
 488                 | otherwise
 489                 = li' : patchInstrs lis
 490
 491                 where   li'     = patchRegsLiveInstr patchF li
 492
 493         eatMe   r1 r2 live
 494                 -- source and destination regs are the same
 495                 | r1 == r2      = True
 496
 497                 -- desination reg is never used
 498                 | elementOfUniqSet r2 (liveBorn live)
 499                 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
 500                 = True
 501
 502                 | otherwise     = False
 503
 504
 505 -- | Patch registers in this LiveInstr, including the liveness information.
 506 --
 507 patchRegsLiveInstr
 508         :: Instruction instr
 509         => (Reg -> Reg)
 510         -> LiveInstr instr -> LiveInstr instr
 511
 512 patchRegsLiveInstr patchF li
 513  = case li of
 514         Instr instr Nothing
 515          -> Instr (patchRegsOfInstr instr patchF) Nothing
 516
 517         Instr instr (Just live)
 518          -> Instr
 519                 (patchRegsOfInstr instr patchF)
 520                 (Just live
 521                         { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
 522                           liveBorn      = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
 523                         , liveDieRead   = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
 524                         , liveDieWrite  = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
 525
 526         SPILL reg slot
 527          -> SPILL (patchF reg) slot
 528
 529         RELOAD slot reg
 530          -> RELOAD slot (patchF reg)
 531
 532
 533 ---------------------------------------------------------------------------------
 534 -- Annotate code with register liveness information
 535 --
 536 regLiveness
 537         :: Instruction instr
 538         => NatCmmTop instr
 539         -> UniqSM (LiveCmmTop instr)
 540
 541 regLiveness (CmmData i d)
 542         = returnUs $ CmmData i d
 543
 544 regLiveness (CmmProc info lbl params (ListGraph []))
 545         = returnUs $ CmmProc
 546                         (LiveInfo info Nothing emptyBlockEnv)
 547                         lbl params (ListGraph [])
 548
 549 regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
 550  = let  first_id                = blockId first
 551         sccs                    = sccBlocks blocks
 552         (ann_sccs, block_live)  = computeLiveness sccs
 553
 554         liveBlocks
 555          = map (\scc -> case scc of
 556                         AcyclicSCC  b@(BasicBlock l _)          -> BasicBlock l [b]
 557                         CyclicSCC  bs@(BasicBlock l _ : _)      -> BasicBlock l bs
 558                         CyclicSCC  []
 559                          -> panic "RegLiveness.regLiveness: no blocks in scc list")
 560                  $ ann_sccs
 561
 562    in   returnUs $ CmmProc (LiveInfo info (Just first_id) block_live)
 563                            lbl params (ListGraph liveBlocks)
 564
 565
 566 sccBlocks
 567         :: Instruction instr
 568         => [NatBasicBlock instr]
 569         -> [SCC (NatBasicBlock instr)]
 570
 571 sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
 572   where
 573         getOutEdges :: Instruction instr => [instr] -> [BlockId]
 574         getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
 575
 576         graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
 577                 | block@(BasicBlock id instrs) <- blocks ]
 578
 579
 580 -- -----------------------------------------------------------------------------
 581 -- Computing liveness
 582
 583 computeLiveness
 584         :: Instruction instr
 585         => [SCC (NatBasicBlock instr)]
 586         -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
 587                                                 -- which are "dead after this instruction".
 588                BlockMap RegSet)                 -- blocks annontated with set of live registers
 589                                                 -- on entry to the block.
 590
 591   -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
 592   -- control to earlier ones only.  The SCCs returned are in the *opposite*
 593   -- order, which is exactly what we want for the next pass.
 594
 595 computeLiveness sccs
 596         = livenessSCCs emptyBlockMap [] sccs
 597
 598
 599 livenessSCCs
 600        :: Instruction instr
 601        => BlockMap RegSet
 602        -> [SCC (LiveBasicBlock instr)]          -- accum
 603        -> [SCC (NatBasicBlock instr)]
 604        -> ( [SCC (LiveBasicBlock instr)]
 605           , BlockMap RegSet)
 606
 607 livenessSCCs blockmap done [] = (done, blockmap)
 608
 609 livenessSCCs blockmap done (AcyclicSCC block : sccs)
 610  = let  (blockmap', block')     = livenessBlock blockmap block
 611    in   livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
 612
 613 livenessSCCs blockmap done
 614         (CyclicSCC blocks : sccs) =
 615         livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
 616  where      (blockmap', blocks')
 617                 = iterateUntilUnchanged linearLiveness equalBlockMaps
 618                                       blockmap blocks
 619
 620             iterateUntilUnchanged
 621                 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
 622                 -> a -> b
 623                 -> (a,c)
 624
 625             iterateUntilUnchanged f eq a b
 626                 = head $
 627                   concatMap tail $
 628                   groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
 629                   iterate (\(a, _) -> f a b) $
 630                   (a, panic "RegLiveness.livenessSCCs")
 631
 632
 633             linearLiveness
 634                 :: Instruction instr
 635                 => BlockMap RegSet -> [NatBasicBlock instr]
 636                 -> (BlockMap RegSet, [LiveBasicBlock instr])
 637
 638             linearLiveness = mapAccumL livenessBlock
 639
 640                 -- probably the least efficient way to compare two
 641                 -- BlockMaps for equality.
 642             equalBlockMaps a b
 643                 = a' == b'
 644               where a' = map f $ blockEnvToList a
 645                     b' = map f $ blockEnvToList b
 646                     f (key,elt) = (key, uniqSetToList elt)
 647
 648
 649
 650 -- | Annotate a basic block with register liveness information.
 651 --
 652 livenessBlock
 653         :: Instruction instr
 654         => BlockMap RegSet
 655         -> NatBasicBlock instr
 656         -> (BlockMap RegSet, LiveBasicBlock instr)
 657
 658 livenessBlock blockmap (BasicBlock block_id instrs)
 659  = let
 660         (regsLiveOnEntry, instrs1)
 661                 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
 662         blockmap'       = extendBlockEnv blockmap block_id regsLiveOnEntry
 663
 664         instrs2         = livenessForward regsLiveOnEntry instrs1
 665
 666         output          = BasicBlock block_id instrs2
 667
 668    in   ( blockmap', output)
 669
 670 -- | Calculate liveness going forwards,
 671 --      filling in when regs are born
 672
 673 livenessForward
 674         :: Instruction instr
 675         => RegSet                       -- regs live on this instr
 676         -> [LiveInstr instr] -> [LiveInstr instr]
 677
 678 livenessForward _           []  = []
 679 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
 680         | Nothing               <- mLive
 681         = li : livenessForward rsLiveEntry lis
 682
 683         | Just live     <- mLive
 684         , RU _ written  <- regUsageOfInstr instr
 685         = let
 686                 -- Regs that are written to but weren't live on entry to this instruction
 687                 --      are recorded as being born here.
 688                 rsBorn          = mkUniqSet
 689                                 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
 690
 691                 rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
 692                                         `minusUniqSet` (liveDieRead live)
 693                                         `minusUniqSet` (liveDieWrite live)
 694
 695         in Instr instr (Just live { liveBorn = rsBorn })
 696                 : livenessForward rsLiveNext lis
 697
 698 livenessForward _ _             = panic "RegLiveness.livenessForward: no match"
 699
 700
 701 -- | Calculate liveness going backwards,
 702 --      filling in when regs die, and what regs are live across each instruction
 703
 704 livenessBack
 705         :: Instruction instr
 706         => RegSet                       -- regs live on this instr
 707         -> BlockMap RegSet              -- regs live on entry to other BBs
 708         -> [LiveInstr instr]            -- instructions (accum)
 709         -> [instr]                      -- instructions
 710         -> (RegSet, [LiveInstr instr])
 711
 712 livenessBack liveregs _        done []  = (liveregs, done)
 713
 714 livenessBack liveregs blockmap acc (instr : instrs)
 715  = let  (liveregs', instr')     = liveness1 liveregs blockmap instr
 716    in   livenessBack liveregs' blockmap (instr' : acc) instrs
 717
 718
 719 -- don't bother tagging comments or deltas with liveness
 720 liveness1
 721         :: Instruction instr
 722         => RegSet
 723         -> BlockMap RegSet
 724         -> instr
 725         -> (RegSet, LiveInstr instr)
 726
 727 liveness1 liveregs _ instr
 728         | isMetaInstr instr
 729         = (liveregs, Instr instr Nothing)
 730
 731 liveness1 liveregs blockmap instr
 732
 733         | not_a_branch
 734         = (liveregs1, Instr instr
 735                         (Just $ Liveness
 736                         { liveBorn      = emptyUniqSet
 737                         , liveDieRead   = mkUniqSet r_dying
 738                         , liveDieWrite  = mkUniqSet w_dying }))
 739
 740         | otherwise
 741         = (liveregs_br, Instr instr
 742                         (Just $ Liveness
 743                         { liveBorn      = emptyUniqSet
 744                         , liveDieRead   = mkUniqSet r_dying_br
 745                         , liveDieWrite  = mkUniqSet w_dying }))
 746
 747         where
 748             RU read written = regUsageOfInstr instr
 749
 750             -- registers that were written here are dead going backwards.
 751             -- registers that were read here are live going backwards.
 752             liveregs1   = (liveregs `delListFromUniqSet` written)
 753                                     `addListToUniqSet` read
 754
 755             -- registers that are not live beyond this point, are recorded
 756             --  as dying here.
 757             r_dying     = [ reg | reg <- read, reg `notElem` written,
 758                               not (elementOfUniqSet reg liveregs) ]
 759
 760             w_dying     = [ reg | reg <- written,
 761                              not (elementOfUniqSet reg liveregs) ]
 762
 763             -- union in the live regs from all the jump destinations of this
 764             -- instruction.
 765             targets      = jumpDestsOfInstr instr -- where we go from here
 766             not_a_branch = null targets
 767
 768             targetLiveRegs target
 769                   = case lookupBlockEnv blockmap target of
 770                                 Just ra -> ra
 771                                 Nothing -> emptyRegMap
 772
 773             live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
 774
 775             liveregs_br = liveregs1 `unionUniqSets` live_from_branch
 776
 777             -- registers that are live only in the branch targets should
 778             -- be listed as dying here.
 779             live_branch_only = live_from_branch `minusUniqSet` liveregs
 780             r_dying_br  = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
 781                                         live_branch_only)
 782
 783
 784
 785