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