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