{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------
--
-- The register liveness determinator
--
-- (c) The University of Glasgow 2004-2013
--
-----------------------------------------------------------------------------

module RegAlloc.Liveness (
        RegSet,
        RegMap, emptyRegMap,
        BlockMap, mapEmpty,
        LiveCmmDecl,
        InstrSR   (..),
        LiveInstr (..),
        Liveness (..),
        LiveInfo (..),
        LiveBasicBlock,

        mapBlockTop,    mapBlockTopM,   mapSCCM,
        mapGenBlockTop, mapGenBlockTopM,
        stripLive,
        stripLiveBlock,
        slurpConflicts,
        slurpReloadCoalesce,
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
        reverseBlocksInTops,
        regLiveness,
        natCmmTopToLive
  ) where
import GhcPrelude

import Reg
import Instruction

import BlockId
import CFG
import Hoopl.Collections
import Hoopl.Label
import Cmm hiding (RegSet, emptyRegSet)
import PprCmm()

import Digraph
import DynFlags
import MonadUtils
import Outputable
import Platform
import UniqSet
import UniqFM
import UniqSupply
import Bag
import State

import Data.List
import Data.Maybe
import Data.IntSet              (IntSet)

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

type RegMap a = UniqFM a

emptyRegMap :: UniqFM a
emptyRegMap :: UniqFM a
emptyRegMap = UniqFM a
forall elt. UniqFM elt
emptyUFM

emptyRegSet :: RegSet
emptyRegSet :: RegSet
emptyRegSet = RegSet
forall a. UniqSet a
emptyUniqSet

type BlockMap a = LabelMap a


-- | A top level thing which carries liveness information.
type LiveCmmDecl statics instr
        = GenCmmDecl
                statics
                LiveInfo
                [SCC (LiveBasicBlock instr)]


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

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

        -- | reload this reg from a stack slot
        | RELOAD Int Reg

instance Instruction instr => Instruction (InstrSR instr) where
        regUsageOfInstr :: Platform -> InstrSR instr -> RegUsage
regUsageOfInstr platform :: Platform
platform i :: InstrSR instr
i
         = case InstrSR instr
i of
                Instr  instr :: instr
instr    -> Platform -> instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform instr
instr
                SPILL  reg :: Reg
reg _    -> [Reg] -> [Reg] -> RegUsage
RU [Reg
reg] []
                RELOAD _ reg :: Reg
reg    -> [Reg] -> [Reg] -> RegUsage
RU [] [Reg
reg]

        patchRegsOfInstr :: InstrSR instr -> (Reg -> Reg) -> InstrSR instr
patchRegsOfInstr i :: InstrSR instr
i f :: Reg -> Reg
f
         = case InstrSR instr
i of
                Instr instr :: instr
instr     -> instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (instr -> (Reg -> Reg) -> instr
forall instr. Instruction instr => instr -> (Reg -> Reg) -> instr
patchRegsOfInstr instr
instr Reg -> Reg
f)
                SPILL  reg :: Reg
reg slot :: Int
slot -> Reg -> Int -> InstrSR instr
forall instr. Reg -> Int -> InstrSR instr
SPILL (Reg -> Reg
f Reg
reg) Int
slot
                RELOAD slot :: Int
slot reg :: Reg
reg -> Int -> Reg -> InstrSR instr
forall instr. Int -> Reg -> InstrSR instr
RELOAD Int
slot (Reg -> Reg
f Reg
reg)

        isJumpishInstr :: InstrSR instr -> Bool
isJumpishInstr i :: InstrSR instr
i
         = case InstrSR instr
i of
                Instr instr :: instr
instr     -> instr -> Bool
forall instr. Instruction instr => instr -> Bool
isJumpishInstr instr
instr
                _               -> Bool
False

        jumpDestsOfInstr :: InstrSR instr -> [BlockId]
jumpDestsOfInstr i :: InstrSR instr
i
         = case InstrSR instr
i of
                Instr instr :: instr
instr     -> instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr instr
instr
                _               -> []

        patchJumpInstr :: InstrSR instr -> (BlockId -> BlockId) -> InstrSR instr
patchJumpInstr i :: InstrSR instr
i f :: BlockId -> BlockId
f
         = case InstrSR instr
i of
                Instr instr :: instr
instr     -> instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (instr -> (BlockId -> BlockId) -> instr
forall instr.
Instruction instr =>
instr -> (BlockId -> BlockId) -> instr
patchJumpInstr instr
instr BlockId -> BlockId
f)
                _               -> InstrSR instr
i

        mkSpillInstr :: DynFlags -> Reg -> Int -> Int -> InstrSR instr
mkSpillInstr            = [Char] -> DynFlags -> Reg -> Int -> Int -> InstrSR instr
forall a. HasCallStack => [Char] -> a
error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
        mkLoadInstr :: DynFlags -> Reg -> Int -> Int -> InstrSR instr
mkLoadInstr             = [Char] -> DynFlags -> Reg -> Int -> Int -> InstrSR instr
forall a. HasCallStack => [Char] -> a
error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"

        takeDeltaInstr :: InstrSR instr -> Maybe Int
takeDeltaInstr i :: InstrSR instr
i
         = case InstrSR instr
i of
                Instr instr :: instr
instr     -> instr -> Maybe Int
forall instr. Instruction instr => instr -> Maybe Int
takeDeltaInstr instr
instr
                _               -> Maybe Int
forall a. Maybe a
Nothing

        isMetaInstr :: InstrSR instr -> Bool
isMetaInstr i :: InstrSR instr
i
         = case InstrSR instr
i of
                Instr instr :: instr
instr     -> instr -> Bool
forall instr. Instruction instr => instr -> Bool
isMetaInstr instr
instr
                _               -> Bool
False

        mkRegRegMoveInstr :: Platform -> Reg -> Reg -> InstrSR instr
mkRegRegMoveInstr platform :: Platform
platform r1 :: Reg
r1 r2 :: Reg
r2
            = instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (Platform -> Reg -> Reg -> instr
forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
mkRegRegMoveInstr Platform
platform Reg
r1 Reg
r2)

        takeRegRegMoveInstr :: InstrSR instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr i :: InstrSR instr
i
         = case InstrSR instr
i of
                Instr instr :: instr
instr     -> instr -> Maybe (Reg, Reg)
forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr instr
instr
                _               -> Maybe (Reg, Reg)
forall a. Maybe a
Nothing

        mkJumpInstr :: BlockId -> [InstrSR instr]
mkJumpInstr target :: BlockId
target      = (instr -> InstrSR instr) -> [instr] -> [InstrSR instr]
forall a b. (a -> b) -> [a] -> [b]
map instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (BlockId -> [instr]
forall instr. Instruction instr => BlockId -> [instr]
mkJumpInstr BlockId
target)

        mkStackAllocInstr :: Platform -> Int -> [InstrSR instr]
mkStackAllocInstr platform :: Platform
platform amount :: Int
amount =
             instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (instr -> InstrSR instr) -> [instr] -> [InstrSR instr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Platform -> Int -> [instr]
forall instr. Instruction instr => Platform -> Int -> [instr]
mkStackAllocInstr Platform
platform Int
amount

        mkStackDeallocInstr :: Platform -> Int -> [InstrSR instr]
mkStackDeallocInstr platform :: Platform
platform amount :: Int
amount =
             instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (instr -> InstrSR instr) -> [instr] -> [InstrSR instr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Platform -> Int -> [instr]
forall instr. Instruction instr => Platform -> Int -> [instr]
mkStackDeallocInstr Platform
platform Int
amount


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

-- | Liveness information.
--   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).

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


-- | Stash regs live on entry to each basic block in the info part of the cmm code.
data LiveInfo
        = LiveInfo
                (LabelMap 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
                (BlockMap IntSet)         -- stack slots live on entry to this block


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


instance Outputable instr
      => Outputable (InstrSR instr) where

        ppr :: InstrSR instr -> SDoc
ppr (Instr realInstr :: instr
realInstr)
           = instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr instr
realInstr

        ppr (SPILL reg :: Reg
reg slot :: Int
slot)
           = [SDoc] -> SDoc
hcat [
                [Char] -> SDoc
text "\tSPILL",
                Char -> SDoc
char ' ',
                Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
reg,
                SDoc
comma,
                [Char] -> SDoc
text "SLOT" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Int -> SDoc
int Int
slot)]

        ppr (RELOAD slot :: Int
slot reg :: Reg
reg)
           = [SDoc] -> SDoc
hcat [
                [Char] -> SDoc
text "\tRELOAD",
                Char -> SDoc
char ' ',
                [Char] -> SDoc
text "SLOT" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Int -> SDoc
int Int
slot),
                SDoc
comma,
                Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
reg]

instance Outputable instr
      => Outputable (LiveInstr instr) where

        ppr :: LiveInstr instr -> SDoc
ppr (LiveInstr instr :: InstrSR instr
instr Nothing)
         = InstrSR instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstrSR instr
instr

        ppr (LiveInstr instr :: InstrSR instr
instr (Just live :: Liveness
live))
         =  InstrSR instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstrSR instr
instr
                SDoc -> SDoc -> SDoc
$$ (Int -> SDoc -> SDoc
nest 8
                        (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
                        [ SDoc -> RegSet -> SDoc
pprRegs ([Char] -> SDoc
text "# born:    ") (Liveness -> RegSet
liveBorn Liveness
live)
                        , SDoc -> RegSet -> SDoc
pprRegs ([Char] -> SDoc
text "# r_dying: ") (Liveness -> RegSet
liveDieRead Liveness
live)
                        , SDoc -> RegSet -> SDoc
pprRegs ([Char] -> SDoc
text "# w_dying: ") (Liveness -> RegSet
liveDieWrite Liveness
live) ]
                    SDoc -> SDoc -> SDoc
$+$ SDoc
space)

         where  pprRegs :: SDoc -> RegSet -> SDoc
                pprRegs :: SDoc -> RegSet -> SDoc
pprRegs name :: SDoc
name regs :: RegSet
regs
                 | RegSet -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet RegSet
regs  = SDoc
empty
                 | Bool
otherwise            = SDoc
name SDoc -> SDoc -> SDoc
<>
                     (UniqFM Reg -> ([Reg] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM (RegSet -> UniqFM Reg
forall a. UniqSet a -> UniqFM a
getUniqSet RegSet
regs) ([SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> ([Reg] -> [SDoc]) -> [Reg] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
space ([SDoc] -> [SDoc]) -> ([Reg] -> [SDoc]) -> [Reg] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reg -> SDoc) -> [Reg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr))

instance Outputable LiveInfo where
    ppr :: LiveInfo -> SDoc
ppr (LiveInfo mb_static :: LabelMap CmmStatics
mb_static entryIds :: [BlockId]
entryIds liveVRegsOnEntry :: Maybe (BlockMap RegSet)
liveVRegsOnEntry liveSlotsOnEntry :: BlockMap IntSet
liveSlotsOnEntry)
        =  (LabelMap CmmStatics -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelMap CmmStatics
mb_static)
        SDoc -> SDoc -> SDoc
$$ [Char] -> SDoc
text "# entryIds         = " SDoc -> SDoc -> SDoc
<> [BlockId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BlockId]
entryIds
        SDoc -> SDoc -> SDoc
$$ [Char] -> SDoc
text "# liveVRegsOnEntry = " SDoc -> SDoc -> SDoc
<> Maybe (BlockMap RegSet) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (BlockMap RegSet)
liveVRegsOnEntry
        SDoc -> SDoc -> SDoc
$$ [Char] -> SDoc
text "# liveSlotsOnEntry = " SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text (BlockMap IntSet -> [Char]
forall a. Show a => a -> [Char]
show BlockMap IntSet
liveSlotsOnEntry)



-- | map a function across all the basic blocks in this code
--
mapBlockTop
        :: (LiveBasicBlock instr -> LiveBasicBlock instr)
        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr

mapBlockTop :: (LiveBasicBlock instr -> LiveBasicBlock instr)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
mapBlockTop f :: LiveBasicBlock instr -> LiveBasicBlock instr
f cmm :: LiveCmmDecl statics instr
cmm
        = State () (LiveCmmDecl statics instr)
-> () -> LiveCmmDecl statics instr
forall s a. State s a -> s -> a
evalState ((LiveBasicBlock instr -> State () (LiveBasicBlock instr))
-> LiveCmmDecl statics instr
-> State () (LiveCmmDecl statics instr)
forall (m :: * -> *) instr statics.
Monad m =>
(LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM (\x :: LiveBasicBlock instr
x -> LiveBasicBlock instr -> State () (LiveBasicBlock instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LiveBasicBlock instr -> State () (LiveBasicBlock instr))
-> LiveBasicBlock instr -> State () (LiveBasicBlock instr)
forall a b. (a -> b) -> a -> b
$ LiveBasicBlock instr -> LiveBasicBlock instr
f LiveBasicBlock instr
x) LiveCmmDecl statics instr
cmm) ()


-- | map a function across all the basic blocks in this code (monadic version)
--
mapBlockTopM
        :: Monad m
        => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
        -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)

mapBlockTopM :: (LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM _ cmm :: LiveCmmDecl statics instr
cmm@(CmmData{})
        = LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
return LiveCmmDecl statics instr
cmm

mapBlockTopM f :: LiveBasicBlock instr -> m (LiveBasicBlock instr)
f (CmmProc header :: LiveInfo
header label :: CLabel
label live :: [GlobalReg]
live sccs :: [SCC (LiveBasicBlock instr)]
sccs)
 = do   [SCC (LiveBasicBlock instr)]
sccs'   <- (SCC (LiveBasicBlock instr) -> m (SCC (LiveBasicBlock instr)))
-> [SCC (LiveBasicBlock instr)] -> m [SCC (LiveBasicBlock instr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> SCC (LiveBasicBlock instr) -> m (SCC (LiveBasicBlock instr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SCC a -> m (SCC b)
mapSCCM LiveBasicBlock instr -> m (LiveBasicBlock instr)
f) [SCC (LiveBasicBlock instr)]
sccs
        LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
return  (LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
forall a b. (a -> b) -> a -> b
$ LiveInfo
-> CLabel
-> [GlobalReg]
-> [SCC (LiveBasicBlock instr)]
-> LiveCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LiveInfo
header CLabel
label [GlobalReg]
live [SCC (LiveBasicBlock instr)]
sccs'

mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
mapSCCM :: (a -> m b) -> SCC a -> m (SCC b)
mapSCCM f :: a -> m b
f (AcyclicSCC x :: a
x)
 = do   b
x'      <- a -> m b
f a
x
        SCC b -> m (SCC b)
forall (m :: * -> *) a. Monad m => a -> m a
return  (SCC b -> m (SCC b)) -> SCC b -> m (SCC b)
forall a b. (a -> b) -> a -> b
$ b -> SCC b
forall vertex. vertex -> SCC vertex
AcyclicSCC b
x'

mapSCCM f :: a -> m b
f (CyclicSCC xs :: [a]
xs)
 = do   [b]
xs'     <- (a -> m b) -> [a] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m b
f [a]
xs
        SCC b -> m (SCC b)
forall (m :: * -> *) a. Monad m => a -> m a
return  (SCC b -> m (SCC b)) -> SCC b -> m (SCC b)
forall a b. (a -> b) -> a -> b
$ [b] -> SCC b
forall vertex. [vertex] -> SCC vertex
CyclicSCC [b]
xs'


-- map a function across all the basic blocks in this code
mapGenBlockTop
        :: (GenBasicBlock             i -> GenBasicBlock            i)
        -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))

mapGenBlockTop :: (GenBasicBlock i -> GenBasicBlock i)
-> GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i)
mapGenBlockTop f :: GenBasicBlock i -> GenBasicBlock i
f cmm :: GenCmmDecl d h (ListGraph i)
cmm
        = State () (GenCmmDecl d h (ListGraph i))
-> () -> GenCmmDecl d h (ListGraph i)
forall s a. State s a -> s -> a
evalState ((GenBasicBlock i -> State () (GenBasicBlock i))
-> GenCmmDecl d h (ListGraph i)
-> State () (GenCmmDecl d h (ListGraph i))
forall (m :: * -> *) i d h.
Monad m =>
(GenBasicBlock i -> m (GenBasicBlock i))
-> GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
mapGenBlockTopM (\x :: GenBasicBlock i
x -> GenBasicBlock i -> State () (GenBasicBlock i)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenBasicBlock i -> State () (GenBasicBlock i))
-> GenBasicBlock i -> State () (GenBasicBlock i)
forall a b. (a -> b) -> a -> b
$ GenBasicBlock i -> GenBasicBlock i
f GenBasicBlock i
x) GenCmmDecl d h (ListGraph i)
cmm) ()


-- | map a function across all the basic blocks in this code (monadic version)
mapGenBlockTopM
        :: Monad m
        => (GenBasicBlock            i  -> m (GenBasicBlock            i))
        -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))

mapGenBlockTopM :: (GenBasicBlock i -> m (GenBasicBlock i))
-> GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
mapGenBlockTopM _ cmm :: GenCmmDecl d h (ListGraph i)
cmm@(CmmData{})
        = GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
forall (m :: * -> *) a. Monad m => a -> m a
return GenCmmDecl d h (ListGraph i)
cmm

mapGenBlockTopM f :: GenBasicBlock i -> m (GenBasicBlock i)
f (CmmProc header :: h
header label :: CLabel
label live :: [GlobalReg]
live (ListGraph blocks :: [GenBasicBlock i]
blocks))
 = do   [GenBasicBlock i]
blocks' <- (GenBasicBlock i -> m (GenBasicBlock i))
-> [GenBasicBlock i] -> m [GenBasicBlock i]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenBasicBlock i -> m (GenBasicBlock i)
f [GenBasicBlock i]
blocks
        GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
forall (m :: * -> *) a. Monad m => a -> m a
return  (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))
-> GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
forall a b. (a -> b) -> a -> b
$ h
-> CLabel
-> [GlobalReg]
-> ListGraph i
-> GenCmmDecl d h (ListGraph i)
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc h
header CLabel
label [GlobalReg]
live ([GenBasicBlock i] -> ListGraph i
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph [GenBasicBlock i]
blocks')


-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
--   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.
--
slurpConflicts
        :: Instruction instr
        => LiveCmmDecl statics instr
        -> (Bag (UniqSet Reg), Bag (Reg, Reg))

slurpConflicts :: LiveCmmDecl statics instr -> (Bag RegSet, Bag (Reg, Reg))
slurpConflicts live :: LiveCmmDecl statics instr
live
        = (Bag RegSet, Bag (Reg, Reg))
-> LiveCmmDecl statics instr -> (Bag RegSet, Bag (Reg, Reg))
forall (t :: * -> *) instr d.
(Foldable t, Instruction instr) =>
(Bag RegSet, Bag (Reg, Reg))
-> GenCmmDecl
     d LiveInfo (t (SCC (GenBasicBlock (LiveInstr instr))))
-> (Bag RegSet, Bag (Reg, Reg))
slurpCmm (Bag RegSet
forall a. Bag a
emptyBag, Bag (Reg, Reg)
forall a. Bag a
emptyBag) LiveCmmDecl statics instr
live

 where  slurpCmm :: (Bag RegSet, Bag (Reg, Reg))
-> GenCmmDecl
     d LiveInfo (t (SCC (GenBasicBlock (LiveInstr instr))))
-> (Bag RegSet, Bag (Reg, Reg))
slurpCmm   rs :: (Bag RegSet, Bag (Reg, Reg))
rs  CmmData{}                = (Bag RegSet, Bag (Reg, Reg))
rs
        slurpCmm   rs :: (Bag RegSet, Bag (Reg, Reg))
rs (CmmProc info :: LiveInfo
info _ _ sccs :: t (SCC (GenBasicBlock (LiveInstr instr)))
sccs)
                = ((Bag RegSet, Bag (Reg, Reg))
 -> SCC (GenBasicBlock (LiveInstr instr))
 -> (Bag RegSet, Bag (Reg, Reg)))
-> (Bag RegSet, Bag (Reg, Reg))
-> t (SCC (GenBasicBlock (LiveInstr instr)))
-> (Bag RegSet, Bag (Reg, Reg))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (LiveInfo
-> (Bag RegSet, Bag (Reg, Reg))
-> SCC (GenBasicBlock (LiveInstr instr))
-> (Bag RegSet, Bag (Reg, Reg))
forall instr.
Instruction instr =>
LiveInfo
-> (Bag RegSet, Bag (Reg, Reg))
-> SCC (GenBasicBlock (LiveInstr instr))
-> (Bag RegSet, Bag (Reg, Reg))
slurpSCC LiveInfo
info) (Bag RegSet, Bag (Reg, Reg))
rs t (SCC (GenBasicBlock (LiveInstr instr)))
sccs

        slurpSCC :: LiveInfo
-> (Bag RegSet, Bag (Reg, Reg))
-> SCC (GenBasicBlock (LiveInstr instr))
-> (Bag RegSet, Bag (Reg, Reg))
slurpSCC  info :: LiveInfo
info rs :: (Bag RegSet, Bag (Reg, Reg))
rs (AcyclicSCC b :: GenBasicBlock (LiveInstr instr)
b)
                = LiveInfo
-> (Bag RegSet, Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag RegSet, Bag (Reg, Reg))
forall instr.
Instruction instr =>
LiveInfo
-> (Bag RegSet, Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag RegSet, Bag (Reg, Reg))
slurpBlock LiveInfo
info (Bag RegSet, Bag (Reg, Reg))
rs GenBasicBlock (LiveInstr instr)
b

        slurpSCC  info :: LiveInfo
info rs :: (Bag RegSet, Bag (Reg, Reg))
rs (CyclicSCC bs :: [GenBasicBlock (LiveInstr instr)]
bs)
                = ((Bag RegSet, Bag (Reg, Reg))
 -> GenBasicBlock (LiveInstr instr) -> (Bag RegSet, Bag (Reg, Reg)))
-> (Bag RegSet, Bag (Reg, Reg))
-> [GenBasicBlock (LiveInstr instr)]
-> (Bag RegSet, Bag (Reg, Reg))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'  (LiveInfo
-> (Bag RegSet, Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag RegSet, Bag (Reg, Reg))
forall instr.
Instruction instr =>
LiveInfo
-> (Bag RegSet, Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag RegSet, Bag (Reg, Reg))
slurpBlock LiveInfo
info) (Bag RegSet, Bag (Reg, Reg))
rs [GenBasicBlock (LiveInstr instr)]
bs

        slurpBlock :: LiveInfo
-> (Bag RegSet, Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag RegSet, Bag (Reg, Reg))
slurpBlock info :: LiveInfo
info rs :: (Bag RegSet, Bag (Reg, Reg))
rs (BasicBlock blockId :: BlockId
blockId instrs :: [LiveInstr instr]
instrs)
                | LiveInfo _ _ (Just blockLive :: BlockMap RegSet
blockLive) _ <- LiveInfo
info
                , Just rsLiveEntry :: RegSet
rsLiveEntry                <- KeyOf LabelMap -> BlockMap RegSet -> Maybe RegSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
blockId BlockMap RegSet
blockLive
                , (conflicts :: Bag RegSet
conflicts, moves :: Bag (Reg, Reg)
moves)              <- RegSet
-> (Bag RegSet, Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag RegSet, Bag (Reg, Reg))
forall instr.
Instruction instr =>
RegSet
-> (Bag RegSet, Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag RegSet, Bag (Reg, Reg))
slurpLIs RegSet
rsLiveEntry (Bag RegSet, Bag (Reg, Reg))
rs [LiveInstr instr]
instrs
                = (RegSet -> Bag RegSet -> Bag RegSet
forall a. a -> Bag a -> Bag a
consBag RegSet
rsLiveEntry Bag RegSet
conflicts, Bag (Reg, Reg)
moves)

                | Bool
otherwise
                = [Char] -> (Bag RegSet, Bag (Reg, Reg))
forall a. [Char] -> a
panic "Liveness.slurpConflicts: bad block"

        slurpLIs :: RegSet
-> (Bag RegSet, Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag RegSet, Bag (Reg, Reg))
slurpLIs rsLive :: RegSet
rsLive (conflicts :: Bag RegSet
conflicts, moves :: Bag (Reg, Reg)
moves) []
                = (RegSet -> Bag RegSet -> Bag RegSet
forall a. a -> Bag a -> Bag a
consBag RegSet
rsLive Bag RegSet
conflicts, Bag (Reg, Reg)
moves)

        slurpLIs rsLive :: RegSet
rsLive rs :: (Bag RegSet, Bag (Reg, Reg))
rs (LiveInstr _ Nothing     : lis :: [LiveInstr instr]
lis)
                = RegSet
-> (Bag RegSet, Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag RegSet, Bag (Reg, Reg))
slurpLIs RegSet
rsLive (Bag RegSet, Bag (Reg, Reg))
rs [LiveInstr instr]
lis

        slurpLIs rsLiveEntry :: RegSet
rsLiveEntry (conflicts :: Bag RegSet
conflicts, moves :: Bag (Reg, Reg)
moves) (LiveInstr instr :: InstrSR instr
instr (Just live :: Liveness
live) : lis :: [LiveInstr instr]
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 :: RegSet
rsLiveAcross    = RegSet
rsLiveEntry RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` (Liveness -> RegSet
liveDieRead Liveness
live)

                -- 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 :: RegSet
rsLiveNext      = (RegSet
rsLiveAcross RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` (Liveness -> RegSet
liveBorn     Liveness
live))
                                                RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet`  (Liveness -> RegSet
liveDieWrite Liveness
live)

                -- 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 :: RegSet
rsOrphans       = RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets
                                        (Liveness -> RegSet
liveBorn Liveness
live)
                                        (RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (Liveness -> RegSet
liveDieWrite Liveness
live) (Liveness -> RegSet
liveDieRead Liveness
live))

                --
                rsConflicts :: RegSet
rsConflicts     = RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets RegSet
rsLiveNext RegSet
rsOrphans

          in    case InstrSR instr -> Maybe (Reg, Reg)
forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr InstrSR instr
instr of
                 Just rr :: (Reg, Reg)
rr        -> RegSet
-> (Bag RegSet, Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag RegSet, Bag (Reg, Reg))
slurpLIs RegSet
rsLiveNext
                                        ( RegSet -> Bag RegSet -> Bag RegSet
forall a. a -> Bag a -> Bag a
consBag RegSet
rsConflicts Bag RegSet
conflicts
                                        , (Reg, Reg) -> Bag (Reg, Reg) -> Bag (Reg, Reg)
forall a. a -> Bag a -> Bag a
consBag (Reg, Reg)
rr Bag (Reg, Reg)
moves) [LiveInstr instr]
lis

                 Nothing        -> RegSet
-> (Bag RegSet, Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag RegSet, Bag (Reg, Reg))
slurpLIs RegSet
rsLiveNext
                                        ( RegSet -> Bag RegSet -> Bag RegSet
forall a. a -> Bag a -> Bag a
consBag RegSet
rsConflicts Bag RegSet
conflicts
                                        , Bag (Reg, Reg)
moves) [LiveInstr instr]
lis


-- | For spill\/reloads
--
--   SPILL  v1, slot1
--   ...
--   RELOAD slot1, v2
--
--   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.
--
--
slurpReloadCoalesce
        :: forall statics instr. Instruction instr
        => LiveCmmDecl statics instr
        -> Bag (Reg, Reg)

slurpReloadCoalesce :: LiveCmmDecl statics instr -> Bag (Reg, Reg)
slurpReloadCoalesce live :: LiveCmmDecl statics instr
live
        = Bag (Reg, Reg) -> LiveCmmDecl statics instr -> Bag (Reg, Reg)
forall t t1.
Bag (Reg, Reg)
-> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg)
slurpCmm Bag (Reg, Reg)
forall a. Bag a
emptyBag LiveCmmDecl statics instr
live

 where
        slurpCmm :: Bag (Reg, Reg)
                 -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]
                 -> Bag (Reg, Reg)
        slurpCmm :: Bag (Reg, Reg)
-> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg)
slurpCmm cs :: Bag (Reg, Reg)
cs CmmData{}   = Bag (Reg, Reg)
cs
        slurpCmm cs :: Bag (Reg, Reg)
cs (CmmProc _ _ _ sccs :: [SCC (LiveBasicBlock instr)]
sccs)
                = Bag (Reg, Reg) -> [LiveBasicBlock instr] -> Bag (Reg, Reg)
slurpComp Bag (Reg, Reg)
cs ([SCC (LiveBasicBlock instr)] -> [LiveBasicBlock instr]
forall a. [SCC a] -> [a]
flattenSCCs [SCC (LiveBasicBlock instr)]
sccs)

        slurpComp :: Bag (Reg, Reg)
                     -> [LiveBasicBlock instr]
                     -> Bag (Reg, Reg)
        slurpComp :: Bag (Reg, Reg) -> [LiveBasicBlock instr] -> Bag (Reg, Reg)
slurpComp  cs :: Bag (Reg, Reg)
cs blocks :: [LiveBasicBlock instr]
blocks
         = let  (moveBags :: [Bag (Reg, Reg)]
moveBags, _)   = State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
-> UniqFM [UniqFM Reg] -> ([Bag (Reg, Reg)], UniqFM [UniqFM Reg])
forall s a. State s a -> s -> (a, s)
runState ([LiveBasicBlock instr]
-> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
slurpCompM [LiveBasicBlock instr]
blocks) UniqFM [UniqFM Reg]
forall elt. UniqFM elt
emptyUFM
           in   [Bag (Reg, Reg)] -> Bag (Reg, Reg)
forall a. [Bag a] -> Bag a
unionManyBags (Bag (Reg, Reg)
cs Bag (Reg, Reg) -> [Bag (Reg, Reg)] -> [Bag (Reg, Reg)]
forall a. a -> [a] -> [a]
: [Bag (Reg, Reg)]
moveBags)

        slurpCompM :: [LiveBasicBlock instr]
                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
        slurpCompM :: [LiveBasicBlock instr]
-> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
slurpCompM blocks :: [LiveBasicBlock instr]
blocks
         = do   -- run the analysis once to record the mapping across jumps.
                (LiveBasicBlock instr
 -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)))
-> [LiveBasicBlock instr] -> State (UniqFM [UniqFM Reg]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_   (Bool
-> LiveBasicBlock instr
-> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
slurpBlock Bool
False) [LiveBasicBlock instr]
blocks

                -- 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.
                (LiveBasicBlock instr
 -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)))
-> [LiveBasicBlock instr]
-> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM    (Bool
-> LiveBasicBlock instr
-> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
slurpBlock Bool
True) [LiveBasicBlock instr]
blocks

        slurpBlock :: Bool -> LiveBasicBlock instr
                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
        slurpBlock :: Bool
-> LiveBasicBlock instr
-> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
slurpBlock propagate :: Bool
propagate (BasicBlock blockId :: BlockId
blockId instrs :: [LiveInstr instr]
instrs)
         = do   -- grab the slot map for entry to this block
                UniqFM Reg
slotMap         <- if Bool
propagate
                                        then BlockId -> State (UniqFM [UniqFM Reg]) (UniqFM Reg)
forall key.
Uniquable key =>
key -> State (UniqFM [UniqFM Reg]) (UniqFM Reg)
getSlotMap BlockId
blockId
                                        else UniqFM Reg -> State (UniqFM [UniqFM Reg]) (UniqFM Reg)
forall (m :: * -> *) a. Monad m => a -> m a
return UniqFM Reg
forall elt. UniqFM elt
emptyUFM

                (_, mMoves :: [Maybe (Reg, Reg)]
mMoves)     <- (UniqFM Reg
 -> LiveInstr instr
 -> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg)))
-> UniqFM Reg
-> [LiveInstr instr]
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, [Maybe (Reg, Reg)])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM UniqFM Reg
-> LiveInstr instr
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg))
slurpLI UniqFM Reg
slotMap [LiveInstr instr]
instrs
                Bag (Reg, Reg) -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (Reg, Reg) -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)))
-> Bag (Reg, Reg) -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
forall a b. (a -> b) -> a -> b
$ [(Reg, Reg)] -> Bag (Reg, Reg)
forall a. [a] -> Bag a
listToBag ([(Reg, Reg)] -> Bag (Reg, Reg)) -> [(Reg, Reg)] -> Bag (Reg, Reg)
forall a b. (a -> b) -> a -> b
$ [Maybe (Reg, Reg)] -> [(Reg, Reg)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Reg, Reg)]
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 :: UniqFM Reg
-> LiveInstr instr
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg))
slurpLI slotMap :: UniqFM Reg
slotMap li :: LiveInstr instr
li

                -- remember what reg was stored into the slot
                | LiveInstr (SPILL reg :: Reg
reg slot :: Int
slot) _  <- LiveInstr instr
li
                , UniqFM Reg
slotMap'                      <- UniqFM Reg -> Int -> Reg -> UniqFM Reg
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM Reg
slotMap Int
slot Reg
reg
                = (UniqFM Reg, Maybe (Reg, Reg))
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg))
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqFM Reg
slotMap', Maybe (Reg, Reg)
forall a. Maybe a
Nothing)

                -- add an edge between the this reg and the last one stored into the slot
                | LiveInstr (RELOAD slot :: Int
slot reg :: Reg
reg) _ <- LiveInstr instr
li
                = case UniqFM Reg -> Int -> Maybe Reg
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM Reg
slotMap Int
slot of
                        Just reg2 :: Reg
reg2
                         | Reg
reg Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
/= Reg
reg2  -> (UniqFM Reg, Maybe (Reg, Reg))
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg))
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqFM Reg
slotMap, (Reg, Reg) -> Maybe (Reg, Reg)
forall a. a -> Maybe a
Just (Reg
reg, Reg
reg2))
                         | Bool
otherwise    -> (UniqFM Reg, Maybe (Reg, Reg))
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg))
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqFM Reg
slotMap, Maybe (Reg, Reg)
forall a. Maybe a
Nothing)

                        Nothing         -> (UniqFM Reg, Maybe (Reg, Reg))
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg))
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqFM Reg
slotMap, Maybe (Reg, Reg)
forall a. Maybe a
Nothing)

                -- if we hit a jump, remember the current slotMap
                | LiveInstr (Instr instr :: instr
instr) _     <- LiveInstr instr
li
                , [BlockId]
targets                       <- instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr instr
instr
                , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
targets
                = do    (BlockId -> State (UniqFM [UniqFM Reg]) ())
-> [BlockId] -> State (UniqFM [UniqFM Reg]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_   (UniqFM Reg -> BlockId -> State (UniqFM [UniqFM Reg]) ()
forall key a. Uniquable key => a -> key -> State (UniqFM [a]) ()
accSlotMap UniqFM Reg
slotMap) [BlockId]
targets
                        (UniqFM Reg, Maybe (Reg, Reg))
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg))
forall (m :: * -> *) a. Monad m => a -> m a
return  (UniqFM Reg
slotMap, Maybe (Reg, Reg)
forall a. Maybe a
Nothing)

                | Bool
otherwise
                = (UniqFM Reg, Maybe (Reg, Reg))
-> State (UniqFM [UniqFM Reg]) (UniqFM Reg, Maybe (Reg, Reg))
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqFM Reg
slotMap, Maybe (Reg, Reg)
forall a. Maybe a
Nothing)

        -- record a slotmap for an in edge to this block
        accSlotMap :: a -> key -> State (UniqFM [a]) ()
accSlotMap slotMap :: a
slotMap blockId :: key
blockId
                = (UniqFM [a] -> UniqFM [a]) -> State (UniqFM [a]) ()
forall s. (s -> s) -> State s ()
modify (\s :: UniqFM [a]
s -> ([a] -> [a] -> [a]) -> UniqFM [a] -> key -> [a] -> UniqFM [a]
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> key -> elt -> UniqFM elt
addToUFM_C [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) UniqFM [a]
s key
blockId [a
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 :: key -> State (UniqFM [UniqFM Reg]) (UniqFM Reg)
getSlotMap blockId :: key
blockId
         = do   UniqFM [UniqFM Reg]
map             <- State (UniqFM [UniqFM Reg]) (UniqFM [UniqFM Reg])
forall s. State s s
get
                let slotMaps :: [UniqFM Reg]
slotMaps    = [UniqFM Reg] -> Maybe [UniqFM Reg] -> [UniqFM Reg]
forall a. a -> Maybe a -> a
fromMaybe [] (UniqFM [UniqFM Reg] -> key -> Maybe [UniqFM Reg]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [UniqFM Reg]
map key
blockId)
                UniqFM Reg -> State (UniqFM [UniqFM Reg]) (UniqFM Reg)
forall (m :: * -> *) a. Monad m => a -> m a
return          (UniqFM Reg -> State (UniqFM [UniqFM Reg]) (UniqFM Reg))
-> UniqFM Reg -> State (UniqFM [UniqFM Reg]) (UniqFM Reg)
forall a b. (a -> b) -> a -> b
$ (UniqFM Reg -> UniqFM Reg -> UniqFM Reg)
-> UniqFM Reg -> [UniqFM Reg] -> UniqFM Reg
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UniqFM Reg -> UniqFM Reg -> UniqFM Reg
mergeSlotMaps UniqFM Reg
forall elt. UniqFM elt
emptyUFM [UniqFM Reg]
slotMaps

        mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
        mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
mergeSlotMaps map1 :: UniqFM Reg
map1 map2 :: UniqFM Reg
map2
                = [(Unique, Reg)] -> UniqFM Reg
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
listToUFM
                ([(Unique, Reg)] -> UniqFM Reg) -> [(Unique, Reg)] -> UniqFM Reg
forall a b. (a -> b) -> a -> b
$ [ (Unique
k, Reg
r1)
                  | (k :: Unique
k, r1 :: Reg
r1) <- UniqFM Reg -> [(Unique, Reg)]
forall elt. UniqFM elt -> [(Unique, elt)]
nonDetUFMToList UniqFM Reg
map1
                  -- This is non-deterministic but we do not
                  -- currently support deterministic code-generation.
                  -- See Note [Unique Determinism and code generation]
                  , case UniqFM Reg -> Unique -> Maybe Reg
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM Reg
map2 Unique
k of
                          Nothing -> Bool
False
                          Just r2 :: Reg
r2 -> Reg
r1 Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r2 ]


-- | Strip away liveness information, yielding NatCmmDecl
stripLive
        :: (Outputable statics, Outputable instr, Instruction instr)
        => DynFlags
        -> LiveCmmDecl statics instr
        -> NatCmmDecl statics instr

stripLive :: DynFlags -> LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripLive dflags :: DynFlags
dflags live :: LiveCmmDecl statics instr
live
        = LiveCmmDecl statics instr -> NatCmmDecl statics instr
forall statics instr.
(Outputable statics, Outputable instr, Instruction instr) =>
LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripCmm LiveCmmDecl statics instr
live

 where  stripCmm :: (Outputable statics, Outputable instr, Instruction instr)
                 => LiveCmmDecl statics instr -> NatCmmDecl statics instr
        stripCmm :: LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripCmm (CmmData sec :: Section
sec ds :: statics
ds)       = Section -> statics -> NatCmmDecl statics instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec statics
ds
        stripCmm (CmmProc (LiveInfo info :: LabelMap CmmStatics
info (first_id :: BlockId
first_id:_) _ _) label :: CLabel
label live :: [GlobalReg]
live sccs :: [SCC (LiveBasicBlock instr)]
sccs)
         = let  final_blocks :: [LiveBasicBlock instr]
final_blocks    = [SCC (LiveBasicBlock instr)] -> [LiveBasicBlock instr]
forall a. [SCC a] -> [a]
flattenSCCs [SCC (LiveBasicBlock instr)]
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' :: LiveBasicBlock instr
first':_), rest' :: [LiveBasicBlock instr]
rest')
                                = (LiveBasicBlock instr -> Bool)
-> [LiveBasicBlock instr]
-> ([LiveBasicBlock instr], [LiveBasicBlock instr])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
first_id) (BlockId -> Bool)
-> (LiveBasicBlock instr -> BlockId)
-> LiveBasicBlock instr
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LiveBasicBlock instr -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId) [LiveBasicBlock instr]
final_blocks

           in   LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> NatCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
label [GlobalReg]
live
                          ([GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([GenBasicBlock instr] -> ListGraph instr)
-> [GenBasicBlock instr] -> ListGraph instr
forall a b. (a -> b) -> a -> b
$ (LiveBasicBlock instr -> GenBasicBlock instr)
-> [LiveBasicBlock instr] -> [GenBasicBlock instr]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> LiveBasicBlock instr -> GenBasicBlock instr
forall instr.
Instruction instr =>
DynFlags -> LiveBasicBlock instr -> NatBasicBlock instr
stripLiveBlock DynFlags
dflags) ([LiveBasicBlock instr] -> [GenBasicBlock instr])
-> [LiveBasicBlock instr] -> [GenBasicBlock instr]
forall a b. (a -> b) -> a -> b
$ LiveBasicBlock instr
first' LiveBasicBlock instr
-> [LiveBasicBlock instr] -> [LiveBasicBlock instr]
forall a. a -> [a] -> [a]
: [LiveBasicBlock instr]
rest')

        -- procs used for stg_split_markers don't contain any blocks, and have no first_id.
        stripCmm (CmmProc (LiveInfo info :: LabelMap CmmStatics
info [] _ _) label :: CLabel
label live :: [GlobalReg]
live [])
         =      LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> NatCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
label [GlobalReg]
live ([GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph [])

        -- If the proc has blocks but we don't know what the first one was, then we're dead.
        stripCmm proc :: LiveCmmDecl statics instr
proc
                 = [Char] -> SDoc -> NatCmmDecl statics instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (LiveCmmDecl statics instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr LiveCmmDecl statics instr
proc)

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

stripLiveBlock
        :: Instruction instr
        => DynFlags
        -> LiveBasicBlock instr
        -> NatBasicBlock instr

stripLiveBlock :: DynFlags -> LiveBasicBlock instr -> NatBasicBlock instr
stripLiveBlock dflags :: DynFlags
dflags (BasicBlock i :: BlockId
i lis :: [LiveInstr instr]
lis)
 =      BlockId -> [instr] -> NatBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
i [instr]
instrs'

 where  (instrs' :: [instr]
instrs', _)
                = State Int [instr] -> Int -> ([instr], Int)
forall s a. State s a -> s -> (a, s)
runState ([instr] -> [LiveInstr instr] -> State Int [instr]
spillNat [] [LiveInstr instr]
lis) 0

        spillNat :: [instr] -> [LiveInstr instr] -> State Int [instr]
spillNat acc :: [instr]
acc []
         =      [instr] -> State Int [instr]
forall (m :: * -> *) a. Monad m => a -> m a
return ([instr] -> [instr]
forall a. [a] -> [a]
reverse [instr]
acc)

        spillNat acc :: [instr]
acc (LiveInstr (SPILL reg :: Reg
reg slot :: Int
slot) _ : instrs :: [LiveInstr instr]
instrs)
         = do   Int
delta   <- State Int Int
forall s. State s s
get
                [instr] -> [LiveInstr instr] -> State Int [instr]
spillNat (DynFlags -> Reg -> Int -> Int -> instr
forall instr.
Instruction instr =>
DynFlags -> Reg -> Int -> Int -> instr
mkSpillInstr DynFlags
dflags Reg
reg Int
delta Int
slot instr -> [instr] -> [instr]
forall a. a -> [a] -> [a]
: [instr]
acc) [LiveInstr instr]
instrs

        spillNat acc :: [instr]
acc (LiveInstr (RELOAD slot :: Int
slot reg :: Reg
reg) _ : instrs :: [LiveInstr instr]
instrs)
         = do   Int
delta   <- State Int Int
forall s. State s s
get
                [instr] -> [LiveInstr instr] -> State Int [instr]
spillNat (DynFlags -> Reg -> Int -> Int -> instr
forall instr.
Instruction instr =>
DynFlags -> Reg -> Int -> Int -> instr
mkLoadInstr DynFlags
dflags Reg
reg Int
delta Int
slot instr -> [instr] -> [instr]
forall a. a -> [a] -> [a]
: [instr]
acc) [LiveInstr instr]
instrs

        spillNat acc :: [instr]
acc (LiveInstr (Instr instr :: instr
instr) _ : instrs :: [LiveInstr instr]
instrs)
         | Just i :: Int
i <- instr -> Maybe Int
forall instr. Instruction instr => instr -> Maybe Int
takeDeltaInstr instr
instr
         = do   Int -> State Int ()
forall s. s -> State s ()
put Int
i
                [instr] -> [LiveInstr instr] -> State Int [instr]
spillNat [instr]
acc [LiveInstr instr]
instrs

        spillNat acc :: [instr]
acc (LiveInstr (Instr instr :: instr
instr) _ : instrs :: [LiveInstr instr]
instrs)
         =      [instr] -> [LiveInstr instr] -> State Int [instr]
spillNat (instr
instr instr -> [instr] -> [instr]
forall a. a -> [a] -> [a]
: [instr]
acc) [LiveInstr instr]
instrs


-- | Erase Delta instructions.

eraseDeltasLive
        :: Instruction instr
        => LiveCmmDecl statics instr
        -> LiveCmmDecl statics instr

eraseDeltasLive :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
eraseDeltasLive cmm :: LiveCmmDecl statics instr
cmm
        = (LiveBasicBlock instr -> LiveBasicBlock instr)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
forall instr statics.
(LiveBasicBlock instr -> LiveBasicBlock instr)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
mapBlockTop LiveBasicBlock instr -> LiveBasicBlock instr
forall instr.
Instruction instr =>
GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
eraseBlock LiveCmmDecl statics instr
cmm
 where
        eraseBlock :: GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
eraseBlock (BasicBlock id :: BlockId
id lis :: [LiveInstr instr]
lis)
                = BlockId -> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id
                ([LiveInstr instr] -> GenBasicBlock (LiveInstr instr))
-> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall a b. (a -> b) -> a -> b
$ (LiveInstr instr -> Bool) -> [LiveInstr instr] -> [LiveInstr instr]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(LiveInstr i :: InstrSR instr
i _) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ InstrSR instr -> Maybe Int
forall instr. Instruction instr => instr -> Maybe Int
takeDeltaInstr InstrSR instr
i)
                ([LiveInstr instr] -> [LiveInstr instr])
-> [LiveInstr instr] -> [LiveInstr instr]
forall a b. (a -> b) -> a -> b
$ [LiveInstr instr]
lis


-- | Patch the registers in this code according to this register mapping.
--   also erase reg -> reg moves when the reg is the same.
--   also erase reg -> reg moves when the destination dies in this instr.
patchEraseLive
        :: Instruction instr
        => (Reg -> Reg)
        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr

patchEraseLive :: (Reg -> Reg)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchEraseLive patchF :: Reg -> Reg
patchF cmm :: LiveCmmDecl statics instr
cmm
        = LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchCmm LiveCmmDecl statics instr
cmm
 where
        patchCmm :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchCmm cmm :: LiveCmmDecl statics instr
cmm@CmmData{}  = LiveCmmDecl statics instr
cmm

        patchCmm (CmmProc info :: LiveInfo
info label :: CLabel
label live :: [GlobalReg]
live sccs :: [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
         | LiveInfo static :: LabelMap CmmStatics
static id :: [BlockId]
id (Just blockMap :: BlockMap RegSet
blockMap) mLiveSlots :: BlockMap IntSet
mLiveSlots <- LiveInfo
info
         = let
                patchRegSet :: UniqFM Reg -> RegSet
patchRegSet set :: UniqFM Reg
set = [Reg] -> RegSet
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([Reg] -> RegSet) -> [Reg] -> RegSet
forall a b. (a -> b) -> a -> b
$ (Reg -> Reg) -> [Reg] -> [Reg]
forall a b. (a -> b) -> [a] -> [b]
map Reg -> Reg
patchF ([Reg] -> [Reg]) -> [Reg] -> [Reg]
forall a b. (a -> b) -> a -> b
$ UniqFM Reg -> [Reg]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM Reg
set
                  -- See Note [Unique Determinism and code generation]
                blockMap' :: BlockMap RegSet
blockMap'       = (RegSet -> RegSet) -> BlockMap RegSet -> BlockMap RegSet
forall (map :: * -> *) a b. IsMap map => (a -> b) -> map a -> map b
mapMap (UniqFM Reg -> RegSet
patchRegSet (UniqFM Reg -> RegSet)
-> (RegSet -> UniqFM Reg) -> RegSet -> RegSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegSet -> UniqFM Reg
forall a. UniqSet a -> UniqFM a
getUniqSet) BlockMap RegSet
blockMap

                info' :: LiveInfo
info'           = LabelMap CmmStatics
-> [BlockId]
-> Maybe (BlockMap RegSet)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap CmmStatics
static [BlockId]
id (BlockMap RegSet -> Maybe (BlockMap RegSet)
forall a. a -> Maybe a
Just BlockMap RegSet
blockMap') BlockMap IntSet
mLiveSlots
           in   LiveInfo
-> CLabel
-> [GlobalReg]
-> [SCC (GenBasicBlock (LiveInstr instr))]
-> LiveCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LiveInfo
info' CLabel
label [GlobalReg]
live ([SCC (GenBasicBlock (LiveInstr instr))]
 -> LiveCmmDecl statics instr)
-> [SCC (GenBasicBlock (LiveInstr instr))]
-> LiveCmmDecl statics instr
forall a b. (a -> b) -> a -> b
$ (SCC (GenBasicBlock (LiveInstr instr))
 -> SCC (GenBasicBlock (LiveInstr instr)))
-> [SCC (GenBasicBlock (LiveInstr instr))]
-> [SCC (GenBasicBlock (LiveInstr instr))]
forall a b. (a -> b) -> [a] -> [b]
map SCC (GenBasicBlock (LiveInstr instr))
-> SCC (GenBasicBlock (LiveInstr instr))
patchSCC [SCC (GenBasicBlock (LiveInstr instr))]
sccs

         | Bool
otherwise
         = [Char] -> LiveCmmDecl statics instr
forall a. [Char] -> a
panic "RegAlloc.Liveness.patchEraseLive: no blockMap"

        patchSCC :: SCC (GenBasicBlock (LiveInstr instr))
-> SCC (GenBasicBlock (LiveInstr instr))
patchSCC (AcyclicSCC b :: GenBasicBlock (LiveInstr instr)
b)  = GenBasicBlock (LiveInstr instr)
-> SCC (GenBasicBlock (LiveInstr instr))
forall vertex. vertex -> SCC vertex
AcyclicSCC (GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
patchBlock GenBasicBlock (LiveInstr instr)
b)
        patchSCC (CyclicSCC  bs :: [GenBasicBlock (LiveInstr instr)]
bs) = [GenBasicBlock (LiveInstr instr)]
-> SCC (GenBasicBlock (LiveInstr instr))
forall vertex. [vertex] -> SCC vertex
CyclicSCC  ((GenBasicBlock (LiveInstr instr)
 -> GenBasicBlock (LiveInstr instr))
-> [GenBasicBlock (LiveInstr instr)]
-> [GenBasicBlock (LiveInstr instr)]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
patchBlock [GenBasicBlock (LiveInstr instr)]
bs)

        patchBlock :: GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
patchBlock (BasicBlock id :: BlockId
id lis :: [LiveInstr instr]
lis)
                = BlockId -> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id ([LiveInstr instr] -> GenBasicBlock (LiveInstr instr))
-> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall a b. (a -> b) -> a -> b
$ [LiveInstr instr] -> [LiveInstr instr]
patchInstrs [LiveInstr instr]
lis

        patchInstrs :: [LiveInstr instr] -> [LiveInstr instr]
patchInstrs []          = []
        patchInstrs (li :: LiveInstr instr
li : lis :: [LiveInstr instr]
lis)

                | LiveInstr i :: InstrSR instr
i (Just live :: Liveness
live)       <- LiveInstr instr
li'
                , Just (r1 :: Reg
r1, r2 :: Reg
r2) <- InstrSR instr -> Maybe (Reg, Reg)
forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr InstrSR instr
i
                , Reg -> Reg -> Liveness -> Bool
eatMe Reg
r1 Reg
r2 Liveness
live
                = [LiveInstr instr] -> [LiveInstr instr]
patchInstrs [LiveInstr instr]
lis

                | Bool
otherwise
                = LiveInstr instr
li' LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr] -> [LiveInstr instr]
patchInstrs [LiveInstr instr]
lis

                where   li' :: LiveInstr instr
li'     = (Reg -> Reg) -> LiveInstr instr -> LiveInstr instr
forall instr.
Instruction instr =>
(Reg -> Reg) -> LiveInstr instr -> LiveInstr instr
patchRegsLiveInstr Reg -> Reg
patchF LiveInstr instr
li

        eatMe :: Reg -> Reg -> Liveness -> Bool
eatMe   r1 :: Reg
r1 r2 :: Reg
r2 live :: Liveness
live
                -- source and destination regs are the same
                | Reg
r1 Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r2      = Bool
True

                -- destination reg is never used
                | Reg -> RegSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
r2 (Liveness -> RegSet
liveBorn Liveness
live)
                , Reg -> RegSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
r2 (Liveness -> RegSet
liveDieRead Liveness
live) Bool -> Bool -> Bool
|| Reg -> RegSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
r2 (Liveness -> RegSet
liveDieWrite Liveness
live)
                = Bool
True

                | Bool
otherwise     = Bool
False


-- | Patch registers in this LiveInstr, including the liveness information.
--
patchRegsLiveInstr
        :: Instruction instr
        => (Reg -> Reg)
        -> LiveInstr instr -> LiveInstr instr

patchRegsLiveInstr :: (Reg -> Reg) -> LiveInstr instr -> LiveInstr instr
patchRegsLiveInstr patchF :: Reg -> Reg
patchF li :: LiveInstr instr
li
 = case LiveInstr instr
li of
        LiveInstr instr :: InstrSR instr
instr Nothing
         -> InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (InstrSR instr -> (Reg -> Reg) -> InstrSR instr
forall instr. Instruction instr => instr -> (Reg -> Reg) -> instr
patchRegsOfInstr InstrSR instr
instr Reg -> Reg
patchF) Maybe Liveness
forall a. Maybe a
Nothing

        LiveInstr instr :: InstrSR instr
instr (Just live :: Liveness
live)
         -> InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr
                (InstrSR instr -> (Reg -> Reg) -> InstrSR instr
forall instr. Instruction instr => instr -> (Reg -> Reg) -> instr
patchRegsOfInstr InstrSR instr
instr Reg -> Reg
patchF)
                (Liveness -> Maybe Liveness
forall a. a -> Maybe a
Just Liveness
live
                        { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
                          liveBorn :: RegSet
liveBorn      = (Reg -> Reg) -> RegSet -> RegSet
forall b a. Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
mapUniqSet Reg -> Reg
patchF (RegSet -> RegSet) -> RegSet -> RegSet
forall a b. (a -> b) -> a -> b
$ Liveness -> RegSet
liveBorn Liveness
live
                        , liveDieRead :: RegSet
liveDieRead   = (Reg -> Reg) -> RegSet -> RegSet
forall b a. Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
mapUniqSet Reg -> Reg
patchF (RegSet -> RegSet) -> RegSet -> RegSet
forall a b. (a -> b) -> a -> b
$ Liveness -> RegSet
liveDieRead Liveness
live
                        , liveDieWrite :: RegSet
liveDieWrite  = (Reg -> Reg) -> RegSet -> RegSet
forall b a. Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
mapUniqSet Reg -> Reg
patchF (RegSet -> RegSet) -> RegSet -> RegSet
forall a b. (a -> b) -> a -> b
$ Liveness -> RegSet
liveDieWrite Liveness
live })
                          -- See Note [Unique Determinism and code generation]


--------------------------------------------------------------------------------
-- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information

natCmmTopToLive
        :: (Instruction instr, Outputable instr)
        => Maybe CFG -> NatCmmDecl statics instr
        -> LiveCmmDecl statics instr

natCmmTopToLive :: Maybe CFG -> NatCmmDecl statics instr -> LiveCmmDecl statics instr
natCmmTopToLive _ (CmmData i :: Section
i d :: statics
d)
        = Section -> statics -> LiveCmmDecl statics instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
i statics
d

natCmmTopToLive _ (CmmProc info :: LabelMap CmmStatics
info lbl :: CLabel
lbl live :: [GlobalReg]
live (ListGraph []))
        = LiveInfo
-> CLabel
-> [GlobalReg]
-> [SCC (LiveBasicBlock instr)]
-> LiveCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc (LabelMap CmmStatics
-> [BlockId]
-> Maybe (BlockMap RegSet)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap CmmStatics
info [] Maybe (BlockMap RegSet)
forall a. Maybe a
Nothing BlockMap IntSet
forall (map :: * -> *) a. IsMap map => map a
mapEmpty) CLabel
lbl [GlobalReg]
live []

natCmmTopToLive mCfg :: Maybe CFG
mCfg proc :: NatCmmDecl statics instr
proc@(CmmProc info :: LabelMap CmmStatics
info lbl :: CLabel
lbl live :: [GlobalReg]
live (ListGraph blocks :: [GenBasicBlock instr]
blocks@(first :: GenBasicBlock instr
first : _)))
        = LiveInfo
-> CLabel
-> [GlobalReg]
-> [SCC (LiveBasicBlock instr)]
-> LiveCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc (LabelMap CmmStatics
-> [BlockId]
-> Maybe (BlockMap RegSet)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap CmmStatics
info' (BlockId
first_id BlockId -> [BlockId] -> [BlockId]
forall a. a -> [a] -> [a]
: [BlockId]
entry_ids) Maybe (BlockMap RegSet)
forall a. Maybe a
Nothing BlockMap IntSet
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
                CLabel
lbl [GlobalReg]
live [SCC (LiveBasicBlock instr)]
sccsLive
   where
        first_id :: BlockId
first_id        = GenBasicBlock instr -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId GenBasicBlock instr
first
        all_entry_ids :: [BlockId]
all_entry_ids   = NatCmmDecl statics instr -> [BlockId]
forall a i b. GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]
entryBlocks NatCmmDecl statics instr
proc
        sccs :: [SCC (GenBasicBlock instr)]
sccs            = [GenBasicBlock instr]
-> [BlockId] -> Maybe CFG -> [SCC (GenBasicBlock instr)]
forall instr.
Instruction instr =>
[NatBasicBlock instr]
-> [BlockId] -> Maybe CFG -> [SCC (NatBasicBlock instr)]
sccBlocks [GenBasicBlock instr]
blocks [BlockId]
all_entry_ids Maybe CFG
mCfg
        sccsLive :: [SCC (LiveBasicBlock instr)]
sccsLive        = (SCC (GenBasicBlock instr) -> SCC (LiveBasicBlock instr))
-> [SCC (GenBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a b. (a -> b) -> [a] -> [b]
map ((GenBasicBlock instr -> LiveBasicBlock instr)
-> SCC (GenBasicBlock instr) -> SCC (LiveBasicBlock instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(BasicBlock l :: BlockId
l instrs :: [instr]
instrs) ->
                                       BlockId -> [LiveInstr instr] -> LiveBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
l ((instr -> LiveInstr instr) -> [instr] -> [LiveInstr instr]
forall a b. (a -> b) -> [a] -> [b]
map (\i :: instr
i -> InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr instr
i) Maybe Liveness
forall a. Maybe a
Nothing) [instr]
instrs)))
                        ([SCC (GenBasicBlock instr)] -> [SCC (LiveBasicBlock instr)])
-> [SCC (GenBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a b. (a -> b) -> a -> b
$ [SCC (GenBasicBlock instr)]
sccs

        entry_ids :: [BlockId]
entry_ids       = (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (BlockId -> Bool
reachable_node) ([BlockId] -> [BlockId])
-> ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockId
first_id) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ [BlockId]
all_entry_ids
        info' :: LabelMap CmmStatics
info'           = (KeyOf LabelMap -> CmmStatics -> Bool)
-> LabelMap CmmStatics -> LabelMap CmmStatics
forall (map :: * -> *) a.
IsMap map =>
(KeyOf map -> a -> Bool) -> map a -> map a
mapFilterWithKey (\node :: KeyOf LabelMap
node _ -> BlockId -> Bool
reachable_node KeyOf LabelMap
BlockId
node) LabelMap CmmStatics
info
        reachable_node :: BlockId -> Bool
reachable_node
          | Just cfg :: CFG
cfg <- Maybe CFG
mCfg
          = CFG -> BlockId -> Bool
hasNode CFG
cfg
          | Bool
otherwise
          = Bool -> BlockId -> Bool
forall a b. a -> b -> a
const Bool
True

--
-- 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)
--
sccBlocks
        :: forall instr . Instruction instr
        => [NatBasicBlock instr]
        -> [BlockId]
        -> Maybe CFG
        -> [SCC (NatBasicBlock instr)]

sccBlocks :: [NatBasicBlock instr]
-> [BlockId] -> Maybe CFG -> [SCC (NatBasicBlock instr)]
sccBlocks blocks :: [NatBasicBlock instr]
blocks entries :: [BlockId]
entries mcfg :: Maybe CFG
mcfg = (SCC (Node BlockId (NatBasicBlock instr))
 -> SCC (NatBasicBlock instr))
-> [SCC (Node BlockId (NatBasicBlock instr))]
-> [SCC (NatBasicBlock instr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Node BlockId (NatBasicBlock instr) -> NatBasicBlock instr)
-> SCC (Node BlockId (NatBasicBlock instr))
-> SCC (NatBasicBlock instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node BlockId (NatBasicBlock instr) -> NatBasicBlock instr
forall key payload. Node key payload -> payload
node_payload) [SCC (Node BlockId (NatBasicBlock instr))]
sccs
  where
        nodes :: [ Node BlockId (NatBasicBlock instr) ]
        nodes :: [Node BlockId (NatBasicBlock instr)]
nodes = [ NatBasicBlock instr
-> BlockId -> [BlockId] -> Node BlockId (NatBasicBlock instr)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode NatBasicBlock instr
block BlockId
id ([instr] -> [BlockId]
Instruction instr => [instr] -> [BlockId]
getOutEdges [instr]
instrs)
                | block :: NatBasicBlock instr
block@(BasicBlock id :: BlockId
id instrs :: [instr]
instrs) <- [NatBasicBlock instr]
blocks ]

        g1 :: Graph (Node BlockId (NatBasicBlock instr))
g1 = [Node BlockId (NatBasicBlock instr)]
-> Graph (Node BlockId (NatBasicBlock instr))
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [Node BlockId (NatBasicBlock instr)]
nodes

        reachable :: LabelSet
        reachable :: LabelSet
reachable
            | Just cfg :: CFG
cfg <- Maybe CFG
mcfg
            -- Our CFG only contains reachable nodes by construction.
            = CFG -> LabelSet
getCfgNodes CFG
cfg
            | Bool
otherwise
            = [ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList ([ElemOf LabelSet] -> LabelSet) -> [ElemOf LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$ [ Node BlockId (NatBasicBlock instr) -> BlockId
forall key payload. Node key payload -> key
node_key Node BlockId (NatBasicBlock instr)
node | Node BlockId (NatBasicBlock instr)
node <- Graph (Node BlockId (NatBasicBlock instr))
-> [Node BlockId (NatBasicBlock instr)]
-> [Node BlockId (NatBasicBlock instr)]
forall node. Graph node -> [node] -> [node]
reachablesG Graph (Node BlockId (NatBasicBlock instr))
g1 [Node BlockId (NatBasicBlock instr)]
roots ]

        g2 :: Graph (Node BlockId (NatBasicBlock instr))
g2 = [Node BlockId (NatBasicBlock instr)]
-> Graph (Node BlockId (NatBasicBlock instr))
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [ Node BlockId (NatBasicBlock instr)
node | Node BlockId (NatBasicBlock instr)
node <- [Node BlockId (NatBasicBlock instr)]
nodes
                                               , Node BlockId (NatBasicBlock instr) -> BlockId
forall key payload. Node key payload -> key
node_key Node BlockId (NatBasicBlock instr)
node
                                                  ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` LabelSet
reachable ]

        sccs :: [SCC (Node BlockId (NatBasicBlock instr))]
sccs = Graph (Node BlockId (NatBasicBlock instr))
-> [SCC (Node BlockId (NatBasicBlock instr))]
forall node. Graph node -> [SCC node]
stronglyConnCompG Graph (Node BlockId (NatBasicBlock instr))
g2

        getOutEdges :: Instruction instr => [instr] -> [BlockId]
        getOutEdges :: [instr] -> [BlockId]
getOutEdges instrs :: [instr]
instrs = [[BlockId]] -> [BlockId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[BlockId]] -> [BlockId]) -> [[BlockId]] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ (instr -> [BlockId]) -> [instr] -> [[BlockId]]
forall a b. (a -> b) -> [a] -> [b]
map instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr [instr]
instrs

        -- 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 :: [Node BlockId (NatBasicBlock instr)]
roots = [NatBasicBlock instr
-> BlockId -> [BlockId] -> Node BlockId (NatBasicBlock instr)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ([Char] -> NatBasicBlock instr
forall a. [Char] -> a
panic "sccBlocks") BlockId
b ([Char] -> [BlockId]
forall a. [Char] -> a
panic "sccBlocks")
                | BlockId
b <- [BlockId]
entries ]

--------------------------------------------------------------------------------
-- Annotate code with register liveness information
--
regLiveness
        :: (Outputable instr, Instruction instr)
        => Platform
        -> LiveCmmDecl statics instr
        -> UniqSM (LiveCmmDecl statics instr)

regLiveness :: Platform
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
regLiveness _ (CmmData i :: Section
i d :: statics
d)
        = LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr))
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
forall a b. (a -> b) -> a -> b
$ Section -> statics -> LiveCmmDecl statics instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
i statics
d

regLiveness _ (CmmProc info :: LiveInfo
info lbl :: CLabel
lbl live :: [GlobalReg]
live [])
        | LiveInfo static :: LabelMap CmmStatics
static mFirst :: [BlockId]
mFirst _ _    <- LiveInfo
info
        = LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr))
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
forall a b. (a -> b) -> a -> b
$ LiveInfo
-> CLabel
-> [GlobalReg]
-> [SCC (LiveBasicBlock instr)]
-> LiveCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc
                        (LabelMap CmmStatics
-> [BlockId]
-> Maybe (BlockMap RegSet)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap CmmStatics
static [BlockId]
mFirst (BlockMap RegSet -> Maybe (BlockMap RegSet)
forall a. a -> Maybe a
Just BlockMap RegSet
forall (map :: * -> *) a. IsMap map => map a
mapEmpty) BlockMap IntSet
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
                        CLabel
lbl [GlobalReg]
live []

regLiveness platform :: Platform
platform (CmmProc info :: LiveInfo
info lbl :: CLabel
lbl live :: [GlobalReg]
live sccs :: [SCC (LiveBasicBlock instr)]
sccs)
        | LiveInfo static :: LabelMap CmmStatics
static mFirst :: [BlockId]
mFirst _ liveSlotsOnEntry :: BlockMap IntSet
liveSlotsOnEntry     <- LiveInfo
info
        = let   (ann_sccs :: [SCC (LiveBasicBlock instr)]
ann_sccs, block_live :: BlockMap RegSet
block_live)  = Platform
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
forall instr.
(Outputable instr, Instruction instr) =>
Platform
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
computeLiveness Platform
platform [SCC (LiveBasicBlock instr)]
sccs

          in    LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr))
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
forall a b. (a -> b) -> a -> b
$ LiveInfo
-> CLabel
-> [GlobalReg]
-> [SCC (LiveBasicBlock instr)]
-> LiveCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc (LabelMap CmmStatics
-> [BlockId]
-> Maybe (BlockMap RegSet)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap CmmStatics
static [BlockId]
mFirst (BlockMap RegSet -> Maybe (BlockMap RegSet)
forall a. a -> Maybe a
Just BlockMap RegSet
block_live) BlockMap IntSet
liveSlotsOnEntry)
                           CLabel
lbl [GlobalReg]
live [SCC (LiveBasicBlock instr)]
ann_sccs


-- -----------------------------------------------------------------------------
-- | Check ordering of Blocks
--   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..
--
checkIsReverseDependent
        :: 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)

checkIsReverseDependent :: [SCC (LiveBasicBlock instr)] -> Maybe BlockId
checkIsReverseDependent sccs' :: [SCC (LiveBasicBlock instr)]
sccs'
 = UniqSet BlockId -> [SCC (LiveBasicBlock instr)] -> Maybe BlockId
forall instr.
Instruction instr =>
UniqSet BlockId
-> [SCC (GenBasicBlock (LiveInstr instr))] -> Maybe BlockId
go UniqSet BlockId
forall a. UniqSet a
emptyUniqSet [SCC (LiveBasicBlock instr)]
sccs'

 where  go :: UniqSet BlockId
-> [SCC (GenBasicBlock (LiveInstr instr))] -> Maybe BlockId
go _ []
         = Maybe BlockId
forall a. Maybe a
Nothing

        go blocksSeen :: UniqSet BlockId
blocksSeen (AcyclicSCC block :: GenBasicBlock (LiveInstr instr)
block : sccs :: [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
         = let  dests :: UniqSet BlockId
dests           = GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
forall instr.
Instruction instr =>
GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
slurpJumpDestsOfBlock GenBasicBlock (LiveInstr instr)
block
                blocksSeen' :: UniqSet BlockId
blocksSeen'     = UniqSet BlockId -> UniqSet BlockId -> UniqSet BlockId
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet BlockId
blocksSeen (UniqSet BlockId -> UniqSet BlockId)
-> UniqSet BlockId -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ [BlockId] -> UniqSet BlockId
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [GenBasicBlock (LiveInstr instr) -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId GenBasicBlock (LiveInstr instr)
block]
                badDests :: UniqSet BlockId
badDests        = UniqSet BlockId
dests UniqSet BlockId -> UniqSet BlockId -> UniqSet BlockId
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet BlockId
blocksSeen'
           in   case UniqSet BlockId -> [BlockId]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet BlockId
badDests of
                 -- See Note [Unique Determinism and code generation]
                 []             -> UniqSet BlockId
-> [SCC (GenBasicBlock (LiveInstr instr))] -> Maybe BlockId
go UniqSet BlockId
blocksSeen' [SCC (GenBasicBlock (LiveInstr instr))]
sccs
                 bad :: BlockId
bad : _        -> BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
bad

        go blocksSeen :: UniqSet BlockId
blocksSeen (CyclicSCC blocks :: [GenBasicBlock (LiveInstr instr)]
blocks : sccs :: [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
         = let  dests :: UniqSet BlockId
dests           = [UniqSet BlockId] -> UniqSet BlockId
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets ([UniqSet BlockId] -> UniqSet BlockId)
-> [UniqSet BlockId] -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock (LiveInstr instr) -> UniqSet BlockId)
-> [GenBasicBlock (LiveInstr instr)] -> [UniqSet BlockId]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
forall instr.
Instruction instr =>
GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
slurpJumpDestsOfBlock [GenBasicBlock (LiveInstr instr)]
blocks
                blocksSeen' :: UniqSet BlockId
blocksSeen'     = UniqSet BlockId -> UniqSet BlockId -> UniqSet BlockId
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet BlockId
blocksSeen (UniqSet BlockId -> UniqSet BlockId)
-> UniqSet BlockId -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ [BlockId] -> UniqSet BlockId
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([BlockId] -> UniqSet BlockId) -> [BlockId] -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock (LiveInstr instr) -> BlockId)
-> [GenBasicBlock (LiveInstr instr)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock (LiveInstr instr) -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId [GenBasicBlock (LiveInstr instr)]
blocks
                badDests :: UniqSet BlockId
badDests        = UniqSet BlockId
dests UniqSet BlockId -> UniqSet BlockId -> UniqSet BlockId
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet BlockId
blocksSeen'
           in   case UniqSet BlockId -> [BlockId]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet BlockId
badDests of
                 -- See Note [Unique Determinism and code generation]
                 []             -> UniqSet BlockId
-> [SCC (GenBasicBlock (LiveInstr instr))] -> Maybe BlockId
go UniqSet BlockId
blocksSeen' [SCC (GenBasicBlock (LiveInstr instr))]
sccs
                 bad :: BlockId
bad : _        -> BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
bad

        slurpJumpDestsOfBlock :: GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
slurpJumpDestsOfBlock (BasicBlock _ instrs :: [LiveInstr instr]
instrs)
                = [UniqSet BlockId] -> UniqSet BlockId
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
                ([UniqSet BlockId] -> UniqSet BlockId)
-> [UniqSet BlockId] -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ (InstrSR instr -> UniqSet BlockId)
-> [InstrSR instr] -> [UniqSet BlockId]
forall a b. (a -> b) -> [a] -> [b]
map ([BlockId] -> UniqSet BlockId
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([BlockId] -> UniqSet BlockId)
-> (InstrSR instr -> [BlockId]) -> InstrSR instr -> UniqSet BlockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstrSR instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr)
                        [ InstrSR instr
i | LiveInstr i :: InstrSR instr
i _ <- [LiveInstr instr]
instrs]


-- | 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.
reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
reverseBlocksInTops top :: LiveCmmDecl statics instr
top
 = case LiveCmmDecl statics instr
top of
        CmmData{}                       -> LiveCmmDecl statics instr
top
        CmmProc info :: LiveInfo
info lbl :: CLabel
lbl live :: [GlobalReg]
live sccs :: [SCC (LiveBasicBlock instr)]
sccs      -> LiveInfo
-> CLabel
-> [GlobalReg]
-> [SCC (LiveBasicBlock instr)]
-> LiveCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LiveInfo
info CLabel
lbl [GlobalReg]
live ([SCC (LiveBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a. [a] -> [a]
reverse [SCC (LiveBasicBlock instr)]
sccs)


-- | Computing liveness
--
--  On entry, the SCCs must be in "reverse" order: later blocks may transfer
--  control to earlier ones only, else `panic`.
--
--  The SCCs returned are in the *opposite* order, which is exactly what we
--  want for the next pass.
--
computeLiveness
        :: (Outputable instr, Instruction instr)
        => Platform
        -> [SCC (LiveBasicBlock instr)]
        -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
                                                -- which are "dead after this instruction".
               BlockMap RegSet)                 -- blocks annotated with set of live registers
                                                -- on entry to the block.

computeLiveness :: Platform
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
computeLiveness platform :: Platform
platform sccs :: [SCC (LiveBasicBlock instr)]
sccs
 = case [SCC (LiveBasicBlock instr)] -> Maybe BlockId
forall instr.
Instruction instr =>
[SCC (LiveBasicBlock instr)] -> Maybe BlockId
checkIsReverseDependent [SCC (LiveBasicBlock instr)]
sccs of
        Nothing         -> Platform
-> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
forall instr.
Instruction instr =>
Platform
-> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
livenessSCCs Platform
platform BlockMap RegSet
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [] [SCC (LiveBasicBlock instr)]
sccs
        Just bad :: BlockId
bad        -> [Char] -> SDoc -> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic "RegAlloc.Liveness.computeLiveness"
                                ([SDoc] -> SDoc
vcat   [ [Char] -> SDoc
text "SCCs aren't in reverse dependent order"
                                        , [Char] -> SDoc
text "bad blockId" SDoc -> SDoc -> SDoc
<+> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
bad
                                        , [SCC (LiveBasicBlock instr)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SCC (LiveBasicBlock instr)]
sccs])

livenessSCCs
       :: Instruction instr
       => Platform
       -> BlockMap RegSet
       -> [SCC (LiveBasicBlock instr)]          -- accum
       -> [SCC (LiveBasicBlock instr)]
       -> ( [SCC (LiveBasicBlock instr)]
          , BlockMap RegSet)

livenessSCCs :: Platform
-> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
livenessSCCs _ blockmap :: BlockMap RegSet
blockmap done :: [SCC (LiveBasicBlock instr)]
done []
        = ([SCC (LiveBasicBlock instr)]
done, BlockMap RegSet
blockmap)

livenessSCCs platform :: Platform
platform blockmap :: BlockMap RegSet
blockmap done :: [SCC (LiveBasicBlock instr)]
done (AcyclicSCC block :: LiveBasicBlock instr
block : sccs :: [SCC (LiveBasicBlock instr)]
sccs)
 = let  (blockmap' :: BlockMap RegSet
blockmap', block' :: LiveBasicBlock instr
block')     = Platform
-> BlockMap RegSet
-> LiveBasicBlock instr
-> (BlockMap RegSet, LiveBasicBlock instr)
forall instr.
Instruction instr =>
Platform
-> BlockMap RegSet
-> LiveBasicBlock instr
-> (BlockMap RegSet, LiveBasicBlock instr)
livenessBlock Platform
platform BlockMap RegSet
blockmap LiveBasicBlock instr
block
   in   Platform
-> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
forall instr.
Instruction instr =>
Platform
-> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
livenessSCCs Platform
platform BlockMap RegSet
blockmap' (LiveBasicBlock instr -> SCC (LiveBasicBlock instr)
forall vertex. vertex -> SCC vertex
AcyclicSCC LiveBasicBlock instr
block' SCC (LiveBasicBlock instr)
-> [SCC (LiveBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a. a -> [a] -> [a]
: [SCC (LiveBasicBlock instr)]
done) [SCC (LiveBasicBlock instr)]
sccs

livenessSCCs platform :: Platform
platform blockmap :: BlockMap RegSet
blockmap done :: [SCC (LiveBasicBlock instr)]
done
        (CyclicSCC blocks :: [LiveBasicBlock instr]
blocks : sccs :: [SCC (LiveBasicBlock instr)]
sccs) =
        Platform
-> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
forall instr.
Instruction instr =>
Platform
-> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap RegSet)
livenessSCCs Platform
platform BlockMap RegSet
blockmap' ([LiveBasicBlock instr] -> SCC (LiveBasicBlock instr)
forall vertex. [vertex] -> SCC vertex
CyclicSCC [LiveBasicBlock instr]
blocks'SCC (LiveBasicBlock instr)
-> [SCC (LiveBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a. a -> [a] -> [a]
:[SCC (LiveBasicBlock instr)]
done) [SCC (LiveBasicBlock instr)]
sccs
 where      (blockmap' :: BlockMap RegSet
blockmap', blocks' :: [LiveBasicBlock instr]
blocks')
                = (BlockMap RegSet
 -> [LiveBasicBlock instr]
 -> (BlockMap RegSet, [LiveBasicBlock instr]))
-> (BlockMap RegSet -> BlockMap RegSet -> Bool)
-> BlockMap RegSet
-> [LiveBasicBlock instr]
-> (BlockMap RegSet, [LiveBasicBlock instr])
forall a b c.
(a -> b -> (a, c)) -> (a -> a -> Bool) -> a -> b -> (a, c)
iterateUntilUnchanged BlockMap RegSet
-> [LiveBasicBlock instr]
-> (BlockMap RegSet, [LiveBasicBlock instr])
forall instr.
Instruction instr =>
BlockMap RegSet
-> [LiveBasicBlock instr]
-> (BlockMap RegSet, [LiveBasicBlock instr])
linearLiveness BlockMap RegSet -> BlockMap RegSet -> Bool
forall (map :: * -> *) (map :: * -> *) elt.
(IsMap map, IsMap map, Eq (KeyOf map), Eq elt,
 KeyOf map ~ KeyOf map) =>
map (UniqSet elt) -> map (UniqSet elt) -> Bool
equalBlockMaps
                                      BlockMap RegSet
blockmap [LiveBasicBlock instr]
blocks

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

            iterateUntilUnchanged :: (a -> b -> (a, c)) -> (a -> a -> Bool) -> a -> b -> (a, c)
iterateUntilUnchanged f :: a -> b -> (a, c)
f eq :: a -> a -> Bool
eq a :: a
a b :: b
b
                = [(a, c)] -> (a, c)
forall a. [a] -> a
head ([(a, c)] -> (a, c)) -> [(a, c)] -> (a, c)
forall a b. (a -> b) -> a -> b
$
                  ([(a, c)] -> [(a, c)]) -> [[(a, c)]] -> [(a, c)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(a, c)] -> [(a, c)]
forall a. [a] -> [a]
tail ([[(a, c)]] -> [(a, c)]) -> [[(a, c)]] -> [(a, c)]
forall a b. (a -> b) -> a -> b
$
                  ((a, c) -> (a, c) -> Bool) -> [(a, c)] -> [[(a, c)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(a1 :: a
a1, _) (a2 :: a
a2, _) -> a -> a -> Bool
eq a
a1 a
a2) ([(a, c)] -> [[(a, c)]]) -> [(a, c)] -> [[(a, c)]]
forall a b. (a -> b) -> a -> b
$
                  ((a, c) -> (a, c)) -> (a, c) -> [(a, c)]
forall a. (a -> a) -> a -> [a]
iterate (\(a :: a
a, _) -> a -> b -> (a, c)
f a
a b
b) ((a, c) -> [(a, c)]) -> (a, c) -> [(a, c)]
forall a b. (a -> b) -> a -> b
$
                  (a
a, [Char] -> c
forall a. [Char] -> a
panic "RegLiveness.livenessSCCs")


            linearLiveness
                :: Instruction instr
                => BlockMap RegSet -> [LiveBasicBlock instr]
                -> (BlockMap RegSet, [LiveBasicBlock instr])

            linearLiveness :: BlockMap RegSet
-> [LiveBasicBlock instr]
-> (BlockMap RegSet, [LiveBasicBlock instr])
linearLiveness = (BlockMap RegSet
 -> LiveBasicBlock instr -> (BlockMap RegSet, LiveBasicBlock instr))
-> BlockMap RegSet
-> [LiveBasicBlock instr]
-> (BlockMap RegSet, [LiveBasicBlock instr])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Platform
-> BlockMap RegSet
-> LiveBasicBlock instr
-> (BlockMap RegSet, LiveBasicBlock instr)
forall instr.
Instruction instr =>
Platform
-> BlockMap RegSet
-> LiveBasicBlock instr
-> (BlockMap RegSet, LiveBasicBlock instr)
livenessBlock Platform
platform)

                -- probably the least efficient way to compare two
                -- BlockMaps for equality.
            equalBlockMaps :: map (UniqSet elt) -> map (UniqSet elt) -> Bool
equalBlockMaps a :: map (UniqSet elt)
a b :: map (UniqSet elt)
b
                = [(KeyOf map, [elt])]
a' [(KeyOf map, [elt])] -> [(KeyOf map, [elt])] -> Bool
forall a. Eq a => a -> a -> Bool
== [(KeyOf map, [elt])]
b'
              where a' :: [(KeyOf map, [elt])]
a' = ((KeyOf map, UniqSet elt) -> (KeyOf map, [elt]))
-> [(KeyOf map, UniqSet elt)] -> [(KeyOf map, [elt])]
forall a b. (a -> b) -> [a] -> [b]
map (KeyOf map, UniqSet elt) -> (KeyOf map, [elt])
forall a elt. (a, UniqSet elt) -> (a, [elt])
f ([(KeyOf map, UniqSet elt)] -> [(KeyOf map, [elt])])
-> [(KeyOf map, UniqSet elt)] -> [(KeyOf map, [elt])]
forall a b. (a -> b) -> a -> b
$ map (UniqSet elt) -> [(KeyOf map, UniqSet elt)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList map (UniqSet elt)
a
                    b' :: [(KeyOf map, [elt])]
b' = ((KeyOf map, UniqSet elt) -> (KeyOf map, [elt]))
-> [(KeyOf map, UniqSet elt)] -> [(KeyOf map, [elt])]
forall a b. (a -> b) -> [a] -> [b]
map (KeyOf map, UniqSet elt) -> (KeyOf map, [elt])
forall a elt. (a, UniqSet elt) -> (a, [elt])
f ([(KeyOf map, UniqSet elt)] -> [(KeyOf map, [elt])])
-> [(KeyOf map, UniqSet elt)] -> [(KeyOf map, [elt])]
forall a b. (a -> b) -> a -> b
$ map (UniqSet elt) -> [(KeyOf map, UniqSet elt)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList map (UniqSet elt)
b
                    f :: (a, UniqSet elt) -> (a, [elt])
f (key :: a
key,elt :: UniqSet elt
elt) = (a
key, UniqSet elt -> [elt]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet elt
elt)
                    -- See Note [Unique Determinism and code generation]



-- | Annotate a basic block with register liveness information.
--
livenessBlock
        :: Instruction instr
        => Platform
        -> BlockMap RegSet
        -> LiveBasicBlock instr
        -> (BlockMap RegSet, LiveBasicBlock instr)

livenessBlock :: Platform
-> BlockMap RegSet
-> LiveBasicBlock instr
-> (BlockMap RegSet, LiveBasicBlock instr)
livenessBlock platform :: Platform
platform blockmap :: BlockMap RegSet
blockmap (BasicBlock block_id :: BlockId
block_id instrs :: [LiveInstr instr]
instrs)
 = let
        (regsLiveOnEntry :: RegSet
regsLiveOnEntry, instrs1 :: [LiveInstr instr]
instrs1)
            = Platform
-> RegSet
-> BlockMap RegSet
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (RegSet, [LiveInstr instr])
forall instr.
Instruction instr =>
Platform
-> RegSet
-> BlockMap RegSet
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (RegSet, [LiveInstr instr])
livenessBack Platform
platform RegSet
forall a. UniqSet a
emptyUniqSet BlockMap RegSet
blockmap [] ([LiveInstr instr] -> [LiveInstr instr]
forall a. [a] -> [a]
reverse [LiveInstr instr]
instrs)
        blockmap' :: BlockMap RegSet
blockmap'       = KeyOf LabelMap -> RegSet -> BlockMap RegSet -> BlockMap RegSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
block_id RegSet
regsLiveOnEntry BlockMap RegSet
blockmap

        instrs2 :: [LiveInstr instr]
instrs2         = Platform -> RegSet -> [LiveInstr instr] -> [LiveInstr instr]
forall instr.
Instruction instr =>
Platform -> RegSet -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward Platform
platform RegSet
regsLiveOnEntry [LiveInstr instr]
instrs1

        output :: LiveBasicBlock instr
output          = BlockId -> [LiveInstr instr] -> LiveBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
block_id [LiveInstr instr]
instrs2

   in   ( BlockMap RegSet
blockmap', LiveBasicBlock instr
output)

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

livenessForward
        :: Instruction instr
        => Platform
        -> RegSet                       -- regs live on this instr
        -> [LiveInstr instr] -> [LiveInstr instr]

livenessForward :: Platform -> RegSet -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward _        _           []  = []
livenessForward platform :: Platform
platform rsLiveEntry :: RegSet
rsLiveEntry (li :: LiveInstr instr
li@(LiveInstr instr :: InstrSR instr
instr mLive :: Maybe Liveness
mLive) : lis :: [LiveInstr instr]
lis)
        | Just live :: Liveness
live <- Maybe Liveness
mLive
        = let
                RU _ written :: [Reg]
written  = Platform -> InstrSR instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr
                -- Regs that are written to but weren't live on entry to this instruction
                --      are recorded as being born here.
                rsBorn :: RegSet
rsBorn          = [Reg] -> RegSet
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
                                ([Reg] -> RegSet) -> [Reg] -> RegSet
forall a b. (a -> b) -> a -> b
$ (Reg -> Bool) -> [Reg] -> [Reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\r :: Reg
r -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Reg -> RegSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
r RegSet
rsLiveEntry) [Reg]
written

                rsLiveNext :: RegSet
rsLiveNext      = (RegSet
rsLiveEntry RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` RegSet
rsBorn)
                                        RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` (Liveness -> RegSet
liveDieRead Liveness
live)
                                        RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` (Liveness -> RegSet
liveDieWrite Liveness
live)

        in InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr (Liveness -> Maybe Liveness
forall a. a -> Maybe a
Just Liveness
live { liveBorn :: RegSet
liveBorn = RegSet
rsBorn })
                LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: Platform -> RegSet -> [LiveInstr instr] -> [LiveInstr instr]
forall instr.
Instruction instr =>
Platform -> RegSet -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward Platform
platform RegSet
rsLiveNext [LiveInstr instr]
lis

        | Bool
otherwise
        = LiveInstr instr
li LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: Platform -> RegSet -> [LiveInstr instr] -> [LiveInstr instr]
forall instr.
Instruction instr =>
Platform -> RegSet -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward Platform
platform RegSet
rsLiveEntry [LiveInstr instr]
lis


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

livenessBack
        :: Instruction instr
        => Platform
        -> 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])

livenessBack :: Platform
-> RegSet
-> BlockMap RegSet
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (RegSet, [LiveInstr instr])
livenessBack _        liveregs :: RegSet
liveregs _        done :: [LiveInstr instr]
done []  = (RegSet
liveregs, [LiveInstr instr]
done)

livenessBack platform :: Platform
platform liveregs :: RegSet
liveregs blockmap :: BlockMap RegSet
blockmap acc :: [LiveInstr instr]
acc (instr :: LiveInstr instr
instr : instrs :: [LiveInstr instr]
instrs)
 = let  (liveregs' :: RegSet
liveregs', instr' :: LiveInstr instr
instr')     = Platform
-> RegSet
-> BlockMap RegSet
-> LiveInstr instr
-> (RegSet, LiveInstr instr)
forall instr.
Instruction instr =>
Platform
-> RegSet
-> BlockMap RegSet
-> LiveInstr instr
-> (RegSet, LiveInstr instr)
liveness1 Platform
platform RegSet
liveregs BlockMap RegSet
blockmap LiveInstr instr
instr
   in   Platform
-> RegSet
-> BlockMap RegSet
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (RegSet, [LiveInstr instr])
forall instr.
Instruction instr =>
Platform
-> RegSet
-> BlockMap RegSet
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (RegSet, [LiveInstr instr])
livenessBack Platform
platform RegSet
liveregs' BlockMap RegSet
blockmap (LiveInstr instr
instr' LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs


-- don't bother tagging comments or deltas with liveness
liveness1
        :: Instruction instr
        => Platform
        -> RegSet
        -> BlockMap RegSet
        -> LiveInstr instr
        -> (RegSet, LiveInstr instr)

liveness1 :: Platform
-> RegSet
-> BlockMap RegSet
-> LiveInstr instr
-> (RegSet, LiveInstr instr)
liveness1 _ liveregs :: RegSet
liveregs _ (LiveInstr instr :: InstrSR instr
instr _)
        | InstrSR instr -> Bool
forall instr. Instruction instr => instr -> Bool
isMetaInstr InstrSR instr
instr
        = (RegSet
liveregs, InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr Maybe Liveness
forall a. Maybe a
Nothing)

liveness1 platform :: Platform
platform liveregs :: RegSet
liveregs blockmap :: BlockMap RegSet
blockmap (LiveInstr instr :: InstrSR instr
instr _)

        | Bool
not_a_branch
        = (RegSet
liveregs1, InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr
                        (Liveness -> Maybe Liveness
forall a. a -> Maybe a
Just (Liveness -> Maybe Liveness) -> Liveness -> Maybe Liveness
forall a b. (a -> b) -> a -> b
$ Liveness :: RegSet -> RegSet -> RegSet -> Liveness
Liveness
                        { liveBorn :: RegSet
liveBorn      = RegSet
forall a. UniqSet a
emptyUniqSet
                        , liveDieRead :: RegSet
liveDieRead   = [Reg] -> RegSet
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [Reg]
r_dying
                        , liveDieWrite :: RegSet
liveDieWrite  = [Reg] -> RegSet
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [Reg]
w_dying }))

        | Bool
otherwise
        = (RegSet
liveregs_br, InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr
                        (Liveness -> Maybe Liveness
forall a. a -> Maybe a
Just (Liveness -> Maybe Liveness) -> Liveness -> Maybe Liveness
forall a b. (a -> b) -> a -> b
$ Liveness :: RegSet -> RegSet -> RegSet -> Liveness
Liveness
                        { liveBorn :: RegSet
liveBorn      = RegSet
forall a. UniqSet a
emptyUniqSet
                        , liveDieRead :: RegSet
liveDieRead   = [Reg] -> RegSet
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [Reg]
r_dying_br
                        , liveDieWrite :: RegSet
liveDieWrite  = [Reg] -> RegSet
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [Reg]
w_dying }))

        where
            !(RU read :: [Reg]
read written :: [Reg]
written) = Platform -> InstrSR instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr

            -- registers that were written here are dead going backwards.
            -- registers that were read here are live going backwards.
            liveregs1 :: RegSet
liveregs1   = (RegSet
liveregs RegSet -> [Reg] -> RegSet
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
`delListFromUniqSet` [Reg]
written)
                                    RegSet -> [Reg] -> RegSet
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
`addListToUniqSet` [Reg]
read

            -- registers that are not live beyond this point, are recorded
            --  as dying here.
            r_dying :: [Reg]
r_dying     = [ Reg
reg | Reg
reg <- [Reg]
read, Reg
reg Reg -> [Reg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Reg]
written,
                              Bool -> Bool
not (Reg -> RegSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
reg RegSet
liveregs) ]

            w_dying :: [Reg]
w_dying     = [ Reg
reg | Reg
reg <- [Reg]
written,
                             Bool -> Bool
not (Reg -> RegSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet Reg
reg RegSet
liveregs) ]

            -- union in the live regs from all the jump destinations of this
            -- instruction.
            targets :: [BlockId]
targets      = InstrSR instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
instr -- where we go from here
            not_a_branch :: Bool
not_a_branch = [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
targets

            targetLiveRegs :: BlockId -> RegSet
targetLiveRegs target :: BlockId
target
                  = case KeyOf LabelMap -> BlockMap RegSet -> Maybe RegSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
target BlockMap RegSet
blockmap of
                                Just ra :: RegSet
ra -> RegSet
ra
                                Nothing -> RegSet
emptyRegSet

            live_from_branch :: RegSet
live_from_branch = [RegSet] -> RegSet
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets ((BlockId -> RegSet) -> [BlockId] -> [RegSet]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> RegSet
targetLiveRegs [BlockId]
targets)

            liveregs_br :: RegSet
liveregs_br = RegSet
liveregs1 RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` RegSet
live_from_branch

            -- registers that are live only in the branch targets should
            -- be listed as dying here.
            live_branch_only :: RegSet
live_branch_only = RegSet
live_from_branch RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` RegSet
liveregs
            r_dying_br :: [Reg]
r_dying_br  = RegSet -> [Reg]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet ([Reg] -> RegSet
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [Reg]
r_dying RegSet -> RegSet -> RegSet
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets`
                                             RegSet
live_branch_only)
                          -- See Note [Unique Determinism and code generation]