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