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