Liveness.hs 35.8 KB
Newer Older
1 2 3 4 5
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

6 7 8 9
-----------------------------------------------------------------------------
--
-- The register liveness determinator
--
Gabor Greif's avatar
Gabor Greif committed
10
-- (c) The University of Glasgow 2004-2013
11 12
--
-----------------------------------------------------------------------------
13

14
module RegAlloc.Liveness (
15 16 17
        RegSet,
        RegMap, emptyRegMap,
        BlockMap, emptyBlockMap,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
18
        LiveCmmDecl,
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
        InstrSR   (..),
        LiveInstr (..),
        Liveness (..),
        LiveInfo (..),
        LiveBasicBlock,

        mapBlockTop,    mapBlockTopM,   mapSCCM,
        mapGenBlockTop, mapGenBlockTopM,
        stripLive,
        stripLiveBlock,
        slurpConflicts,
        slurpReloadCoalesce,
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
        reverseBlocksInTops,
        regLiveness,
        natCmmTopToLive
37
  ) where
38 39 40
import Reg
import Instruction

41
import BlockId
42 43
import Cmm hiding (RegSet)
import PprCmm()
44 45

import Digraph
46
import DynFlags
47
import Outputable
48
import Platform
49
import UniqSet
50
import UniqFM
51 52 53
import UniqSupply
import Bag
import State
54
import FastString
55 56 57

import Data.List
import Data.Maybe
58 59 60
import Data.Map                 (Map)
import Data.Set                 (Set)
import qualified Data.Map       as Map
61 62 63 64 65

-----------------------------------------------------------------------------
type RegSet = UniqSet Reg

type RegMap a = UniqFM a
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
66 67

emptyRegMap :: UniqFM a
68 69
emptyRegMap = emptyUFM

70
type BlockMap a = BlockEnv a
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
71

72 73

-- | A top level thing which carries liveness information.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
74 75
type LiveCmmDecl statics instr
        = GenCmmDecl
76 77 78
                statics
                LiveInfo
                [SCC (LiveBasicBlock instr)]
79

80

81
-- | The register allocator also wants to use SPILL/RELOAD meta instructions,
82
--   so we'll keep those here.
83
data InstrSR instr
84 85
        -- | A real machine instruction
        = Instr  instr
86

87 88
        -- | spill this reg to a stack slot
        | SPILL  Reg Int
89

90 91
        -- | reload this reg from a stack slot
        | RELOAD Int Reg
92 93

instance Instruction instr => Instruction (InstrSR instr) where
94
        regUsageOfInstr platform i
95
         = case i of
96
                Instr  instr    -> regUsageOfInstr platform instr
97 98
                SPILL  reg _    -> RU [reg] []
                RELOAD _ reg    -> RU [] [reg]
99

100 101 102 103 104
        patchRegsOfInstr i f
         = case i of
                Instr instr     -> Instr (patchRegsOfInstr instr f)
                SPILL  reg slot -> SPILL (f reg) slot
                RELOAD slot reg -> RELOAD slot (f reg)
105

106 107 108 109
        isJumpishInstr i
         = case i of
                Instr instr     -> isJumpishInstr instr
                _               -> False
110

111 112 113 114
        jumpDestsOfInstr i
         = case i of
                Instr instr     -> jumpDestsOfInstr instr
                _               -> []
115

116 117 118 119
        patchJumpInstr i f
         = case i of
                Instr instr     -> Instr (patchJumpInstr instr f)
                _               -> i
120

121 122
        mkSpillInstr            = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
        mkLoadInstr             = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
123

124 125 126 127
        takeDeltaInstr i
         = case i of
                Instr instr     -> takeDeltaInstr instr
                _               -> Nothing
128

129 130 131 132
        isMetaInstr i
         = case i of
                Instr instr     -> isMetaInstr instr
                _               -> False
133

134 135
        mkRegRegMoveInstr platform r1 r2
            = Instr (mkRegRegMoveInstr platform r1 r2)
136

137 138 139 140 141 142
        takeRegRegMoveInstr i
         = case i of
                Instr instr     -> takeRegRegMoveInstr instr
                _               -> Nothing

        mkJumpInstr target      = map Instr (mkJumpInstr target)
143

Simon Marlow's avatar
Simon Marlow committed
144 145 146 147 148
        mkStackAllocInstr platform amount =
             Instr (mkStackAllocInstr platform amount)

        mkStackDeallocInstr platform amount =
             Instr (mkStackDeallocInstr platform amount)
149 150 151 152


-- | An instruction with liveness information.
data LiveInstr instr
153
        = LiveInstr (InstrSR instr) (Maybe Liveness)
154

155
-- | Liveness information.
156 157 158 159 160
--   The regs which die are ones which are no longer live in the *next* instruction
--   in this sequence.
--   (NB. if the instruction is a jump, these registers might still be live
--   at the jump target(s) - you have to check the liveness at the destination
--   block to find out).
161 162

data Liveness
163 164 165 166
        = Liveness
        { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).
        , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.
        , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.
167 168 169 170


-- | Stash regs live on entry to each basic block in the info part of the cmm code.
data LiveInfo
171
        = LiveInfo
172 173 174 175 176
                (BlockEnv CmmStatics)     -- cmm info table static stuff
                [BlockId]                 -- entry points (first one is the
                                          -- entry point for the proc).
                (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block
                (Map BlockId (Set Int))   -- stack slots live on entry to this block
177

178 179

-- | A basic block with liveness information.
180
type LiveBasicBlock instr
181
        = GenBasicBlock (LiveInstr instr)
182 183


Ian Lynagh's avatar
Ian Lynagh committed
184 185
instance Outputable instr
      => Outputable (InstrSR instr) where
186

Ian Lynagh's avatar
Ian Lynagh committed
187 188
        ppr (Instr realInstr)
           = ppr realInstr
189

Ian Lynagh's avatar
Ian Lynagh committed
190
        ppr (SPILL reg slot)
191 192 193 194 195 196 197
           = hcat [
                ptext (sLit "\tSPILL"),
                char ' ',
                ppr reg,
                comma,
                ptext (sLit "SLOT") <> parens (int slot)]

Ian Lynagh's avatar
Ian Lynagh committed
198
        ppr (RELOAD slot reg)
199 200 201 202 203 204 205
           = hcat [
                ptext (sLit "\tRELOAD"),
                char ' ',
                ptext (sLit "SLOT") <> parens (int slot),
                comma,
                ppr reg]

Ian Lynagh's avatar
Ian Lynagh committed
206 207
instance Outputable instr
      => Outputable (LiveInstr instr) where
208

Ian Lynagh's avatar
Ian Lynagh committed
209 210
        ppr (LiveInstr instr Nothing)
         = ppr instr
211

Ian Lynagh's avatar
Ian Lynagh committed
212 213
        ppr (LiveInstr instr (Just live))
         =  ppr instr
214 215 216 217 218 219
                $$ (nest 8
                        $ vcat
                        [ pprRegs (ptext (sLit "# born:    ")) (liveBorn live)
                        , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
                        , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
                    $+$ space)
220

221 222 223 224
         where  pprRegs :: SDoc -> RegSet -> SDoc
                pprRegs name regs
                 | isEmptyUniqSet regs  = empty
                 | otherwise            = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
225

Ian Lynagh's avatar
Ian Lynagh committed
226
instance Outputable LiveInfo where
227
    ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)
228
        =  (ppr mb_static)
229
        $$ text "# entryIds         = " <> ppr entryIds
230 231
        $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
        $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
232 233


234

235 236 237
-- | map a function across all the basic blocks in this code
--
mapBlockTop
238
        :: (LiveBasicBlock instr -> LiveBasicBlock instr)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
239
        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
240 241

mapBlockTop f cmm
242
        = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
243 244 245 246 247


-- | map a function across all the basic blocks in this code (monadic version)
--
mapBlockTopM
248 249
        :: Monad m
        => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
250
        -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
251

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
252
mapBlockTopM _ cmm@(CmmData{})
253
        = return cmm
254

255
mapBlockTopM f (CmmProc header label live sccs)
256
 = do   sccs'   <- mapM (mapSCCM f) sccs
257
        return  $ CmmProc header label live sccs'
258 259

mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
260 261 262
mapSCCM f (AcyclicSCC x)
 = do   x'      <- f x
        return  $ AcyclicSCC x'
263

264
mapSCCM f (CyclicSCC xs)
265 266
 = do   xs'     <- mapM f xs
        return  $ CyclicSCC xs'
267

268

269 270
-- map a function across all the basic blocks in this code
mapGenBlockTop
271
        :: (GenBasicBlock             i -> GenBasicBlock            i)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
272
        -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))
273 274

mapGenBlockTop f cmm
275
        = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
276 277 278 279


-- | map a function across all the basic blocks in this code (monadic version)
mapGenBlockTopM
280 281
        :: Monad m
        => (GenBasicBlock            i  -> m (GenBasicBlock            i))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
282
        -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))
283

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
284
mapGenBlockTopM _ cmm@(CmmData{})
285
        = return cmm
286

287
mapGenBlockTopM f (CmmProc header label live (ListGraph blocks))
288
 = do   blocks' <- mapM f blocks
289
        return  $ CmmProc header label live (ListGraph blocks')
290 291


292
-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
293 294
--   Slurping of conflicts and moves is wrapped up together so we don't have
--   to make two passes over the same code when we want to build the graph.
295
--
296 297
slurpConflicts
        :: Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
298
        => LiveCmmDecl statics instr
299
        -> (Bag (UniqSet Reg), Bag (Reg, Reg))
300

301
slurpConflicts live
302
        = slurpCmm (emptyBag, emptyBag) live
303

304
 where  slurpCmm   rs  CmmData{}                = rs
305
        slurpCmm   rs (CmmProc info _ _ sccs)
306
                = foldl' (slurpSCC info) rs sccs
307

308 309
        slurpSCC  info rs (AcyclicSCC b)
                = slurpBlock info rs b
310

311 312
        slurpSCC  info rs (CyclicSCC bs)
                = foldl'  (slurpBlock info) rs bs
313

314 315 316 317 318
        slurpBlock info rs (BasicBlock blockId instrs)
                | LiveInfo _ _ (Just blockLive) _ <- info
                , Just rsLiveEntry                <- mapLookup blockId blockLive
                , (conflicts, moves)              <- slurpLIs rsLiveEntry rs instrs
                = (consBag rsLiveEntry conflicts, moves)
319

320 321
                | otherwise
                = panic "Liveness.slurpConflicts: bad block"
322

323 324
        slurpLIs rsLive (conflicts, moves) []
                = (consBag rsLive conflicts, moves)
325

326 327
        slurpLIs rsLive rs (LiveInstr _ Nothing     : lis)
                = slurpLIs rsLive rs lis
328

329 330 331 332 333
        slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis)
         = let
                -- regs that die because they are read for the last time at the start of an instruction
                --      are not live across it.
                rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
334

335 336 337 338 339
                -- regs live on entry to the next instruction.
                --      be careful of orphans, make sure to delete dying regs _after_ unioning
                --      in the ones that are born here.
                rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
                                                `minusUniqSet`  (liveDieWrite live)
340

341 342 343 344 345 346
                -- orphan vregs are the ones that die in the same instruction they are born in.
                --      these are likely to be results that are never used, but we still
                --      need to assign a hreg to them..
                rsOrphans       = intersectUniqSets
                                        (liveBorn live)
                                        (unionUniqSets (liveDieWrite live) (liveDieRead live))
347

348 349
                --
                rsConflicts     = unionUniqSets rsLiveNext rsOrphans
350

351 352 353 354 355 356 357 358
          in    case takeRegRegMoveInstr instr of
                 Just rr        -> slurpLIs rsLiveNext
                                        ( consBag rsConflicts conflicts
                                        , consBag rr moves) lis

                 Nothing        -> slurpLIs rsLiveNext
                                        ( consBag rsConflicts conflicts
                                        , moves) lis
359 360


Ian Lynagh's avatar
Ian Lynagh committed
361
-- | For spill\/reloads
362
--
363 364 365
--   SPILL  v1, slot1
--   ...
--   RELOAD slot1, v2
366
--
367 368
--   If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
--   the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
369 370
--
--
371 372
slurpReloadCoalesce
        :: forall statics instr. Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
373
        => LiveCmmDecl statics instr
374
        -> Bag (Reg, Reg)
375

376
slurpReloadCoalesce live
377
        = slurpCmm emptyBag live
378

379
 where
380
        slurpCmm :: Bag (Reg, Reg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
381
                 -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]
382
                 -> Bag (Reg, Reg)
383
        slurpCmm cs CmmData{}   = cs
384
        slurpCmm cs (CmmProc _ _ _ sccs)
385
                = slurpComp cs (flattenSCCs sccs)
386

387 388 389
        slurpComp :: Bag (Reg, Reg)
                     -> [LiveBasicBlock instr]
                     -> Bag (Reg, Reg)
390 391 392
        slurpComp  cs blocks
         = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
           in   unionManyBags (cs : moveBags)
393

394 395
        slurpCompM :: [LiveBasicBlock instr]
                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
396 397 398
        slurpCompM blocks
         = do   -- run the analysis once to record the mapping across jumps.
                mapM_   (slurpBlock False) blocks
399

400 401 402 403 404
                -- run it a second time while using the information from the last pass.
                --      We /could/ run this many more times to deal with graphical control
                --      flow and propagating info across multiple jumps, but it's probably
                --      not worth the trouble.
                mapM    (slurpBlock True) blocks
405

406 407
        slurpBlock :: Bool -> LiveBasicBlock instr
                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431
        slurpBlock propagate (BasicBlock blockId instrs)
         = do   -- grab the slot map for entry to this block
                slotMap         <- if propagate
                                        then getSlotMap blockId
                                        else return emptyUFM

                (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
                return $ listToBag $ catMaybes mMoves

        slurpLI :: UniqFM Reg                           -- current slotMap
                -> LiveInstr instr
                -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]
                                                        --      for tracking slotMaps across jumps

                         ( UniqFM Reg                   -- new slotMap
                         , Maybe (Reg, Reg))            -- maybe a new coalesce edge

        slurpLI slotMap li

                -- remember what reg was stored into the slot
                | LiveInstr (SPILL reg slot) _  <- li
                , slotMap'                      <- addToUFM slotMap slot reg
                = return (slotMap', Nothing)

Gabor Greif's avatar
Gabor Greif committed
432
                -- add an edge between the this reg and the last one stored into the slot
433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468
                | LiveInstr (RELOAD slot reg) _ <- li
                = case lookupUFM slotMap slot of
                        Just reg2
                         | reg /= reg2  -> return (slotMap, Just (reg, reg2))
                         | otherwise    -> return (slotMap, Nothing)

                        Nothing         -> return (slotMap, Nothing)

                -- if we hit a jump, remember the current slotMap
                | LiveInstr (Instr instr) _     <- li
                , targets                       <- jumpDestsOfInstr instr
                , not $ null targets
                = do    mapM_   (accSlotMap slotMap) targets
                        return  (slotMap, Nothing)

                | otherwise
                = return (slotMap, Nothing)

        -- record a slotmap for an in edge to this block
        accSlotMap slotMap blockId
                = modify (\s -> addToUFM_C (++) s blockId [slotMap])

        -- work out the slot map on entry to this block
        --      if we have slot maps for multiple in-edges then we need to merge them.
        getSlotMap blockId
         = do   map             <- get
                let slotMaps    = fromMaybe [] (lookupUFM map blockId)
                return          $ foldr mergeSlotMaps emptyUFM slotMaps

        mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
        mergeSlotMaps map1 map2
                = listToUFM
                $ [ (k, r1)     | (k, r1)       <- ufmToList map1
                                , case lookupUFM map2 k of
                                        Nothing -> False
                                        Just r2 -> r1 == r2 ]
469 470


Simon Peyton Jones's avatar
Simon Peyton Jones committed
471
-- | Strip away liveness information, yielding NatCmmDecl
472
stripLive
Ian Lynagh's avatar
Ian Lynagh committed
473
        :: (Outputable statics, Outputable instr, Instruction instr)
474
        => DynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
475 476
        -> LiveCmmDecl statics instr
        -> NatCmmDecl statics instr
477

478
stripLive dflags live
479 480
        = stripCmm live

Ian Lynagh's avatar
Ian Lynagh committed
481
 where  stripCmm :: (Outputable statics, Outputable instr, Instruction instr)
482 483
                 => LiveCmmDecl statics instr -> NatCmmDecl statics instr
        stripCmm (CmmData sec ds)       = CmmData sec ds
484
        stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs)
485 486 487 488 489 490 491 492
         = let  final_blocks    = flattenSCCs sccs

                -- make sure the block that was first in the input list
                --      stays at the front of the output. This is the entry point
                --      of the proc, and it needs to come first.
                ((first':_), rest')
                                = partition ((== first_id) . blockId) final_blocks

493
           in   CmmProc info label live
494
                          (ListGraph $ map (stripLiveBlock dflags) $ first' : rest')
495

496
        -- procs used for stg_split_markers don't contain any blocks, and have no first_id.
497
        stripCmm (CmmProc (LiveInfo info [] _ _) label live [])
498
         =      CmmProc info label live (ListGraph [])
499

500 501
        -- If the proc has blocks but we don't know what the first one was, then we're dead.
        stripCmm proc
Ian Lynagh's avatar
Ian Lynagh committed
502
                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
503

504
-- | Strip away liveness information from a basic block,
505
--   and make real spill instructions out of SPILL, RELOAD pseudos along the way.
506

507
stripLiveBlock
508
        :: Instruction instr
509
        => DynFlags
510
        -> LiveBasicBlock instr
511
        -> NatBasicBlock instr
512

513
stripLiveBlock dflags (BasicBlock i lis)
514
 =      BasicBlock i instrs'
515

516 517
 where  (instrs', _)
                = runState (spillNat [] lis) 0
518

519 520
        spillNat acc []
         =      return (reverse acc)
521

522 523
        spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
         = do   delta   <- get
524
                spillNat (mkSpillInstr dflags reg delta slot : acc) instrs
525

526 527
        spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
         = do   delta   <- get
528
                spillNat (mkLoadInstr dflags reg delta slot : acc) instrs
529

530 531 532 533
        spillNat acc (LiveInstr (Instr instr) _ : instrs)
         | Just i <- takeDeltaInstr instr
         = do   put i
                spillNat acc instrs
534

535 536
        spillNat acc (LiveInstr (Instr instr) _ : instrs)
         =      spillNat (instr : acc) instrs
537 538


539 540
-- | Erase Delta instructions.

541 542
eraseDeltasLive
        :: Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
543 544
        => LiveCmmDecl statics instr
        -> LiveCmmDecl statics instr
545

546
eraseDeltasLive cmm
547
        = mapBlockTop eraseBlock cmm
548
 where
549 550 551 552
        eraseBlock (BasicBlock id lis)
                = BasicBlock id
                $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
                $ lis
553 554 555


-- | Patch the registers in this code according to this register mapping.
556 557
--   also erase reg -> reg moves when the reg is the same.
--   also erase reg -> reg moves when the destination dies in this instr.
558
patchEraseLive
559 560
        :: Instruction instr
        => (Reg -> Reg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
561
        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
562 563

patchEraseLive patchF cmm
564
        = patchCmm cmm
565
 where
566
        patchCmm cmm@CmmData{}  = cmm
567

568
        patchCmm (CmmProc info label live sccs)
569 570 571 572
         | LiveInfo static id (Just blockMap) mLiveSlots <- info
         = let
                patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
                blockMap'       = mapMap patchRegSet blockMap
573

574
                info'           = LiveInfo static id (Just blockMap') mLiveSlots
575
           in   CmmProc info' label live $ map patchSCC sccs
576

577 578
         | otherwise
         = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
579

580 581
        patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)
        patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs)
582

583 584
        patchBlock (BasicBlock id lis)
                = BasicBlock id $ patchInstrs lis
585

586 587
        patchInstrs []          = []
        patchInstrs (li : lis)
588

589 590 591 592
                | LiveInstr i (Just live)       <- li'
                , Just (r1, r2) <- takeRegRegMoveInstr i
                , eatMe r1 r2 live
                = patchInstrs lis
593

594 595
                | otherwise
                = li' : patchInstrs lis
596

597
                where   li'     = patchRegsLiveInstr patchF li
598

599 600 601
        eatMe   r1 r2 live
                -- source and destination regs are the same
                | r1 == r2      = True
602

Gabor Greif's avatar
Gabor Greif committed
603
                -- destination reg is never used
604 605 606
                | elementOfUniqSet r2 (liveBorn live)
                , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
                = True
607

608
                | otherwise     = False
609 610 611 612 613


-- | Patch registers in this LiveInstr, including the liveness information.
--
patchRegsLiveInstr
614 615 616
        :: Instruction instr
        => (Reg -> Reg)
        -> LiveInstr instr -> LiveInstr instr
617 618 619

patchRegsLiveInstr patchF li
 = case li of
620 621
        LiveInstr instr Nothing
         -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
622

623 624 625 626 627 628 629 630
        LiveInstr instr (Just live)
         -> LiveInstr
                (patchRegsOfInstr instr patchF)
                (Just live
                        { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
                          liveBorn      = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
                        , liveDieRead   = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
                        , liveDieWrite  = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
631 632


633
--------------------------------------------------------------------------------
Simon Peyton Jones's avatar
Simon Peyton Jones committed
634
-- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information
635

636 637
natCmmTopToLive
        :: Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
638 639
        => NatCmmDecl statics instr
        -> LiveCmmDecl statics instr
640

641
natCmmTopToLive (CmmData i d)
642
        = CmmData i d
643

644
natCmmTopToLive (CmmProc info lbl live (ListGraph []))
645
        = CmmProc (LiveInfo info [] Nothing Map.empty) lbl live []
646

647
natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
648
 = let  first_id        = blockId first
649 650 651
        all_entry_ids   = entryBlocks proc
        sccs            = sccBlocks blocks all_entry_ids
        entry_ids       = filter (/= first_id) all_entry_ids
652 653 654 655
        sccsLive        = map (fmap (\(BasicBlock l instrs) ->
                                        BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
                        $ sccs

656 657
   in   CmmProc (LiveInfo info (first_id : entry_ids) Nothing Map.empty)
                lbl live sccsLive
658

659

660 661 662 663 664 665 666 667 668 669
--
-- Compute the liveness graph of the set of basic blocks.  Important:
-- we also discard any unreachable code here, starting from the entry
-- points (the first block in the list, and any blocks with info
-- tables).  Unreachable code arises when code blocks are orphaned in
-- earlier optimisation passes, and may confuse the register allocator
-- by referring to registers that are not initialised.  It's easy to
-- discard the unreachable code as part of the SCC pass, so that's
-- exactly what we do. (#7574)
--
670 671 672
sccBlocks
        :: Instruction instr
        => [NatBasicBlock instr]
673
        -> [BlockId]
674
        -> [SCC (NatBasicBlock instr)]
675

676
sccBlocks blocks entries = map (fmap get_node) sccs
677
  where
678 679 680 681
        -- nodes :: [(NatBasicBlock instr, Unique, [Unique])]
        nodes = [ (block, id, getOutEdges instrs)
                | block@(BasicBlock id instrs) <- blocks ]

682 683 684 685 686 687 688 689 690 691
        g1 = graphFromEdgedVertices nodes

        reachable :: BlockSet
        reachable = setFromList [ id | (_,id,_) <- reachablesG g1 roots ]

        g2 = graphFromEdgedVertices [ node | node@(_,id,_) <- nodes
                                           , id `setMember` reachable ]

        sccs = stronglyConnCompG g2

692 693
        get_node (n, _, _) = n

694 695
        getOutEdges :: Instruction instr => [instr] -> [BlockId]
        getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
696

697 698 699 700 701 702 703
        -- This is truly ugly, but I don't see a good alternative.
        -- Digraph just has the wrong API.  We want to identify nodes
        -- by their keys (BlockId), but Digraph requires the whole
        -- node: (NatBasicBlock, BlockId, [BlockId]).  This takes
        -- advantage of the fact that Digraph only looks at the key,
        -- even though it asks for the whole triple.
        roots = [(panic "sccBlocks",b,panic "sccBlocks") | b <- entries ]
704 705


706 707

--------------------------------------------------------------------------------
708 709 710
-- Annotate code with register liveness information
--
regLiveness
Ian Lynagh's avatar
Ian Lynagh committed
711
        :: (Outputable instr, Instruction instr)
712 713
        => Platform
        -> LiveCmmDecl statics instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
714
        -> UniqSM (LiveCmmDecl statics instr)
715

716
regLiveness _ (CmmData i d)
717
        = return $ CmmData i d
718

719
regLiveness _ (CmmProc info lbl live [])
720
        | LiveInfo static mFirst _ _    <- info
721
        = return $ CmmProc
722
                        (LiveInfo static mFirst (Just mapEmpty) Map.empty)
723
                        lbl live []
724

725
regLiveness platform (CmmProc info lbl live sccs)
726
        | LiveInfo static mFirst _ liveSlotsOnEntry     <- info
727
        = let   (ann_sccs, block_live)  = computeLiveness platform sccs
728

729
          in    return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
730
                           lbl live ann_sccs
731 732 733


-- -----------------------------------------------------------------------------
734
-- | Check ordering of Blocks
735 736 737 738 739
--   The computeLiveness function requires SCCs to be in reverse
--   dependent order.  If they're not the liveness information will be
--   wrong, and we'll get a bad allocation.  Better to check for this
--   precondition explicitly or some other poor sucker will waste a
--   day staring at bad assembly code..
740
--
741
checkIsReverseDependent
742 743 744 745
        :: Instruction instr
        => [SCC (LiveBasicBlock instr)]         -- ^ SCCs of blocks that we're about to run the liveness determinator on.
        -> Maybe BlockId                        -- ^ BlockIds that fail the test (if any)

746 747 748
checkIsReverseDependent sccs'
 = go emptyUniqSet sccs'

749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771
 where  go _ []
         = Nothing

        go blocksSeen (AcyclicSCC block : sccs)
         = let  dests           = slurpJumpDestsOfBlock block
                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
                badDests        = dests `minusUniqSet` blocksSeen'
           in   case uniqSetToList badDests of
                 []             -> go blocksSeen' sccs
                 bad : _        -> Just bad

        go blocksSeen (CyclicSCC blocks : sccs)
         = let  dests           = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
                badDests        = dests `minusUniqSet` blocksSeen'
           in   case uniqSetToList badDests of
                 []             -> go blocksSeen' sccs
                 bad : _        -> Just bad

        slurpJumpDestsOfBlock (BasicBlock _ instrs)
                = unionManyUniqSets
                $ map (mkUniqSet . jumpDestsOfInstr)
                        [ i | LiveInstr i _ <- instrs]
772

773 774 775

-- | If we've compute liveness info for this code already we have to reverse
--   the SCCs in each top to get them back to the right order so we can do it again.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
776
reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
777 778
reverseBlocksInTops top
 = case top of
779
        CmmData{}                       -> top
780
        CmmProc info lbl live sccs      -> CmmProc info lbl live (reverse sccs)
781

782

783
-- | Computing liveness
784
--
785 786
--  On entry, the SCCs must be in "reverse" order: later blocks may transfer
--  control to earlier ones only, else `panic`.
787
--
788 789 790
--  The SCCs returned are in the *opposite* order, which is exactly what we
--  want for the next pass.
--
791
computeLiveness
Ian Lynagh's avatar
Ian Lynagh committed
792
        :: (Outputable instr, Instruction instr)
793 794
        => Platform
        -> [SCC (LiveBasicBlock instr)]
795 796 797 798
        -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
                                                -- which are "dead after this instruction".
               BlockMap RegSet)                 -- blocks annontated with set of live registers
                                                -- on entry to the block.
799

800
computeLiveness platform sccs
801
 = case checkIsReverseDependent sccs of
802
        Nothing         -> livenessSCCs platform emptyBlockMap [] sccs
803 804 805
        Just bad        -> pprPanic "RegAlloc.Liveness.computeLivenss"
                                (vcat   [ text "SCCs aren't in reverse dependent order"
                                        , text "bad blockId" <+> ppr bad
Ian Lynagh's avatar
Ian Lynagh committed
806
                                        , ppr sccs])
807 808

livenessSCCs
809
       :: Instruction instr
810 811
       => Platform
       -> BlockMap RegSet
812
       -> [SCC (LiveBasicBlock instr)]          -- accum
813
       -> [SCC (LiveBasicBlock instr)]
814
       -> ( [SCC (LiveBasicBlock instr)]
815
          , BlockMap RegSet)
816

817
livenessSCCs _ blockmap done []
818
        = (done, blockmap)
819

820 821 822
livenessSCCs platform blockmap done (AcyclicSCC block : sccs)
 = let  (blockmap', block')     = livenessBlock platform blockmap block
   in   livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs
823

ian@well-typed.com's avatar