Liveness.hs 33.5 KB
Newer Older
1
2
3
4
5
6
7
-----------------------------------------------------------------------------
--
-- The register liveness determinator
--
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
8
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
9

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

        mapBlockTop,    mapBlockTopM,   mapSCCM,
        mapGenBlockTop, mapGenBlockTopM,
        stripLive,
        stripLiveBlock,
        slurpConflicts,
        slurpReloadCoalesce,
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
        reverseBlocksInTops,
        regLiveness,
        natCmmTopToLive
33
  ) where
34
35
36
import Reg
import Instruction

37
import BlockId
38
39
import OldCmm hiding (RegSet)
import OldPprCmm()
40
41
42

import Digraph
import Outputable
43
import Platform
44
45
import Unique
import UniqSet
46
import UniqFM
47
48
49
import UniqSupply
import Bag
import State
50
import FastString
51
52
53

import Data.List
import Data.Maybe
54
55
56
import Data.Map                 (Map)
import Data.Set                 (Set)
import qualified Data.Map       as Map
57
58
59
60
61

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

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

emptyRegMap :: UniqFM a
64
65
emptyRegMap = emptyUFM

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

68
69

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

76

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

83
84
        -- | spill this reg to a stack slot
        | SPILL  Reg Int
85

86
87
        -- | reload this reg from a stack slot
        | RELOAD Int Reg
88
89

instance Instruction instr => Instruction (InstrSR instr) where
90
91
92
93
94
        regUsageOfInstr i
         = case i of
                Instr  instr    -> regUsageOfInstr instr
                SPILL  reg _    -> RU [reg] []
                RELOAD _ reg    -> RU [] [reg]
95

96
97
98
99
100
        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)
101

102
103
104
105
        isJumpishInstr i
         = case i of
                Instr instr     -> isJumpishInstr instr
                _               -> False
106

107
108
109
110
        jumpDestsOfInstr i
         = case i of
                Instr instr     -> jumpDestsOfInstr instr
                _               -> []
111

112
113
114
115
        patchJumpInstr i f
         = case i of
                Instr instr     -> Instr (patchJumpInstr instr f)
                _               -> i
116

117
118
        mkSpillInstr            = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
        mkLoadInstr             = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
119

120
121
122
123
        takeDeltaInstr i
         = case i of
                Instr instr     -> takeDeltaInstr instr
                _               -> Nothing
124

125
126
127
128
        isMetaInstr i
         = case i of
                Instr instr     -> isMetaInstr instr
                _               -> False
129

130
131
        mkRegRegMoveInstr platform r1 r2
            = Instr (mkRegRegMoveInstr platform r1 r2)
132

133
134
135
136
137
138
        takeRegRegMoveInstr i
         = case i of
                Instr instr     -> takeRegRegMoveInstr instr
                _               -> Nothing

        mkJumpInstr target      = map Instr (mkJumpInstr target)
139
140
141
142
143



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

146
-- | Liveness information.
147
148
149
150
151
--   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).
152
153

data Liveness
154
155
156
157
        = 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.
158
159
160
161


-- | Stash regs live on entry to each basic block in the info part of the cmm code.
data LiveInfo
162
163
164
165
166
        = LiveInfo
                (Maybe CmmStatics)                      -- cmm info table static stuff
                (Maybe BlockId)                         -- id of the first block
                (Maybe (BlockMap RegSet))               -- argument locals live on entry to this block
                (Map BlockId (Set Int))                 -- stack slots live on entry to this block
167

168
169

-- | A basic block with liveness information.
170
type LiveBasicBlock instr
171
        = GenBasicBlock (LiveInstr instr)
172
173


Ian Lynagh's avatar
Ian Lynagh committed
174
175
instance Outputable instr
      => Outputable (InstrSR instr) where
176

Ian Lynagh's avatar
Ian Lynagh committed
177
178
        ppr (Instr realInstr)
           = ppr realInstr
179

Ian Lynagh's avatar
Ian Lynagh committed
180
        ppr (SPILL reg slot)
181
182
183
184
185
186
187
           = hcat [
                ptext (sLit "\tSPILL"),
                char ' ',
                ppr reg,
                comma,
                ptext (sLit "SLOT") <> parens (int slot)]

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

Ian Lynagh's avatar
Ian Lynagh committed
196
197
instance Outputable instr
      => Outputable (LiveInstr instr) where
198

Ian Lynagh's avatar
Ian Lynagh committed
199
200
        ppr (LiveInstr instr Nothing)
         = ppr instr
201

Ian Lynagh's avatar
Ian Lynagh committed
202
203
        ppr (LiveInstr instr (Just live))
         =  ppr instr
204
205
206
207
208
209
                $$ (nest 8
                        $ vcat
                        [ pprRegs (ptext (sLit "# born:    ")) (liveBorn live)
                        , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
                        , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
                    $+$ space)
210

211
212
213
214
         where  pprRegs :: SDoc -> RegSet -> SDoc
                pprRegs name regs
                 | isEmptyUniqSet regs  = empty
                 | otherwise            = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
215

Ian Lynagh's avatar
Ian Lynagh committed
216
217
218
instance Outputable LiveInfo where
    ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry)
        =  (maybe empty (ppr) mb_static)
219
220
221
        $$ text "# firstId          = " <> ppr firstId
        $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
        $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
222
223


224

225
226
227
-- | map a function across all the basic blocks in this code
--
mapBlockTop
228
        :: (LiveBasicBlock instr -> LiveBasicBlock instr)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
229
        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
230
231

mapBlockTop f cmm
232
        = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
233
234
235
236
237


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

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
242
mapBlockTopM _ cmm@(CmmData{})
243
        = return cmm
244

245
mapBlockTopM f (CmmProc header label sccs)
246
247
 = do   sccs'   <- mapM (mapSCCM f) sccs
        return  $ CmmProc header label sccs'
248
249

mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
250
251
252
mapSCCM f (AcyclicSCC x)
 = do   x'      <- f x
        return  $ AcyclicSCC x'
253

254
mapSCCM f (CyclicSCC xs)
255
256
 = do   xs'     <- mapM f xs
        return  $ CyclicSCC xs'
257

258

259
260
-- map a function across all the basic blocks in this code
mapGenBlockTop
261
        :: (GenBasicBlock             i -> GenBasicBlock            i)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
262
        -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))
263
264

mapGenBlockTop f cmm
265
        = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
266
267
268
269


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

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
274
mapGenBlockTopM _ cmm@(CmmData{})
275
        = return cmm
276

277
mapGenBlockTopM f (CmmProc header label (ListGraph blocks))
278
279
 = do   blocks' <- mapM f blocks
        return  $ CmmProc header label (ListGraph blocks')
280
281


282
-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
283
284
--   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.
285
--
286
287
slurpConflicts
        :: Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
288
        => LiveCmmDecl statics instr
289
        -> (Bag (UniqSet Reg), Bag (Reg, Reg))
290

291
slurpConflicts live
292
        = slurpCmm (emptyBag, emptyBag) live
293

294
295
296
 where  slurpCmm   rs  CmmData{}                = rs
        slurpCmm   rs (CmmProc info _ sccs)
                = foldl' (slurpSCC info) rs sccs
297

298
299
        slurpSCC  info rs (AcyclicSCC b)
                = slurpBlock info rs b
300

301
302
        slurpSCC  info rs (CyclicSCC bs)
                = foldl'  (slurpBlock info) rs bs
303

304
305
306
307
308
        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)
309

310
311
                | otherwise
                = panic "Liveness.slurpConflicts: bad block"
312

313
314
        slurpLIs rsLive (conflicts, moves) []
                = (consBag rsLive conflicts, moves)
315

316
317
        slurpLIs rsLive rs (LiveInstr _ Nothing     : lis)
                = slurpLIs rsLive rs lis
318

319
320
321
322
323
        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)
324

325
326
327
328
329
                -- 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)
330

331
332
333
334
335
336
                -- 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))
337

338
339
                --
                rsConflicts     = unionUniqSets rsLiveNext rsOrphans
340

341
342
343
344
345
346
347
348
          in    case takeRegRegMoveInstr instr of
                 Just rr        -> slurpLIs rsLiveNext
                                        ( consBag rsConflicts conflicts
                                        , consBag rr moves) lis

                 Nothing        -> slurpLIs rsLiveNext
                                        ( consBag rsConflicts conflicts
                                        , moves) lis
349
350


Ian Lynagh's avatar
Ian Lynagh committed
351
-- | For spill\/reloads
352
--
353
354
355
--   SPILL  v1, slot1
--   ...
--   RELOAD slot1, v2
356
--
357
358
--   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.
359
360
--
--
361
362
slurpReloadCoalesce
        :: forall statics instr. Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
363
        => LiveCmmDecl statics instr
364
        -> Bag (Reg, Reg)
365

366
slurpReloadCoalesce live
367
        = slurpCmm emptyBag live
368

369
 where
370
        slurpCmm :: Bag (Reg, Reg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
371
                 -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]
372
                 -> Bag (Reg, Reg)
373
374
375
        slurpCmm cs CmmData{}   = cs
        slurpCmm cs (CmmProc _ _ sccs)
                = slurpComp cs (flattenSCCs sccs)
376

377
378
379
        slurpComp :: Bag (Reg, Reg)
                     -> [LiveBasicBlock instr]
                     -> Bag (Reg, Reg)
380
381
382
        slurpComp  cs blocks
         = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
           in   unionManyBags (cs : moveBags)
383

384
385
        slurpCompM :: [LiveBasicBlock instr]
                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
386
387
388
        slurpCompM blocks
         = do   -- run the analysis once to record the mapping across jumps.
                mapM_   (slurpBlock False) blocks
389

390
391
392
393
394
                -- 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
395

396
397
        slurpBlock :: Bool -> LiveBasicBlock instr
                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
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
        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)

                -- add an edge betwen the this reg and the last one stored into the slot
                | 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 ]
459
460


Simon Peyton Jones's avatar
Simon Peyton Jones committed
461
-- | Strip away liveness information, yielding NatCmmDecl
462
stripLive
Ian Lynagh's avatar
Ian Lynagh committed
463
        :: (Outputable statics, Outputable instr, Instruction instr)
464
        => Platform
Simon Peyton Jones's avatar
Simon Peyton Jones committed
465
466
        -> LiveCmmDecl statics instr
        -> NatCmmDecl statics instr
467

468
stripLive platform live
469
470
        = stripCmm live

Ian Lynagh's avatar
Ian Lynagh committed
471
 where  stripCmm :: (Outputable statics, Outputable instr, Instruction instr)
472
473
                 => LiveCmmDecl statics instr -> NatCmmDecl statics instr
        stripCmm (CmmData sec ds)       = CmmData sec ds
474
475
476
477
478
479
480
481
482
483
        stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs)
         = 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

           in   CmmProc info label
484
                          (ListGraph $ map (stripLiveBlock platform) $ first' : rest')
485

486
487
488
        -- procs used for stg_split_markers don't contain any blocks, and have no first_id.
        stripCmm (CmmProc (LiveInfo info Nothing _ _) label [])
         =      CmmProc info label (ListGraph [])
489

490
491
        -- 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
492
                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
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
500
        => Platform
        -> LiveBasicBlock instr
501
        -> NatBasicBlock instr
502

503
stripLiveBlock platform (BasicBlock i lis)
504
 =      BasicBlock i instrs'
505

506
507
 where  (instrs', _)
                = runState (spillNat [] lis) 0
508

509
510
        spillNat acc []
         =      return (reverse acc)
511

512
513
        spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
         = do   delta   <- get
514
                spillNat (mkSpillInstr platform reg delta slot : acc) instrs
515

516
517
        spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
         = do   delta   <- get
518
                spillNat (mkLoadInstr platform reg delta slot : acc) instrs
519

520
521
522
523
        spillNat acc (LiveInstr (Instr instr) _ : instrs)
         | Just i <- takeDeltaInstr instr
         = do   put i
                spillNat acc instrs
524

525
526
        spillNat acc (LiveInstr (Instr instr) _ : instrs)
         =      spillNat (instr : acc) instrs
527
528


529
530
-- | Erase Delta instructions.

531
532
eraseDeltasLive
        :: Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
533
534
        => LiveCmmDecl statics instr
        -> LiveCmmDecl statics instr
535

536
eraseDeltasLive cmm
537
        = mapBlockTop eraseBlock cmm
538
 where
539
540
541
542
        eraseBlock (BasicBlock id lis)
                = BasicBlock id
                $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
                $ lis
543
544
545


-- | Patch the registers in this code according to this register mapping.
546
547
--   also erase reg -> reg moves when the reg is the same.
--   also erase reg -> reg moves when the destination dies in this instr.
548
patchEraseLive
549
550
        :: Instruction instr
        => (Reg -> Reg)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
551
        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
552
553

patchEraseLive patchF cmm
554
        = patchCmm cmm
555
 where
556
        patchCmm cmm@CmmData{}  = cmm
557

558
559
560
561
562
        patchCmm (CmmProc info label sccs)
         | LiveInfo static id (Just blockMap) mLiveSlots <- info
         = let
                patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
                blockMap'       = mapMap patchRegSet blockMap
563

564
565
                info'           = LiveInfo static id (Just blockMap') mLiveSlots
           in   CmmProc info' label $ map patchSCC sccs
566

567
568
         | otherwise
         = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
569

570
571
        patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)
        patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs)
572

573
574
        patchBlock (BasicBlock id lis)
                = BasicBlock id $ patchInstrs lis
575

576
577
        patchInstrs []          = []
        patchInstrs (li : lis)
578

579
580
581
582
                | LiveInstr i (Just live)       <- li'
                , Just (r1, r2) <- takeRegRegMoveInstr i
                , eatMe r1 r2 live
                = patchInstrs lis
583

584
585
                | otherwise
                = li' : patchInstrs lis
586

587
                where   li'     = patchRegsLiveInstr patchF li
588

589
590
591
        eatMe   r1 r2 live
                -- source and destination regs are the same
                | r1 == r2      = True
592

593
594
595
596
                -- desination reg is never used
                | elementOfUniqSet r2 (liveBorn live)
                , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
                = True
597

598
                | otherwise     = False
599
600
601
602
603


-- | Patch registers in this LiveInstr, including the liveness information.
--
patchRegsLiveInstr
604
605
606
        :: Instruction instr
        => (Reg -> Reg)
        -> LiveInstr instr -> LiveInstr instr
607
608
609

patchRegsLiveInstr patchF li
 = case li of
610
611
        LiveInstr instr Nothing
         -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
612

613
614
615
616
617
618
619
620
        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 })
621
622


623
--------------------------------------------------------------------------------
Simon Peyton Jones's avatar
Simon Peyton Jones committed
624
-- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information
625

626
627
natCmmTopToLive
        :: Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
628
629
        => NatCmmDecl statics instr
        -> LiveCmmDecl statics instr
630

631
natCmmTopToLive (CmmData i d)
632
        = CmmData i d
633

634
natCmmTopToLive (CmmProc info lbl (ListGraph []))
635
        = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl []
636

637
natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _)))
638
639
640
641
642
643
644
 = let  first_id        = blockId first
        sccs            = sccBlocks blocks
        sccsLive        = map (fmap (\(BasicBlock l instrs) ->
                                        BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
                        $ sccs

   in   CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive
645

646

647
648
649
650
sccBlocks
        :: Instruction instr
        => [NatBasicBlock instr]
        -> [SCC (NatBasicBlock instr)]
651
652
653

sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
  where
654
655
        getOutEdges :: Instruction instr => [instr] -> [BlockId]
        getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
656

657
658
        graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
                | block@(BasicBlock id instrs) <- blocks ]
659
660


661
662
663
664
---------------------------------------------------------------------------------
-- Annotate code with register liveness information
--
regLiveness
Ian Lynagh's avatar
Ian Lynagh committed
665
        :: (Outputable instr, Instruction instr)
666
        => LiveCmmDecl statics instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
667
        -> UniqSM (LiveCmmDecl statics instr)
668

669
regLiveness (CmmData i d)
670
        = return $ CmmData i d
671

672
regLiveness (CmmProc info lbl [])
673
        | LiveInfo static mFirst _ _    <- info
674
        = return $ CmmProc
675
676
                        (LiveInfo static mFirst (Just mapEmpty) Map.empty)
                        lbl []
677

678
regLiveness (CmmProc info lbl sccs)
679
        | LiveInfo static mFirst _ liveSlotsOnEntry     <- info
Ian Lynagh's avatar
Ian Lynagh committed
680
        = let   (ann_sccs, block_live)  = computeLiveness sccs
681

682
          in    return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
683
                           lbl ann_sccs
684
685
686


-- -----------------------------------------------------------------------------
687
-- | Check ordering of Blocks
688
689
690
691
692
--   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..
--
693
checkIsReverseDependent
694
695
696
697
        :: 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)

698
699
700
checkIsReverseDependent sccs'
 = go emptyUniqSet sccs'

701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
 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]
724

725
726
727

-- | 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
728
reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
729
730
reverseBlocksInTops top
 = case top of
731
732
733
        CmmData{}                       -> top
        CmmProc info lbl sccs   -> CmmProc info lbl (reverse sccs)

734

735
-- | Computing liveness
736
--
737
738
--  On entry, the SCCs must be in "reverse" order: later blocks may transfer
--  control to earlier ones only, else `panic`.
739
--
740
741
742
--  The SCCs returned are in the *opposite* order, which is exactly what we
--  want for the next pass.
--
743
computeLiveness
Ian Lynagh's avatar
Ian Lynagh committed
744
745
        :: (Outputable instr, Instruction instr)
        => [SCC (LiveBasicBlock instr)]
746
747
748
749
        -> ([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.
750

Ian Lynagh's avatar
Ian Lynagh committed
751
computeLiveness sccs
752
 = case checkIsReverseDependent sccs of
753
754
755
756
        Nothing         -> livenessSCCs emptyBlockMap [] sccs
        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
757
                                        , ppr sccs])
758
759

livenessSCCs
760
761
       :: Instruction instr
       => BlockMap RegSet
762
       -> [SCC (LiveBasicBlock instr)]          -- accum
763
       -> [SCC (LiveBasicBlock instr)]
764
       -> ( [SCC (LiveBasicBlock instr)]
765
          , BlockMap RegSet)
766

767
768
livenessSCCs blockmap done []
        = (done, blockmap)
769
770

livenessSCCs blockmap done (AcyclicSCC block : sccs)
771
772
 = let  (blockmap', block')     = livenessBlock blockmap block
   in   livenessSCCs blockmap' (AcyclicSCC block' : done) sccs
773
774

livenessSCCs blockmap done
775
776
        (CyclicSCC blocks : sccs) =
        livenessSCCs blockmap' (CyclicSCC blocks':done) sccs
777
 where      (blockmap', blocks')
778
779
                = iterateUntilUnchanged linearLiveness equalBlockMaps
                                      blockmap blocks
780
781
782
783
784
785

            iterateUntilUnchanged
                :: (a -> b -> (a,c)) -> (a -> a -> Bool)
                -> a -> b
                -> (a,c)

786
787
788
789
790
791
            iterateUntilUnchanged f eq a b
                = head $
                  concatMap tail $
                  groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
                  iterate (\(a, _) -> f a b) $
                  (a, panic "RegLiveness.livenessSCCs")
792
793


794
795
796
797
            linearLiveness
                :: Instruction instr
                => BlockMap RegSet -> [LiveBasicBlock instr]
                -> (BlockMap RegSet, [LiveBasicBlock instr])
798

799
800
801
802
            linearLiveness = mapAccumL livenessBlock

                -- probably the least efficient way to compare two
                -- BlockMaps for equality.
803
804
805
806
807
            equalBlockMaps a b
                = a' == b'
              where a' = map f $ mapToList a
                    b' = map f $ mapToList b
                    f (key,elt) = (key, uniqSetToList elt)
808
809
810
811
812
813



-- | Annotate a basic block with register liveness information.
--
livenessBlock
814
815
816
817
        :: Instruction instr
        => BlockMap RegSet
        -> LiveBasicBlock instr
        -> (BlockMap RegSet, LiveBasicBlock instr)
818

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
819
livenessBlock blockmap (BasicBlock block_id instrs)
820
 = let
821
822
823
        (regsLiveOnEntry, instrs1)
                = livenessBack emptyUniqSet blockmap [] (reverse instrs)
        blockmap'       = mapInsert block_id regsLiveOnEntry blockmap
824

825
        instrs2         = livenessForward regsLiveOnEntry instrs1
826

827
        output          = BasicBlock block_id instrs2
828

829
   in   ( blockmap', output)
830
831

-- | Calculate liveness going forwards,
832
--   filling in when regs are born
833
834

livenessForward
835
836
837
        :: Instruction instr
        => RegSet                       -- regs live on this instr
        -> [LiveInstr instr] -> [LiveInstr instr]
838

839
livenessForward _           []  = []
840
livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis)
841
842
        | Nothing               <- mLive
        = li : livenessForward rsLiveEntry lis
843

844
845
846
847
848
849
850
        | Just live     <- mLive
        , RU _ written  <- regUsageOfInstr instr
        = let
                -- Regs that are written to but weren't live on entry to this instruction
                --      are recorded as being born here.
                rsBorn          = mkUniqSet
                                $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
851

852
853
854
                rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
                                        `minusUniqSet` (liveDieRead live)
                                        `minusUniqSet` (liveDieWrite live)
855

856
857
        in LiveInstr instr (Just live { liveBorn = rsBorn })
                : livenessForward rsLiveNext lis
858

859
livenessForward _ _             = panic "RegLiveness.livenessForward: no match"
Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
860

861
862

-- | Calculate liveness going backwards,
863
--   filling in when regs die, and what regs are live across each instruction
864
865

livenessBack
866
867
868
869
870
871
        :: Instruction instr
        => RegSet                       -- regs live on this instr
        -> BlockMap RegSet              -- regs live on entry to other BBs
        -> [LiveInstr instr]            -- instructions (accum)
        -> [LiveInstr instr]            -- instructions
        -> (RegSet, [LiveInstr instr])
872

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
873
livenessBack liveregs _        done []  = (liveregs, done)
874
875

livenessBack liveregs blockmap acc (instr : instrs)
876
877
 = let  (liveregs', instr')     = liveness1 liveregs blockmap instr
   in   livenessBack liveregs' blockmap (instr' : acc) instrs
878
879


880
-- don't bother tagging comments or deltas with liveness
881
882
883
884
885
886
liveness1
        :: Instruction instr
        => RegSet
        -> BlockMap RegSet
        -> LiveInstr instr
        -> (RegSet, LiveInstr instr)
887

888
liveness1 liveregs _ (LiveInstr instr _)
889
890
        | isMetaInstr instr
        = (liveregs, LiveInstr instr Nothing)
891

892
liveness1 liveregs blockmap (LiveInstr instr _)
893

894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
        | not_a_branch
        = (liveregs1, LiveInstr instr
                        (Just $ Liveness
                        { liveBorn      = emptyUniqSet
                        , liveDieRead   = mkUniqSet r_dying
                        , liveDieWrite  = mkUniqSet w_dying }))

        | otherwise
        = (liveregs_br, LiveInstr instr
                        (Just $ Liveness
                        { liveBorn      = emptyUniqSet
                        , liveDieRead   = mkUniqSet r_dying_br
                        , liveDieWrite  = mkUniqSet w_dying }))

        where
Simon Marlow's avatar
Simon Marlow committed
909
            !(RU read written) = regUsageOfInstr instr
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929

            -- registers that were written here are dead going backwards.
            -- registers that were read here are live going backwards.
            liveregs1   = (liveregs `delListFromUniqSet` written)
                                    `addListToUniqSet` read

            -- registers that are not live beyond this point, are recorded
            --  as dying here.
            r_dying     = [ reg | reg <- read, reg `notElem` written,
                              not (elementOfUniqSet reg liveregs) ]

            w_dying     = [ reg | reg <- written,
                             not (elementOfUniqSet reg liveregs) ]

            -- union in the live regs from all the jump destinations of this
            -- instruction.
            targets      = jumpDestsOfInstr instr -- where we go from here
            not_a_branch = null targets

            targetLiveRegs target
930
                  = case mapLookup target blockmap of
931
                                Just ra -> ra
932
                                Nothing -> emptyRegMap
933
934
935

            live_from_branch = unionManyUniqSets (map targetLiveRegs targets)

936
            liveregs_br = liveregs1 `unionUniqSets` live_from_branch
937
938
939
940
941
942
943
944

            -- registers that are live only in the branch targets should
            -- be listed as dying here.
            live_branch_only = live_from_branch `minusUniqSet` liveregs
            r_dying_br  = uniqSetToList (mkUniqSet r_dying `unionUniqSets`
                                        live_branch_only)