compiler/nativeGen/RegLiveness.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- The register liveness determinator
   4 --
   5 -- (c) The University of Glasgow 2004
   6 --
   7 -----------------------------------------------------------------------------
   8
   9
  10 module RegLiveness (
  11         RegSet,
  12         RegMap, emptyRegMap,
  13         BlockMap, emptyBlockMap,
  14         LiveCmmTop,
  15         LiveInstr (..),
  16         Liveness (..),
  17         LiveInfo (..),
  18         LiveBasicBlock,
  19
  20         mapBlockTop,    mapBlockTopM,
  21         mapGenBlockTop, mapGenBlockTopM,
  22         stripLive,
  23         spillNatBlock,
  24         slurpConflicts,
  25         lifetimeCount,
  26         eraseDeltasLive,
  27         patchEraseLive,
  28         patchRegsLiveInstr,
  29         regLiveness
  30
  31   ) where
  32
  33 #include "HsVersions.h"
  34
  35 import MachRegs
  36 import MachInstrs
  37 import PprMach
  38 import RegAllocInfo
  39 import Cmm
  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
  50 import Data.List
  51 import Data.Maybe
  52
  53 -----------------------------------------------------------------------------
  54 type RegSet = UniqSet Reg
  55
  56 type RegMap a = UniqFM a
  57 emptyRegMap = emptyUFM
  58
  59 type BlockMap a = UniqFM a
  60 emptyBlockMap = emptyUFM
  61
  62
  63 -- | A top level thing which carries liveness information.
  64 type LiveCmmTop
  65         = GenCmmTop
  66                 CmmStatic
  67                 LiveInfo
  68                 (GenBasicBlock LiveInstr)
  69                         -- the "instructions" here are actually more blocks,
  70                         --      single blocks are acyclic
  71                         --      multiple blocks are taken to be cyclic.
  72
  73 -- | An instruction with liveness information.
  74 data LiveInstr
  75         = Instr Instr (Maybe Liveness)
  76
  77 -- | Liveness information.
  78 --      The regs which die are ones which are no longer live in the *next* instruction
  79 --      in this sequence.
  80 --      (NB. if the instruction is a jump, these registers might still be live
  81 --      at the jump target(s) - you have to check the liveness at the destination
  82 --      block to find out).
  83
  84 data Liveness
  85         = Liveness
  86         { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).
  87         , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.
  88         , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.
  89
  90
  91 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
  92 data LiveInfo
  93         = LiveInfo
  94                 [CmmStatic]             -- cmm static stuff
  95                 (Maybe BlockId)         -- id of the first block
  96                 (BlockMap RegSet)       -- argument locals live on entry to this block
  97
  98 -- | A basic block with liveness information.
  99 type LiveBasicBlock
 100         = GenBasicBlock LiveInstr
 101
 102
 103 instance Outputable LiveInstr where
 104         ppr (Instr instr Nothing)
 105          = ppr instr
 106
 107         ppr (Instr instr (Just live))
 108          =  ppr instr
 109                 $$ (nest 8
 110                         $ vcat
 111                         [ pprRegs (ptext SLIT("# born:    ")) (liveBorn live)
 112                         , pprRegs (ptext SLIT("# r_dying: ")) (liveDieRead live)
 113                         , pprRegs (ptext SLIT("# w_dying: ")) (liveDieWrite live) ]
 114                     $+$ space)
 115
 116          where  pprRegs :: SDoc -> RegSet -> SDoc
 117                 pprRegs name regs
 118                  | isEmptyUniqSet regs  = empty
 119                  | otherwise            = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
 120
 121
 122 instance Outputable LiveInfo where
 123         ppr (LiveInfo static firstId liveOnEntry)
 124                 =  (vcat $ map ppr static)
 125                 $$ text "# firstId     = " <> ppr firstId
 126                 $$ text "# liveOnEntry = " <> ppr liveOnEntry
 127
 128
 129 -- | map a function across all the basic blocks in this code
 130 --
 131 mapBlockTop
 132         :: (LiveBasicBlock -> LiveBasicBlock)
 133         -> LiveCmmTop -> LiveCmmTop
 134
 135 mapBlockTop f cmm
 136         = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
 137
 138
 139 -- | map a function across all the basic blocks in this code (monadic version)
 140 --
 141 mapBlockTopM
 142         :: Monad m
 143         => (LiveBasicBlock -> m LiveBasicBlock)
 144         -> LiveCmmTop -> m LiveCmmTop
 145
 146 mapBlockTopM f cmm@(CmmData{})
 147         = return cmm
 148
 149 mapBlockTopM f (CmmProc header label params comps)
 150  = do   comps'  <- mapM (mapBlockCompM f) comps
 151         return  $ CmmProc header label params comps'
 152
 153 mapBlockCompM f (BasicBlock i blocks)
 154  = do   blocks' <- mapM f blocks
 155         return  $ BasicBlock i blocks'
 156
 157
 158 -- map a function across all the basic blocks in this code
 159 mapGenBlockTop
 160         :: (GenBasicBlock i -> GenBasicBlock i)
 161         -> (GenCmmTop d h i -> GenCmmTop d h i)
 162
 163 mapGenBlockTop f cmm
 164         = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
 165
 166
 167 -- | map a function across all the basic blocks in this code (monadic version)
 168 mapGenBlockTopM
 169         :: Monad m
 170         => (GenBasicBlock i -> m (GenBasicBlock i))
 171         -> (GenCmmTop d h i -> m (GenCmmTop d h i))
 172
 173 mapGenBlockTopM f cmm@(CmmData{})
 174         = return cmm
 175
 176 mapGenBlockTopM f (CmmProc header label params blocks)
 177  = do   blocks' <- mapM f blocks
 178         return  $ CmmProc header label params blocks'
 179
 180
 181
 182
 183
 184 -- | Slurp out the list of register conflicts from this top level thing.
 185
 186 slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
 187 slurpConflicts live
 188         = slurpCmm emptyBag live
 189
 190  where  slurpCmm   rs  CmmData{}                = rs
 191         slurpCmm   rs (CmmProc info _ _ blocks)
 192                 = foldl' (slurpComp info) rs blocks
 193
 194         slurpComp  info rs (BasicBlock i blocks)
 195                 = foldl' (slurpBlock info) rs blocks
 196
 197         slurpBlock info rs (BasicBlock blockId instrs)
 198                 | LiveInfo _ _ blockLive        <- info
 199                 , Just rsLiveEntry              <- lookupUFM blockLive blockId
 200                 = consBag rsLiveEntry $ slurpLIs rsLiveEntry rs instrs
 201
 202         slurpLIs rsLive rs []                           = consBag rsLive rs
 203         slurpLIs rsLive rs (Instr _ Nothing     : lis)  = slurpLIs rsLive rs lis
 204
 205         slurpLIs rsLiveEntry rs (li@(Instr _ (Just live)) : lis)
 206          = let
 207                 -- regs that die because they are read for the last time at the start of an instruction
 208                 --      are not live across it.
 209                 rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
 210
 211                 -- regs live on entry to the next instruction.
 212                 --      be careful of orphans, make sure to delete dying regs _after_ unioning
 213                 --      in the ones that are born here.
 214                 rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
 215                                                 `minusUniqSet`  (liveDieWrite live)
 216
 217                 -- orphan vregs are the ones that die in the same instruction they are born in.
 218                 --      these are likely to be results that are never used, but we still
 219                 --      need to assign a hreg to them..
 220                 rsOrphans       = intersectUniqSets
 221                                         (liveBorn live)
 222                                         (unionUniqSets (liveDieWrite live) (liveDieRead live))
 223
 224                 --
 225                 rsConflicts     = unionUniqSets rsLiveNext rsOrphans
 226
 227           in    slurpLIs rsLiveNext (consBag rsConflicts rs) lis
 228
 229
 230 -- | Strip away liveness information, yielding NatCmmTop
 231
 232 stripLive :: LiveCmmTop -> NatCmmTop
 233 stripLive live
 234         = stripCmm live
 235
 236  where  stripCmm (CmmData sec ds)       = CmmData sec ds
 237         stripCmm (CmmProc (LiveInfo info _ _) label params comps)
 238                 = CmmProc info label params (concatMap stripComp comps)
 239
 240         stripComp  (BasicBlock i blocks)        = map stripBlock blocks
 241         stripBlock (BasicBlock i instrs)        = BasicBlock i (map stripLI instrs)
 242         stripLI    (Instr instr _)              = instr
 243
 244
 245 -- | Make real spill instructions out of SPILL, RELOAD pseudos
 246
 247 spillNatBlock :: NatBasicBlock -> NatBasicBlock
 248 spillNatBlock (BasicBlock i instrs)
 249  =      BasicBlock i instrs'
 250  where  (instrs', _)
 251                 = runState (mapM spillNat instrs) 0
 252
 253         spillNat instr@(DELTA i)
 254          = do   put i
 255                 return instr
 256
 257         spillNat (SPILL reg slot)
 258          = do   delta   <- get
 259                 return  $ mkSpillInstr reg delta slot
 260
 261         spillNat (RELOAD slot reg)
 262          = do   delta   <- get
 263                 return  $ mkLoadInstr reg delta slot
 264
 265         spillNat instr
 266          =      return instr
 267
 268
 269 -- | Slurp out a map of how many times each register was live upon entry to an instruction.
 270
 271 lifetimeCount
 272         :: LiveCmmTop
 273         -> UniqFM (Reg, Int)    -- ^ reg -> (reg, count)
 274
 275 lifetimeCount cmm
 276         = countCmm emptyUFM cmm
 277  where
 278         countCmm fm  CmmData{}          = fm
 279         countCmm fm (CmmProc info _ _ blocks)
 280                 = foldl' (countComp info) fm blocks
 281
 282         countComp info fm (BasicBlock i blocks)
 283                 = foldl' (countBlock info) fm blocks
 284
 285         countBlock info fm (BasicBlock blockId instrs)
 286                 | LiveInfo _ _ blockLive        <- info
 287                 , Just rsLiveEntry              <- lookupUFM blockLive blockId
 288                 = countLIs rsLiveEntry fm instrs
 289
 290         countLIs rsLive fm []                           = fm
 291         countLIs rsLive fm (Instr _ Nothing : lis)      = countLIs rsLive fm lis
 292
 293         countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
 294          = let
 295                 rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
 296
 297                 rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
 298                                                  `minusUniqSet` (liveDieWrite live)
 299
 300                 add r fm        = addToUFM_C
 301                                         (\(r1, l1) (_, l2) -> (r1, l1 + l2))
 302                                         fm r (r, 1)
 303
 304                 fm'             = foldUniqSet add fm rsLiveEntry
 305            in   countLIs rsLiveNext fm' lis
 306
 307
 308 -- | Erase Delta instructions.
 309
 310 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
 311 eraseDeltasLive cmm
 312         = mapBlockTop eraseBlock cmm
 313  where
 314         isDelta (DELTA _)       = True
 315         isDelta _               = False
 316
 317         eraseBlock (BasicBlock id lis)
 318                 = BasicBlock id
 319                 $ filter (\(Instr i _) -> not $ isDelta i)
 320                 $ lis
 321
 322
 323 -- | Patch the registers in this code according to this register mapping.
 324 --      also erase reg -> reg moves when the reg is the same.
 325 --      also erase reg -> reg moves when the destination dies in this instr.
 326
 327 patchEraseLive
 328         :: (Reg -> Reg)
 329         -> LiveCmmTop -> LiveCmmTop
 330
 331 patchEraseLive patchF cmm
 332         = patchCmm cmm
 333  where
 334         patchCmm cmm@CmmData{}  = cmm
 335
 336         patchCmm cmm@(CmmProc info label params comps)
 337          | LiveInfo static id blockMap  <- info
 338          = let  patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
 339                 blockMap'       = mapUFM patchRegSet blockMap
 340
 341                 info'           = LiveInfo static id blockMap'
 342            in   CmmProc info' label params $ map patchComp comps
 343
 344         patchComp (BasicBlock id blocks)
 345                 = BasicBlock id $ map patchBlock blocks
 346
 347         patchBlock (BasicBlock id lis)
 348                 = BasicBlock id $ patchInstrs lis
 349
 350         patchInstrs []          = []
 351         patchInstrs (li : lis)
 352
 353                 | Instr i (Just live)   <- li'
 354                 , Just (r1, r2) <- isRegRegMove i
 355                 , eatMe r1 r2 live
 356                 = patchInstrs lis
 357
 358                 | otherwise
 359                 = li' : patchInstrs lis
 360
 361                 where   li'     = patchRegsLiveInstr patchF li
 362
 363         eatMe   r1 r2 live
 364                 -- source and destination regs are the same
 365                 | r1 == r2      = True
 366
 367                 -- desination reg is never used
 368                 | elementOfUniqSet r2 (liveBorn live)
 369                 , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
 370                 = True
 371
 372                 | otherwise     = False
 373
 374
 375 -- | Patch registers in this LiveInstr, including the liveness information.
 376 --
 377 patchRegsLiveInstr
 378         :: (Reg -> Reg)
 379         -> LiveInstr -> LiveInstr
 380
 381 patchRegsLiveInstr patchF li
 382  = case li of
 383         Instr instr Nothing
 384          -> Instr (patchRegs instr patchF) Nothing
 385
 386         Instr instr (Just live)
 387          -> Instr
 388                 (patchRegs instr patchF)
 389                 (Just live
 390                         { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
 391                           liveBorn      = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
 392                         , liveDieRead   = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
 393                         , liveDieWrite  = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
 394
 395
 396 ---------------------------------------------------------------------------------
 397 -- Annotate code with register liveness information
 398 --
 399 regLiveness
 400         :: NatCmmTop
 401         -> UniqSM LiveCmmTop
 402
 403 regLiveness cmm@(CmmData sec d)
 404         = returnUs $ CmmData sec d
 405
 406 regLiveness cmm@(CmmProc info lbl params [])
 407         = returnUs $ CmmProc
 408                         (LiveInfo info Nothing emptyUFM)
 409                         lbl params []
 410
 411 regLiveness cmm@(CmmProc info lbl params blocks@(first:rest))
 412  = let  first_id                = blockId first
 413         sccs                    = sccBlocks blocks
 414         (ann_sccs, block_live)  = computeLiveness sccs
 415
 416         liveBlocks
 417          = map (\scc -> case scc of
 418                         AcyclicSCC  b@(BasicBlock l _)          -> BasicBlock l [b]
 419                         CyclicSCC  bs@(BasicBlock l _ : _)      -> BasicBlock l bs
 420                         CyclicSCC  []
 421                          -> panic "RegLiveness.regLiveness: no blocks in scc list")
 422                  $ ann_sccs
 423
 424    in   returnUs $ CmmProc
 425                         (LiveInfo info (Just first_id) block_live)
 426                         lbl params liveBlocks
 427
 428
 429 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
 430 sccBlocks blocks = stronglyConnComp graph
 431   where
 432         getOutEdges :: [Instr] -> [BlockId]
 433         getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
 434
 435         graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
 436                 | block@(BasicBlock id instrs) <- blocks ]
 437
 438
 439 -- -----------------------------------------------------------------------------
 440 -- Computing liveness
 441
 442 computeLiveness
 443    :: [SCC NatBasicBlock]
 444    -> ([SCC LiveBasicBlock],            -- instructions annotated with list of registers
 445                                         -- which are "dead after this instruction".
 446        BlockMap RegSet)                 -- blocks annontated with set of live registers
 447                                         -- on entry to the block.
 448
 449   -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
 450   -- control to earlier ones only.  The SCCs returned are in the *opposite*
 451   -- order, which is exactly what we want for the next pass.
 452
 453 computeLiveness sccs
 454         = livenessSCCs emptyBlockMap [] sccs
 455
 456
 457 livenessSCCs
 458        :: BlockMap RegSet
 459        -> [SCC LiveBasicBlock]          -- accum
 460        -> [SCC NatBasicBlock]
 461        -> ([SCC LiveBasicBlock], BlockMap RegSet)
 462
 463 livenessSCCs blockmap done [] = (done, blockmap)
 464
 465 livenessSCCs blockmap done (AcyclicSCC block : sccs)
 466  = let  (blockmap', block')     = livenessBlock blockmap block
 467    in   livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
 468
 469 livenessSCCs blockmap done
 470         (CyclicSCC blocks : sccs) =
 471         livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
 472  where      (blockmap', blocks')
 473                 = iterateUntilUnchanged linearLiveness equalBlockMaps
 474                                       blockmap blocks
 475
 476             iterateUntilUnchanged
 477                 :: (a -> b -> (a,c)) -> (a -> a -> Bool)
 478                 -> a -> b
 479                 -> (a,c)
 480
 481             iterateUntilUnchanged f eq a b
 482                 = head $
 483                   concatMap tail $
 484                   groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
 485                   iterate (\(a, _) -> f a b) $
 486                   (a, error "RegisterAlloc.livenessSCCs")
 487
 488
 489             linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
 490                            -> (BlockMap RegSet, [LiveBasicBlock])
 491             linearLiveness = mapAccumL livenessBlock
 492
 493                 -- probably the least efficient way to compare two
 494                 -- BlockMaps for equality.
 495             equalBlockMaps a b
 496                 = a' == b'
 497               where a' = map f $ ufmToList a
 498                     b' = map f $ ufmToList b
 499                     f (key,elt) = (key, uniqSetToList elt)
 500
 501
 502
 503 -- | Annotate a basic block with register liveness information.
 504 --
 505 livenessBlock
 506         :: BlockMap RegSet
 507         -> NatBasicBlock
 508         -> (BlockMap RegSet, LiveBasicBlock)
 509
 510 livenessBlock blockmap block@(BasicBlock block_id instrs)
 511  = let
 512         (regsLiveOnEntry, instrs1)
 513                 = livenessBack emptyUniqSet blockmap [] (reverse instrs)
 514         blockmap'       = addToUFM blockmap block_id regsLiveOnEntry
 515
 516         instrs2         = livenessForward regsLiveOnEntry instrs1
 517
 518         output          = BasicBlock block_id instrs2
 519
 520    in   ( blockmap', output)
 521
 522 -- | Calculate liveness going forwards,
 523 --      filling in when regs are born
 524
 525 livenessForward
 526         :: RegSet                       -- regs live on this instr
 527         -> [LiveInstr] -> [LiveInstr]
 528
 529 livenessForward rsLiveEntry []  = []
 530 livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
 531         | Nothing               <- mLive
 532         = li : livenessForward rsLiveEntry lis
 533
 534         | Just live             <- mLive
 535         , RU read written       <- regUsage instr
 536         = let
 537                 -- Regs that are written to but weren't live on entry to this instruction
 538                 --      are recorded as being born here.
 539                 rsBorn          = mkUniqSet
 540                                 $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
 541
 542                 rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
 543                                         `minusUniqSet` (liveDieRead live)
 544                                         `minusUniqSet` (liveDieWrite live)
 545
 546         in Instr instr (Just live { liveBorn = rsBorn })
 547                 : livenessForward rsLiveNext lis
 548
 549
 550 -- | Calculate liveness going backwards,
 551 --      filling in when regs die, and what regs are live across each instruction
 552
 553 livenessBack
 554         :: RegSet                       -- regs live on this instr
 555         -> BlockMap RegSet              -- regs live on entry to other BBs
 556         -> [LiveInstr]                  -- instructions (accum)
 557         -> [Instr]                      -- instructions
 558         -> (RegSet, [LiveInstr])
 559
 560 livenessBack liveregs blockmap done []  = (liveregs, done)
 561
 562 livenessBack liveregs blockmap acc (instr : instrs)
 563  = let  (liveregs', instr')     = liveness1 liveregs blockmap instr
 564    in   livenessBack liveregs' blockmap (instr' : acc) instrs
 565
 566 -- don't bother tagging comments or deltas with liveness
 567 liveness1 liveregs blockmap (instr@COMMENT{})
 568         = (liveregs, Instr instr Nothing)
 569
 570 liveness1 liveregs blockmap (instr@DELTA{})
 571         = (liveregs, Instr instr Nothing)
 572
 573 liveness1 liveregs blockmap instr
 574
 575       | not_a_branch
 576       = (liveregs1, Instr instr
 577                         (Just $ Liveness
 578                         { liveBorn      = emptyUniqSet
 579                         , liveDieRead   = mkUniqSet r_dying
 580                         , liveDieWrite  = mkUniqSet w_dying }))
 581
 582       | otherwise
 583       = (liveregs_br, Instr instr
 584                         (Just $ Liveness
 585                         { liveBorn      = emptyUniqSet
 586                         , liveDieRead   = mkUniqSet r_dying_br
 587                         , liveDieWrite  = mkUniqSet w_dying }))
 588
 589       where
 590             RU read written = regUsage instr
 591
 592             -- registers that were written here are dead going backwards.
 593             -- registers that were read here are live going backwards.
 594             liveregs1   = (liveregs `delListFromUniqSet` written)
 595                                     `addListToUniqSet` read
 596
 597             -- registers that are not live beyond this point, are recorded
 598             --  as dying here.
 599             r_dying     = [ reg | reg <- read, reg `notElem` written,
 600                               not (elementOfUniqSet reg liveregs) ]
 601
 602             w_dying     = [ reg | reg <- written,
 603                              not (elementOfUniqSet reg liveregs) ]
 604
 605             -- union in the live regs from all the jump destinations of this
 606             -- instruction.
 607             targets      = jumpDests instr [] -- where we go from here
 608             not_a_branch = null targets
 609
 610             targetLiveRegs target
 611                   = case lookupUFM blockmap target of
 612                                 Just ra -> ra
 613                                 Nothing -> emptyBlockMap
 614
 615             live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
 616
 617             liveregs_br = liveregs1 `unionUniqSets` live_from_branch
 618
 619             -- registers that are live only in the branch targets should
 620             -- be listed as dying here.
 621             live_branch_only = live_from_branch `minusUniqSet` liveregs
 622             r_dying_br  = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
 623                                         live_branch_only)
 624
 625
 626
 627