compiler/nativeGen/RegLiveness.hs

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