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