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