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                 [SCC (LiveBasicBlock instr)]
  74
  75
  76 -- | An instruction with liveness information.
  77 data LiveInstr instr
  78         = Instr instr (Maybe Liveness)
  79
  80         -- | spill this reg to a stack slot
  81         | SPILL Reg Int
  82
  83         -- | reload this reg from a stack slot
  84         | RELOAD Int Reg
  85
  86
  87 -- | Liveness information.
  88 --      The regs which die are ones which are no longer live in the *next* instruction
  89 --      in this sequence.
  90 --      (NB. if the instruction is a jump, these registers might still be live
  91 --      at the jump target(s) - you have to check the liveness at the destination
  92 --      block to find out).
  93
  94 data Liveness
  95         = Liveness
  96         { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).
  97         , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.
  98         , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.
  99
 100
 101 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
 102 data LiveInfo
 103         = LiveInfo
 104                 [CmmStatic]                     -- cmm static stuff
 105                 (Maybe BlockId)                 -- id of the first block
 106                 (Maybe (BlockMap RegSet))       -- argument locals live on entry to this block
 107
 108 -- | A basic block with liveness information.
 109 type LiveBasicBlock instr
 110         = GenBasicBlock (LiveInstr instr)
 111
 112
 113 instance Outputable instr
 114       => Outputable (LiveInstr instr) where
 115         ppr (SPILL reg slot)
 116            = hcat [
 117                 ptext (sLit "\tSPILL"),
 118                 char ' ',
 119                 ppr reg,
 120                 comma,
 121                 ptext (sLit "SLOT") <> parens (int slot)]
 122
 123         ppr (RELOAD slot reg)
 124            = hcat [
 125                 ptext (sLit "\tRELOAD"),
 126                 char ' ',
 127                 ptext (sLit "SLOT") <> parens (int slot),
 128                 comma,
 129                 ppr reg]
 130
 131         ppr (Instr instr Nothing)
 132          = ppr instr
 133
 134         ppr (Instr instr (Just live))
 135          =  ppr instr
 136                 $$ (nest 8
 137                         $ vcat
 138                         [ pprRegs (ptext (sLit "# born:    ")) (liveBorn live)
 139                         , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
 140                         , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
 141                     $+$ space)
 142
 143          where  pprRegs :: SDoc -> RegSet -> SDoc
 144                 pprRegs name regs
 145                  | isEmptyUniqSet regs  = empty
 146                  | otherwise            = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
 147
 148 instance Outputable LiveInfo where
 149         ppr (LiveInfo static firstId liveOnEntry)
 150                 =  (vcat $ map ppr static)
 151                 $$ text "# firstId     = " <> ppr firstId
 152                 $$ text "# liveOnEntry = " <> ppr liveOnEntry
 153
 154
 155
 156 -- | map a function across all the basic blocks in this code
 157 --
 158 mapBlockTop
 159         :: (LiveBasicBlock instr -> LiveBasicBlock instr)
 160         -> LiveCmmTop instr -> LiveCmmTop instr
 161
 162 mapBlockTop f cmm
 163         = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
 164
 165
 166 -- | map a function across all the basic blocks in this code (monadic version)
 167 --
 168 mapBlockTopM
 169         :: Monad m
 170         => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
 171         -> LiveCmmTop instr -> m (LiveCmmTop instr)
 172
 173 mapBlockTopM _ cmm@(CmmData{})
 174         = return cmm
 175
 176 mapBlockTopM f (CmmProc header label params sccs)
 177  = do   sccs'   <- mapM (mapSCCM f) sccs
 178         return  $ CmmProc header label params sccs'
 179
 180 mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
 181 mapSCCM f (AcyclicSCC x)
 182  = do   x'      <- f x
 183         return  $ AcyclicSCC x'
 184
 185 mapSCCM f (CyclicSCC xs)
 186  = do   xs'     <- mapM f xs
 187         return  $ CyclicSCC xs'
 188
 189 {-
 190 mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a')
 191 mapBlockCompM f (BasicBlock i blocks)
 192  = do   blocks' <- mapM f blocks
 193         return  $ BasicBlock i blocks'
 194 -}
 195
 196 -- map a function across all the basic blocks in this code
 197 mapGenBlockTop
 198         :: (GenBasicBlock             i -> GenBasicBlock            i)
 199         -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
 200
 201 mapGenBlockTop f cmm
 202         = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
 203
 204
 205 -- | map a function across all the basic blocks in this code (monadic version)
 206 mapGenBlockTopM
 207         :: Monad m
 208         => (GenBasicBlock            i  -> m (GenBasicBlock            i))
 209         -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
 210
 211 mapGenBlockTopM _ cmm@(CmmData{})
 212         = return cmm
 213
 214 mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
 215  = do   blocks' <- mapM f blocks
 216         return  $ CmmProc header label params (ListGraph blocks')
 217
 218
 219 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
 220 --      Slurping of conflicts and moves is wrapped up together so we don't have
 221 --      to make two passes over the same code when we want to build the graph.
 222 --
 223 slurpConflicts
 224         :: Instruction instr
 225         => LiveCmmTop instr
 226         -> (Bag (UniqSet Reg), Bag (Reg, Reg))
 227
 228 slurpConflicts live
 229         = slurpCmm (emptyBag, emptyBag) live
 230
 231  where  slurpCmm   rs  CmmData{}                = rs
 232         slurpCmm   rs (CmmProc info _ _ sccs)
 233                 = foldl' (slurpSCC info) rs sccs
 234
 235         slurpSCC  info rs (AcyclicSCC b)
 236                 = slurpBlock info rs b
 237
 238         slurpSCC  info rs (CyclicSCC bs)
 239                 = foldl'  (slurpBlock info) rs bs
 240
 241         slurpBlock info rs (BasicBlock blockId instrs)
 242                 | LiveInfo _ _ (Just blockLive) <- info
 243                 , Just rsLiveEntry              <- lookupBlockEnv blockLive blockId
 244                 , (conflicts, moves)            <- slurpLIs rsLiveEntry rs instrs
 245                 = (consBag rsLiveEntry conflicts, moves)
 246
 247                 | otherwise
 248                 = panic "Liveness.slurpConflicts: bad block"
 249
 250         slurpLIs rsLive (conflicts, moves) []
 251                 = (consBag rsLive conflicts, moves)
 252
 253         slurpLIs rsLive rs (Instr _ Nothing     : lis)
 254                 = slurpLIs rsLive rs lis
 255
 256         -- we're not expecting to be slurping conflicts from spilled code
 257         slurpLIs _ _ (SPILL _ _ : _)
 258                 = panic "Liveness.slurpConflicts: unexpected SPILL"
 259
 260         slurpLIs _ _ (RELOAD _ _ : _)
 261                 = panic "Liveness.slurpConflicts: unexpected RELOAD"
 262
 263         slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
 264          = let
 265                 -- regs that die because they are read for the last time at the start of an instruction
 266                 --      are not live across it.
 267                 rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
 268
 269                 -- regs live on entry to the next instruction.
 270                 --      be careful of orphans, make sure to delete dying regs _after_ unioning
 271                 --      in the ones that are born here.
 272                 rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
 273                                                 `minusUniqSet`  (liveDieWrite live)
 274
 275                 -- orphan vregs are the ones that die in the same instruction they are born in.
 276                 --      these are likely to be results that are never used, but we still
 277                 --      need to assign a hreg to them..
 278                 rsOrphans       = intersectUniqSets
 279                                         (liveBorn live)
 280                                         (unionUniqSets (liveDieWrite live) (liveDieRead live))
 281
 282                 --
 283                 rsConflicts     = unionUniqSets rsLiveNext rsOrphans
 284
 285           in    case takeRegRegMoveInstr instr of
 286                  Just rr        -> slurpLIs rsLiveNext
 287                                         ( consBag rsConflicts conflicts
 288                                         , consBag rr moves) lis
 289
 290                  Nothing        -> slurpLIs rsLiveNext
 291                                         ( consBag rsConflicts conflicts
 292                                         , moves) lis
 293
 294
 295 -- | For spill\/reloads
 296 --
 297 --      SPILL  v1, slot1
 298 --      ...
 299 --      RELOAD slot1, v2
 300 --
 301 --      If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
 302 --      the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
 303 --
 304 --
 305 slurpReloadCoalesce
 306         :: Instruction instr
 307         => LiveCmmTop instr
 308         -> Bag (Reg, Reg)
 309
 310 slurpReloadCoalesce live
 311         = slurpCmm emptyBag live
 312
 313  where  slurpCmm cs CmmData{}   = cs
 314         slurpCmm cs (CmmProc _ _ _ sccs)
 315                 = slurpComp cs (flattenSCCs sccs)
 316
 317         slurpComp  cs blocks
 318          = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
 319            in   unionManyBags (cs : moveBags)
 320
 321         slurpCompM blocks
 322          = do   -- run the analysis once to record the mapping across jumps.
 323                 mapM_   (slurpBlock False) blocks
 324
 325                 -- run it a second time while using the information from the last pass.
 326                 --      We /could/ run this many more times to deal with graphical control
 327                 --      flow and propagating info across multiple jumps, but it's probably
 328                 --      not worth the trouble.
 329                 mapM    (slurpBlock True) blocks
 330
 331         slurpBlock propagate (BasicBlock blockId instrs)
 332          = do   -- grab the slot map for entry to this block
 333                 slotMap         <- if propagate
 334                                         then getSlotMap blockId
 335                                         else return emptyUFM
 336
 337                 (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
 338                 return $ listToBag $ catMaybes mMoves
 339
 340         slurpLI :: Instruction instr
 341                 => UniqFM Reg                           -- current slotMap
 342                 -> LiveInstr instr
 343                 -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]
 344                                                         --      for tracking slotMaps across jumps
 345
 346                          ( UniqFM Reg                   -- new slotMap
 347                          , Maybe (Reg, Reg))            -- maybe a new coalesce edge
 348
 349         slurpLI slotMap li
 350
 351                 -- remember what reg was stored into the slot
 352                 | SPILL reg slot        <- li
 353                 , slotMap'              <- addToUFM slotMap slot reg
 354                 = return (slotMap', Nothing)
 355
 356                 -- add an edge betwen the this reg and the last one stored into the slot
 357                 | RELOAD slot reg       <- li
 358                 = case lookupUFM slotMap slot of
 359                         Just reg2
 360                          | reg /= reg2  -> return (slotMap, Just (reg, reg2))
 361                          | otherwise    -> return (slotMap, Nothing)
 362
 363                         Nothing         -> return (slotMap, Nothing)
 364
 365                 -- if we hit a jump, remember the current slotMap
 366                 | Instr instr _         <- li
 367                 , targets               <- jumpDestsOfInstr instr
 368                 , not $ null targets
 369                 = do    mapM_   (accSlotMap slotMap) targets
 370                         return  (slotMap, Nothing)
 371
 372                 | otherwise
 373                 = return (slotMap, Nothing)
 374
 375         -- record a slotmap for an in edge to this block
 376         accSlotMap slotMap blockId
 377                 = modify (\s -> addToUFM_C (++) s blockId [slotMap])
 378
 379         -- work out the slot map on entry to this block
 380         --      if we have slot maps for multiple in-edges then we need to merge them.
 381         getSlotMap blockId
 382          = do   map             <- get
 383                 let slotMaps    = fromMaybe [] (lookupUFM map blockId)
 384                 return          $ foldr mergeSlotMaps emptyUFM slotMaps
 385
 386         mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
 387         mergeSlotMaps map1 map2
 388                 = listToUFM
 389                 $ [ (k, r1)     | (k, r1)       <- ufmToList map1
 390                                 , case lookupUFM map2 k of
 391                                         Nothing -> False
 392                                         Just r2 -> r1 == r2 ]
 393
 394
 395 -- | Strip away liveness information, yielding NatCmmTop
 396
 397 stripLive
 398         :: Instruction instr
 399         => LiveCmmTop instr
 400         -> NatCmmTop instr
 401
 402 stripLive live
 403         = stripCmm live
 404
 405  where  stripCmm (CmmData sec ds)       = CmmData sec ds
 406         stripCmm (CmmProc (LiveInfo info _ _) label params sccs)
 407                 = CmmProc info label params
 408                           (ListGraph $ map stripLiveBlock $ flattenSCCs sccs)
 409
 410
 411 -- | Strip away liveness information from a basic block,
 412 --      and make real spill instructions out of SPILL, RELOAD pseudos along the way.
 413
 414 stripLiveBlock
 415         :: Instruction instr
 416         => LiveBasicBlock instr
 417         -> NatBasicBlock instr
 418
 419 stripLiveBlock (BasicBlock i lis)
 420  =      BasicBlock i instrs'
 421
 422  where  (instrs', _)
 423                 = runState (spillNat [] lis) 0
 424
 425         spillNat acc []
 426          =      return (reverse acc)
 427
 428         spillNat acc (SPILL reg slot : instrs)
 429          = do   delta   <- get
 430                 spillNat (mkSpillInstr reg delta slot : acc) instrs
 431
 432         spillNat acc (RELOAD slot reg : instrs)
 433          = do   delta   <- get
 434                 spillNat (mkLoadInstr reg delta slot : acc) instrs
 435
 436         spillNat acc (Instr instr _ : instrs)
 437          | Just i <- takeDeltaInstr instr
 438          = do   put i
 439                 spillNat acc instrs
 440
 441         spillNat acc (Instr instr _ : instrs)
 442          =      spillNat (instr : acc) instrs
 443
 444
 445 -- | Erase Delta instructions.
 446
 447 eraseDeltasLive
 448         :: Instruction instr
 449         => LiveCmmTop instr
 450         -> LiveCmmTop instr
 451
 452 eraseDeltasLive cmm
 453         = mapBlockTop eraseBlock cmm
 454  where
 455         eraseBlock (BasicBlock id lis)
 456                 = BasicBlock id
 457                 $ filter (\(Instr i _) -> not $ isJust $ takeDeltaInstr i)
 458                 $ lis
 459
 460
 461 -- | Patch the registers in this code according to this register mapping.
 462 --      also erase reg -> reg moves when the reg is the same.
 463 --      also erase reg -> reg moves when the destination dies in this instr.
 464
 465 patchEraseLive
 466         :: Instruction instr
 467         => (Reg -> Reg)
 468         -> LiveCmmTop instr -> LiveCmmTop instr
 469
 470 patchEraseLive patchF cmm
 471         = patchCmm cmm
 472  where
 473         patchCmm cmm@CmmData{}  = cmm
 474
 475         patchCmm (CmmProc info label params sccs)
 476          | LiveInfo static id (Just blockMap)   <- info
 477          = let
 478                 patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
 479                 blockMap'       = mapBlockEnv patchRegSet blockMap
 480
 481                 info'           = LiveInfo static id (Just blockMap')
 482            in   CmmProc info' label params $ map patchSCC sccs
 483
 484          | otherwise
 485          = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
 486
 487         patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)
 488         patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs)
 489
 490         patchBlock (BasicBlock id lis)
 491                 = BasicBlock id $ patchInstrs lis
 492
 493         patchInstrs []          = []
 494         patchInstrs (li : lis)
 495
 496                 | Instr i (Just live)   <- li'
 497                 , Just (r1, r2) <- takeRegRegMoveInstr i
 498                 , eatMe r1 r2 live
 499                 = patchInstrs lis
 500
 501                 | otherwise
 502                 = li' : patchInstrs lis
 503
 504                 where   li'     = patchRegsLiveInstr patchF li
 505
 506         eatMe   r1 r2 live
 507                 -- source and destination regs are the same
 508                 | r1 == r2      = True
 509
 510                 -- desination reg is never used
 511                 | elementOfUniqSet r2 (liveBorn live)
 512                 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
 513                 = True
 514
 515                 | otherwise     = False
 516
 517
 518 -- | Patch registers in this LiveInstr, including the liveness information.
 519 --
 520 patchRegsLiveInstr
 521         :: Instruction instr
 522         => (Reg -> Reg)
 523         -> LiveInstr instr -> LiveInstr instr
 524
 525 patchRegsLiveInstr patchF li
 526  = case li of
 527         Instr instr Nothing
 528          -> Instr (patchRegsOfInstr instr patchF) Nothing
 529
 530         Instr instr (Just live)
 531          -> Instr
 532                 (patchRegsOfInstr instr patchF)
 533                 (Just live
 534                         { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
 535                           liveBorn      = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
 536                         , liveDieRead   = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
 537                         , liveDieWrite  = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
 538
 539         SPILL reg slot
 540          -> SPILL (patchF reg) slot
 541
 542         RELOAD slot reg
 543          -> RELOAD slot (patchF reg)
 544
 545
 546 --------------------------------------------------------------------------------
 547 -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information
 548 {-
 549 natCmmTopToLive
 550         :: NatCmmTop instr
 551         -> LiveCmmTop instr
 552
 553 natCmmTopToLive cmm@(CmmData _ _)
 554         = cmm
 555
 556 natCmmTopToLive (CmmProc info lbl params (ListGraph []))
 557         = CmmProc (LiveInfo info Nothing emptyBlockEnv)
 558                 lbl params (ListGraph []))
 559
 560 natCmmTopToLive (CmmProc info lbl params (ListGraph blocks))
 561  = let  first_id                = blockId first
 562         sccs                    = sccBlocks blocks
 563
 564         liveBlocks
 565          = map (\scc -> case scc of
 566                         AcyclicSCC  b@(BasicBlock l _)          -> BasicBlock l [cmmBlockToLive b]
 567                         CyclicSCC  bs@(BasicBlock l _ : _)      -> BasicBlock l (map cmmBlockToLive bs)
 568                         CyclicSCC  []
 569                          -> panic "RegLiveNess.natCmmTopToLive: no blocks in scc list")
 570                 sccs
 571
 572    in   CmmProc (LiveInfo info (Just first_id) ???
 573 -}
 574
 575 ---------------------------------------------------------------------------------
 576 -- Annotate code with register liveness information
 577 --
 578 regLiveness
 579         :: Instruction instr
 580         => NatCmmTop instr
 581         -> UniqSM (LiveCmmTop instr)
 582
 583 regLiveness (CmmData i d)
 584         = returnUs $ CmmData i d
 585
 586 regLiveness (CmmProc info lbl params (ListGraph []))
 587         = returnUs $ CmmProc
 588                         (LiveInfo info Nothing (Just emptyBlockEnv))
 589                         lbl params []
 590
 591 regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
 592  = let  first_id                = blockId first
 593         sccs                    = sccBlocks blocks
 594         (ann_sccs, block_live)  = computeLiveness sccs
 595
 596    in   returnUs $ CmmProc (LiveInfo info (Just first_id) (Just block_live))
 597                            lbl params ann_sccs
 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