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,   mapSCCM,
  22         mapGenBlockTop, mapGenBlockTopM,
  23         stripLive,
  24         stripLiveBlock,
  25         slurpConflicts,
  26         slurpReloadCoalesce,
  27         eraseDeltasLive,
  28         patchEraseLive,
  29         patchRegsLiveInstr,
  30         reverseBlocksInTops,
  31         regLiveness,
  32         natCmmTopToLive
  33   ) where
  34 import Reg
  35 import Instruction
  36
  37 import BlockId
  38 import OldCmm hiding (RegSet)
  39 import OldPprCmm()
  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 import Data.Map                 (Map)
  54 import Data.Set                 (Set)
  55 import qualified Data.Map       as Map
  56
  57 -----------------------------------------------------------------------------
  58 type RegSet = UniqSet Reg
  59
  60 type RegMap a = UniqFM a
  61
  62 emptyRegMap :: UniqFM a
  63 emptyRegMap = emptyUFM
  64
  65 type BlockMap a = BlockEnv a
  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 -- | The register allocator also wants to use SPILL/RELOAD meta instructions,
  77 --      so we'll keep those here.
  78 data InstrSR instr
  79         -- | A real machine instruction
  80         = Instr  instr
  81
  82         -- | spill this reg to a stack slot
  83         | SPILL  Reg Int
  84
  85         -- | reload this reg from a stack slot
  86         | RELOAD Int Reg
  87
  88 instance Instruction instr => Instruction (InstrSR instr) where
  89         regUsageOfInstr i
  90          = case i of
  91                 Instr  instr    -> regUsageOfInstr instr
  92                 SPILL  reg _    -> RU [reg] []
  93                 RELOAD _ reg    -> RU [] [reg]
  94
  95         patchRegsOfInstr i f
  96          = case i of
  97                 Instr instr     -> Instr (patchRegsOfInstr instr f)
  98                 SPILL  reg slot -> SPILL (f reg) slot
  99                 RELOAD slot reg -> RELOAD slot (f reg)
 100
 101         isJumpishInstr i
 102          = case i of
 103                 Instr instr     -> isJumpishInstr instr
 104                 _               -> False
 105
 106         jumpDestsOfInstr i
 107          = case i of
 108                 Instr instr     -> jumpDestsOfInstr instr
 109                 _               -> []
 110
 111         patchJumpInstr i f
 112          = case i of
 113                 Instr instr     -> Instr (patchJumpInstr instr f)
 114                 _               -> i
 115
 116         mkSpillInstr            = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
 117         mkLoadInstr             = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
 118
 119         takeDeltaInstr i
 120          = case i of
 121                 Instr instr     -> takeDeltaInstr instr
 122                 _               -> Nothing
 123
 124         isMetaInstr i
 125          = case i of
 126                 Instr instr     -> isMetaInstr instr
 127                 _               -> False
 128
 129         mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2)
 130
 131         takeRegRegMoveInstr i
 132          = case i of
 133                 Instr instr     -> takeRegRegMoveInstr instr
 134                 _               -> Nothing
 135
 136         mkJumpInstr target      = map Instr (mkJumpInstr target)
 137
 138
 139
 140 -- | An instruction with liveness information.
 141 data LiveInstr instr
 142         = LiveInstr (InstrSR instr) (Maybe Liveness)
 143
 144 -- | Liveness information.
 145 --      The regs which die are ones which are no longer live in the *next* instruction
 146 --      in this sequence.
 147 --      (NB. if the instruction is a jump, these registers might still be live
 148 --      at the jump target(s) - you have to check the liveness at the destination
 149 --      block to find out).
 150
 151 data Liveness
 152         = Liveness
 153         { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).
 154         , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.
 155         , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.
 156
 157
 158 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
 159 data LiveInfo
 160         = LiveInfo
 161                 [CmmStatic]                             -- cmm static stuff
 162                 (Maybe BlockId)                         -- id of the first block
 163                 (Maybe (BlockMap RegSet))               -- argument locals live on entry to this block
 164                 (Map BlockId (Set Int))                 -- stack slots live on entry to this block
 165
 166
 167 -- | A basic block with liveness information.
 168 type LiveBasicBlock instr
 169         = GenBasicBlock (LiveInstr instr)
 170
 171
 172 instance Outputable instr
 173       => Outputable (InstrSR instr) where
 174
 175         ppr (Instr realInstr)
 176            = ppr realInstr
 177
 178         ppr (SPILL reg slot)
 179            = hcat [
 180                 ptext (sLit "\tSPILL"),
 181                 char ' ',
 182                 ppr reg,
 183                 comma,
 184                 ptext (sLit "SLOT") <> parens (int slot)]
 185
 186         ppr (RELOAD slot reg)
 187            = hcat [
 188                 ptext (sLit "\tRELOAD"),
 189                 char ' ',
 190                 ptext (sLit "SLOT") <> parens (int slot),
 191                 comma,
 192                 ppr reg]
 193
 194 instance Outputable instr
 195       => Outputable (LiveInstr instr) where
 196
 197         ppr (LiveInstr instr Nothing)
 198          = ppr instr
 199
 200         ppr (LiveInstr instr (Just live))
 201          =  ppr instr
 202                 $$ (nest 8
 203                         $ vcat
 204                         [ pprRegs (ptext (sLit "# born:    ")) (liveBorn live)
 205                         , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
 206                         , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
 207                     $+$ space)
 208
 209          where  pprRegs :: SDoc -> RegSet -> SDoc
 210                 pprRegs name regs
 211                  | isEmptyUniqSet regs  = empty
 212                  | otherwise            = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
 213
 214 instance Outputable LiveInfo where
 215         ppr (LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry)
 216                 =  (vcat $ map ppr static)
 217                 $$ text "# firstId          = " <> ppr firstId
 218                 $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
 219                 $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
 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 sccs)
 244  = do   sccs'   <- mapM (mapSCCM f) sccs
 245         return  $ CmmProc header label 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 (ListGraph blocks))
 276  = do   blocks' <- mapM f blocks
 277         return  $ CmmProc header label (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                <- mapLookup blockId blockLive
 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         :: forall instr. Instruction instr
 361         => LiveCmmTop instr
 362         -> Bag (Reg, Reg)
 363
 364 slurpReloadCoalesce live
 365         = slurpCmm emptyBag live
 366
 367  where
 368         slurpCmm :: Bag (Reg, Reg)
 369                  -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
 370                  -> Bag (Reg, Reg)
 371         slurpCmm cs CmmData{}   = cs
 372         slurpCmm cs (CmmProc _ _ sccs)
 373                 = slurpComp cs (flattenSCCs sccs)
 374
 375         slurpComp :: Bag (Reg, Reg)
 376                      -> [LiveBasicBlock instr]
 377                      -> Bag (Reg, Reg)
 378         slurpComp  cs blocks
 379          = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
 380            in   unionManyBags (cs : moveBags)
 381
 382         slurpCompM :: [LiveBasicBlock instr]
 383                    -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
 384         slurpCompM blocks
 385          = do   -- run the analysis once to record the mapping across jumps.
 386                 mapM_   (slurpBlock False) blocks
 387
 388                 -- run it a second time while using the information from the last pass.
 389                 --      We /could/ run this many more times to deal with graphical control
 390                 --      flow and propagating info across multiple jumps, but it's probably
 391                 --      not worth the trouble.
 392                 mapM    (slurpBlock True) blocks
 393
 394         slurpBlock :: Bool -> LiveBasicBlock instr
 395                    -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
 396         slurpBlock propagate (BasicBlock blockId instrs)
 397          = do   -- grab the slot map for entry to this block
 398                 slotMap         <- if propagate
 399                                         then getSlotMap blockId
 400                                         else return emptyUFM
 401
 402                 (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
 403                 return $ listToBag $ catMaybes mMoves
 404
 405         slurpLI :: UniqFM Reg                           -- current slotMap
 406                 -> LiveInstr instr
 407                 -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]
 408                                                         --      for tracking slotMaps across jumps
 409
 410                          ( UniqFM Reg                   -- new slotMap
 411                          , Maybe (Reg, Reg))            -- maybe a new coalesce edge
 412
 413         slurpLI slotMap li
 414
 415                 -- remember what reg was stored into the slot
 416                 | LiveInstr (SPILL reg slot) _  <- li
 417                 , slotMap'                      <- addToUFM slotMap slot reg
 418                 = return (slotMap', Nothing)
 419
 420                 -- add an edge betwen the this reg and the last one stored into the slot
 421                 | LiveInstr (RELOAD slot reg) _ <- li
 422                 = case lookupUFM slotMap slot of
 423                         Just reg2
 424                          | reg /= reg2  -> return (slotMap, Just (reg, reg2))
 425                          | otherwise    -> return (slotMap, Nothing)
 426
 427                         Nothing         -> return (slotMap, Nothing)
 428
 429                 -- if we hit a jump, remember the current slotMap
 430                 | LiveInstr (Instr instr) _     <- li
 431                 , targets                       <- jumpDestsOfInstr instr
 432                 , not $ null targets
 433                 = do    mapM_   (accSlotMap slotMap) targets
 434                         return  (slotMap, Nothing)
 435
 436                 | otherwise
 437                 = return (slotMap, Nothing)
 438
 439         -- record a slotmap for an in edge to this block
 440         accSlotMap slotMap blockId
 441                 = modify (\s -> addToUFM_C (++) s blockId [slotMap])
 442
 443         -- work out the slot map on entry to this block
 444         --      if we have slot maps for multiple in-edges then we need to merge them.
 445         getSlotMap blockId
 446          = do   map             <- get
 447                 let slotMaps    = fromMaybe [] (lookupUFM map blockId)
 448                 return          $ foldr mergeSlotMaps emptyUFM slotMaps
 449
 450         mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
 451         mergeSlotMaps map1 map2
 452                 = listToUFM
 453                 $ [ (k, r1)     | (k, r1)       <- ufmToList map1
 454                                 , case lookupUFM map2 k of
 455                                         Nothing -> False
 456                                         Just r2 -> r1 == r2 ]
 457
 458
 459 -- | Strip away liveness information, yielding NatCmmTop
 460 stripLive
 461         :: (Outputable instr, Instruction instr)
 462         => LiveCmmTop instr
 463         -> NatCmmTop instr
 464
 465 stripLive live
 466         = stripCmm live
 467
 468  where  stripCmm (CmmData sec ds)       = CmmData sec ds
 469         stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs)
 470          = let  final_blocks    = flattenSCCs sccs
 471
 472                 -- make sure the block that was first in the input list
 473                 --      stays at the front of the output. This is the entry point
 474                 --      of the proc, and it needs to come first.
 475                 ((first':_), rest')
 476                                 = partition ((== first_id) . blockId) final_blocks
 477
 478            in   CmmProc info label
 479                           (ListGraph $ map stripLiveBlock $ first' : rest')
 480
 481         -- procs used for stg_split_markers don't contain any blocks, and have no first_id.
 482         stripCmm (CmmProc (LiveInfo info Nothing _ _) label [])
 483          =      CmmProc info label (ListGraph [])
 484
 485         -- If the proc has blocks but we don't know what the first one was, then we're dead.
 486         stripCmm proc
 487                  = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
 488
 489
 490 -- | Strip away liveness information from a basic block,
 491 --      and make real spill instructions out of SPILL, RELOAD pseudos along the way.
 492
 493 stripLiveBlock
 494         :: Instruction instr
 495         => LiveBasicBlock instr
 496         -> NatBasicBlock instr
 497
 498 stripLiveBlock (BasicBlock i lis)
 499  =      BasicBlock i instrs'
 500
 501  where  (instrs', _)
 502                 = runState (spillNat [] lis) 0
 503
 504         spillNat acc []
 505          =      return (reverse acc)
 506
 507         spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
 508          = do   delta   <- get
 509                 spillNat (mkSpillInstr reg delta slot : acc) instrs
 510
 511         spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
 512          = do   delta   <- get
 513                 spillNat (mkLoadInstr reg delta slot : acc) instrs
 514
 515         spillNat acc (LiveInstr (Instr instr) _ : instrs)
 516          | Just i <- takeDeltaInstr instr
 517          = do   put i
 518                 spillNat acc instrs
 519
 520         spillNat acc (LiveInstr (Instr instr) _ : instrs)
 521          =      spillNat (instr : acc) instrs
 522
 523
 524 -- | Erase Delta instructions.
 525
 526 eraseDeltasLive
 527         :: Instruction instr
 528         => LiveCmmTop instr
 529         -> LiveCmmTop instr
 530
 531 eraseDeltasLive cmm
 532         = mapBlockTop eraseBlock cmm
 533  where
 534         eraseBlock (BasicBlock id lis)
 535                 = BasicBlock id
 536                 $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
 537                 $ lis
 538
 539
 540 -- | Patch the registers in this code according to this register mapping.
 541 --      also erase reg -> reg moves when the reg is the same.
 542 --      also erase reg -> reg moves when the destination dies in this instr.
 543 patchEraseLive
 544         :: Instruction instr
 545         => (Reg -> Reg)
 546         -> LiveCmmTop instr -> LiveCmmTop instr
 547
 548 patchEraseLive patchF cmm
 549         = patchCmm cmm
 550  where
 551         patchCmm cmm@CmmData{}  = cmm
 552
 553         patchCmm (CmmProc info label sccs)
 554          | LiveInfo static id (Just blockMap) mLiveSlots <- info
 555          = let
 556                 patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
 557                 blockMap'       = mapMap patchRegSet blockMap
 558
 559                 info'           = LiveInfo static id (Just blockMap') mLiveSlots
 560            in   CmmProc info' label $ map patchSCC sccs
 561
 562          | otherwise
 563          = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
 564
 565         patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)
 566         patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs)
 567
 568         patchBlock (BasicBlock id lis)
 569                 = BasicBlock id $ patchInstrs lis
 570
 571         patchInstrs []          = []
 572         patchInstrs (li : lis)
 573
 574                 | LiveInstr i (Just live)       <- li'
 575                 , Just (r1, r2) <- takeRegRegMoveInstr i
 576                 , eatMe r1 r2 live
 577                 = patchInstrs lis
 578
 579                 | otherwise
 580                 = li' : patchInstrs lis
 581
 582                 where   li'     = patchRegsLiveInstr patchF li
 583
 584         eatMe   r1 r2 live
 585                 -- source and destination regs are the same
 586                 | r1 == r2      = True
 587
 588                 -- desination reg is never used
 589                 | elementOfUniqSet r2 (liveBorn live)
 590                 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
 591                 = True
 592
 593                 | otherwise     = False
 594
 595
 596 -- | Patch registers in this LiveInstr, including the liveness information.
 597 --
 598 patchRegsLiveInstr
 599         :: Instruction instr
 600         => (Reg -> Reg)
 601         -> LiveInstr instr -> LiveInstr instr
 602
 603 patchRegsLiveInstr patchF li
 604  = case li of
 605         LiveInstr instr Nothing
 606          -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
 607
 608         LiveInstr instr (Just live)
 609          -> LiveInstr
 610                 (patchRegsOfInstr instr patchF)
 611                 (Just live
 612                         { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
 613                           liveBorn      = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
 614                         , liveDieRead   = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
 615                         , liveDieWrite  = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
 616
 617
 618 --------------------------------------------------------------------------------
 619 -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information
 620
 621 natCmmTopToLive
 622         :: Instruction instr
 623         => NatCmmTop instr
 624         -> LiveCmmTop instr
 625
 626 natCmmTopToLive (CmmData i d)
 627         = CmmData i d
 628
 629 natCmmTopToLive (CmmProc info lbl (ListGraph []))
 630         = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl []
 631
 632 natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _)))
 633  = let  first_id        = blockId first
 634         sccs            = sccBlocks blocks
 635         sccsLive        = map (fmap (\(BasicBlock l instrs) ->
 636                                         BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
 637                         $ sccs
 638
 639    in   CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive
 640
 641
 642 sccBlocks
 643         :: Instruction instr
 644         => [NatBasicBlock instr]
 645         -> [SCC (NatBasicBlock instr)]
 646
 647 sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
 648   where
 649         getOutEdges :: Instruction instr => [instr] -> [BlockId]
 650         getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
 651
 652         graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
 653                 | block@(BasicBlock id instrs) <- blocks ]
 654
 655
 656 ---------------------------------------------------------------------------------
 657 -- Annotate code with register liveness information
 658 --
 659 regLiveness
 660         :: (Outputable instr, Instruction instr)
 661         => LiveCmmTop instr
 662         -> UniqSM (LiveCmmTop instr)
 663
 664 regLiveness (CmmData i d)
 665         = returnUs $ CmmData i d
 666
 667 regLiveness (CmmProc info lbl [])
 668         | LiveInfo static mFirst _ _    <- info
 669         = returnUs $ CmmProc
 670                         (LiveInfo static mFirst (Just mapEmpty) Map.empty)
 671                         lbl []
 672
 673 regLiveness (CmmProc info lbl sccs)
 674         | LiveInfo static mFirst _ liveSlotsOnEntry     <- info
 675         = let   (ann_sccs, block_live)  = computeLiveness sccs
 676
 677           in    returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
 678                            lbl ann_sccs
 679
 680
 681 -- -----------------------------------------------------------------------------
 682 -- | Check ordering of Blocks
 683 --      The computeLiveness function requires SCCs to be in reverse dependent order.
 684 --      If they're not the liveness information will be wrong, and we'll get a bad allocation.
 685 --      Better to check for this precondition explicitly or some other poor sucker will
 686 --      waste a day staring at bad assembly code..
 687 --
 688 checkIsReverseDependent
 689         :: Instruction instr
 690         => [SCC (LiveBasicBlock instr)]         -- ^ SCCs of blocks that we're about to run the liveness determinator on.
 691         -> Maybe BlockId                        -- ^ BlockIds that fail the test (if any)
 692
 693 checkIsReverseDependent sccs'
 694  = go emptyUniqSet sccs'
 695
 696  where  go _ []
 697          = Nothing
 698
 699         go blocksSeen (AcyclicSCC block : sccs)
 700          = let  dests           = slurpJumpDestsOfBlock block
 701                 blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
 702                 badDests        = dests `minusUniqSet` blocksSeen'
 703            in   case uniqSetToList badDests of
 704                  []             -> go blocksSeen' sccs
 705                  bad : _        -> Just bad
 706
 707         go blocksSeen (CyclicSCC blocks : sccs)
 708          = let  dests           = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
 709                 blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
 710                 badDests        = dests `minusUniqSet` blocksSeen'
 711            in   case uniqSetToList badDests of
 712                  []             -> go blocksSeen' sccs
 713                  bad : _        -> Just bad
 714
 715         slurpJumpDestsOfBlock (BasicBlock _ instrs)
 716                 = unionManyUniqSets
 717                 $ map (mkUniqSet . jumpDestsOfInstr)
 718                         [ i | LiveInstr i _ <- instrs]
 719
 720
 721 -- | If we've compute liveness info for this code already we have to reverse
 722 --   the SCCs in each top to get them back to the right order so we can do it again.
 723 reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr
 724 reverseBlocksInTops top
 725  = case top of
 726         CmmData{}                       -> top
 727         CmmProc info lbl sccs   -> CmmProc info lbl (reverse sccs)
 728
 729
 730 -- | Computing liveness
 731 --
 732 --  On entry, the SCCs must be in "reverse" order: later blocks may transfer
 733 --  control to earlier ones only, else `panic`.
 734 --
 735 --  The SCCs returned are in the *opposite* order, which is exactly what we
 736 --  want for the next pass.
 737 --
 738 computeLiveness
 739         :: (Outputable instr, Instruction instr)
 740         => [SCC (LiveBasicBlock instr)]
 741         -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
 742                                                 -- which are "dead after this instruction".
 743                BlockMap RegSet)                 -- blocks annontated with set of live registers
 744                                                 -- on entry to the block.
 745
 746 computeLiveness sccs
 747  = case checkIsReverseDependent sccs of
 748         Nothing         -> livenessSCCs emptyBlockMap [] sccs
 749         Just bad        -> pprPanic "RegAlloc.Liveness.computeLivenss"
 750                                 (vcat   [ text "SCCs aren't in reverse dependent order"
 751                                         , text "bad blockId" <+> ppr bad
 752                                         , ppr sccs])
 753
 754 livenessSCCs
 755        :: Instruction instr
 756        => BlockMap RegSet
 757        -> [SCC (LiveBasicBlock instr)]          -- accum
 758        -> [SCC (LiveBasicBlock instr)]
 759        -> ( [SCC (LiveBasicBlock instr)]
 760           , BlockMap RegSet)
 761
 762 livenessSCCs blockmap done []
 763         = (done, blockmap)
 764
 765 livenessSCCs blockmap done (AcyclicSCC block : sccs)
 766  = let  (blockmap', block')     = livenessBlock blockmap block
 767    in   livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
 768
 769 livenessSCCs blockmap done
 770         (CyclicSCC blocks : sccs) =
 771         livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
 772  where      (blockmap', blocks')
 773                 = iterateUntilUnchanged linearLiveness equalBlockMaps
 774                                       blockmap blocks
 775
 776             iterateUntilUnchanged
 777                 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
 778                 -> a -> b
 779                 -> (a,c)
 780
 781             iterateUntilUnchanged f eq a b
 782                 = head $
 783                   concatMap tail $
 784                   groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
 785                   iterate (\(a, _) -> f a b) $
 786                   (a, panic "RegLiveness.livenessSCCs")
 787
 788
 789             linearLiveness
 790                 :: Instruction instr
 791                 => BlockMap RegSet -> [LiveBasicBlock instr]
 792                 -> (BlockMap RegSet, [LiveBasicBlock instr])
 793
 794             linearLiveness = mapAccumL livenessBlock
 795
 796                 -- probably the least efficient way to compare two
 797                 -- BlockMaps for equality.
 798             equalBlockMaps a b
 799                 = a' == b'
 800               where a' = map f $ mapToList a
 801                     b' = map f $ mapToList b
 802                     f (key,elt) = (key, uniqSetToList elt)
 803
 804
 805
 806 -- | Annotate a basic block with register liveness information.
 807 --
 808 livenessBlock
 809         :: Instruction instr
 810         => BlockMap RegSet
 811         -> LiveBasicBlock instr
 812         -> (BlockMap RegSet, LiveBasicBlock instr)
 813
 814 livenessBlock blockmap (BasicBlock block_id instrs)
 815  = let
 816         (regsLiveOnEntry, instrs1)
 817                 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
 818         blockmap'       = mapInsert block_id regsLiveOnEntry blockmap
 819
 820         instrs2         = livenessForward regsLiveOnEntry instrs1
 821
 822         output          = BasicBlock block_id instrs2
 823
 824    in   ( blockmap', output)
 825
 826 -- | Calculate liveness going forwards,
 827 --      filling in when regs are born
 828
 829 livenessForward
 830         :: Instruction instr
 831         => RegSet                       -- regs live on this instr
 832         -> [LiveInstr instr] -> [LiveInstr instr]
 833
 834 livenessForward _           []  = []
 835 livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis)
 836         | Nothing               <- mLive
 837         = li : livenessForward rsLiveEntry lis
 838
 839         | Just live     <- mLive
 840         , RU _ written  <- regUsageOfInstr instr
 841         = let
 842                 -- Regs that are written to but weren't live on entry to this instruction
 843                 --      are recorded as being born here.
 844                 rsBorn          = mkUniqSet
 845                                 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
 846
 847                 rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
 848                                         `minusUniqSet` (liveDieRead live)
 849                                         `minusUniqSet` (liveDieWrite live)
 850
 851         in LiveInstr instr (Just live { liveBorn = rsBorn })
 852                 : livenessForward rsLiveNext lis
 853
 854 livenessForward _ _             = panic "RegLiveness.livenessForward: no match"
 855
 856
 857 -- | Calculate liveness going backwards,
 858 --      filling in when regs die, and what regs are live across each instruction
 859
 860 livenessBack
 861         :: Instruction instr
 862         => RegSet                       -- regs live on this instr
 863         -> BlockMap RegSet              -- regs live on entry to other BBs
 864         -> [LiveInstr instr]            -- instructions (accum)
 865         -> [LiveInstr instr]            -- instructions
 866         -> (RegSet, [LiveInstr instr])
 867
 868 livenessBack liveregs _        done []  = (liveregs, done)
 869
 870 livenessBack liveregs blockmap acc (instr : instrs)
 871  = let  (liveregs', instr')     = liveness1 liveregs blockmap instr
 872    in   livenessBack liveregs' blockmap (instr' : acc) instrs
 873
 874
 875 -- don't bother tagging comments or deltas with liveness
 876 liveness1
 877         :: Instruction instr
 878         => RegSet
 879         -> BlockMap RegSet
 880         -> LiveInstr instr
 881         -> (RegSet, LiveInstr instr)
 882
 883 liveness1 liveregs _ (LiveInstr instr _)
 884         | isMetaInstr instr
 885         = (liveregs, LiveInstr instr Nothing)
 886
 887 liveness1 liveregs blockmap (LiveInstr instr _)
 888
 889         | not_a_branch
 890         = (liveregs1, LiveInstr instr
 891                         (Just $ Liveness
 892                         { liveBorn      = emptyUniqSet
 893                         , liveDieRead   = mkUniqSet r_dying
 894                         , liveDieWrite  = mkUniqSet w_dying }))
 895
 896         | otherwise
 897         = (liveregs_br, LiveInstr instr
 898                         (Just $ Liveness
 899                         { liveBorn      = emptyUniqSet
 900                         , liveDieRead   = mkUniqSet r_dying_br
 901                         , liveDieWrite  = mkUniqSet w_dying }))
 902
 903         where
 904             RU read written = regUsageOfInstr instr
 905
 906             -- registers that were written here are dead going backwards.
 907             -- registers that were read here are live going backwards.
 908             liveregs1   = (liveregs `delListFromUniqSet` written)
 909                                     `addListToUniqSet` read
 910
 911             -- registers that are not live beyond this point, are recorded
 912             --  as dying here.
 913             r_dying     = [ reg | reg <- read, reg `notElem` written,
 914                               not (elementOfUniqSet reg liveregs) ]
 915
 916             w_dying     = [ reg | reg <- written,
 917                              not (elementOfUniqSet reg liveregs) ]
 918
 919             -- union in the live regs from all the jump destinations of this
 920             -- instruction.
 921             targets      = jumpDestsOfInstr instr -- where we go from here
 922             not_a_branch = null targets
 923
 924             targetLiveRegs target
 925                   = case mapLookup target blockmap of
 926                                 Just ra -> ra
 927                                 Nothing -> emptyRegMap
 928
 929             live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
 930
 931             liveregs_br = liveregs1 `unionUniqSets` live_from_branch
 932
 933             -- registers that are live only in the branch targets should
 934             -- be listed as dying here.
 935             live_branch_only = live_from_branch `minusUniqSet` liveregs
 936             r_dying_br  = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
 937                                         live_branch_only)
 938
 939