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