-- FIXME: this module is slow

-- | Based on the Appel book.
module Kempe.Asm.X86.Liveness ( Liveness
                              , reconstruct
                              ) where

import           Control.Composition (thread)
-- this seems to be faster
import qualified Data.IntMap.Lazy    as IM
import           Data.Semigroup      ((<>))
import qualified Data.Set            as S
import           Kempe.Asm.X86.Type

emptyLiveness :: Liveness
emptyLiveness :: Liveness
emptyLiveness = Set AbsReg -> Set AbsReg -> Liveness
Liveness Set AbsReg
forall a. Set a
S.empty Set AbsReg
forall a. Set a
S.empty

-- need: succ for a node

initLiveness :: [X86 reg ControlAnn] -> LivenessMap
initLiveness :: [X86 reg ControlAnn] -> LivenessMap
initLiveness = [(Key, (ControlAnn, Liveness))] -> LivenessMap
forall a. [(Key, a)] -> IntMap a
IM.fromList ([(Key, (ControlAnn, Liveness))] -> LivenessMap)
-> ([X86 reg ControlAnn] -> [(Key, (ControlAnn, Liveness))])
-> [X86 reg ControlAnn]
-> LivenessMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (X86 reg ControlAnn -> (Key, (ControlAnn, Liveness)))
-> [X86 reg ControlAnn] -> [(Key, (ControlAnn, Liveness))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\X86 reg ControlAnn
asm -> let x :: ControlAnn
x = X86 reg ControlAnn -> ControlAnn
forall reg a. X86 reg a -> a
ann X86 reg ControlAnn
asm in (ControlAnn -> Key
node ControlAnn
x, (ControlAnn
x, Liveness
emptyLiveness)))

type LivenessMap = IM.IntMap (ControlAnn, Liveness)

-- | All program points accessible from some node.
succNode :: ControlAnn -- ^ 'ControlAnn' associated w/ node @n@
         -> LivenessMap
         -> [Liveness] -- ^ 'Liveness' associated with 'succNode' @n@
succNode :: ControlAnn -> LivenessMap -> [Liveness]
succNode ControlAnn
x LivenessMap
ns =
    let conns :: [Key]
conns = ControlAnn -> [Key]
conn ControlAnn
x
        in (Key -> Liveness) -> [Key] -> [Liveness]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ControlAnn, Liveness) -> Liveness
forall a b. (a, b) -> b
snd ((ControlAnn, Liveness) -> Liveness)
-> (Key -> (ControlAnn, Liveness)) -> Key -> Liveness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> LivenessMap -> (ControlAnn, Liveness))
-> LivenessMap -> Key -> (ControlAnn, Liveness)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> LivenessMap -> (ControlAnn, Liveness)
lookupNode LivenessMap
ns) [Key]
conns

lookupNode :: Int -> LivenessMap -> (ControlAnn, Liveness)
lookupNode :: Key -> LivenessMap -> (ControlAnn, Liveness)
lookupNode = (ControlAnn, Liveness)
-> Key -> LivenessMap -> (ControlAnn, Liveness)
forall a. a -> Key -> IntMap a -> a
IM.findWithDefault ([Char] -> (ControlAnn, Liveness)
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: failed to look up instruction")

done :: LivenessMap -> LivenessMap -> Bool
done :: LivenessMap -> LivenessMap -> Bool
done LivenessMap
n0 LivenessMap
n1 = {-# SCC "done" #-} [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((ControlAnn, Liveness) -> (ControlAnn, Liveness) -> Bool)
-> [(ControlAnn, Liveness)] -> [(ControlAnn, Liveness)] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(ControlAnn
_, Liveness
l) (ControlAnn
_, Liveness
l') -> Liveness
l Liveness -> Liveness -> Bool
forall a. Eq a => a -> a -> Bool
== Liveness
l') (LivenessMap -> [(ControlAnn, Liveness)]
forall a. IntMap a -> [a]
IM.elems LivenessMap
n0) (LivenessMap -> [(ControlAnn, Liveness)]
forall a. IntMap a -> [a]
IM.elems LivenessMap
n1) -- should be safe b/c n0, n1 must have same length

-- order in which to inspect nodes during liveness analysis
inspectOrder :: [X86 reg ControlAnn] -> [Int]
inspectOrder :: [X86 reg ControlAnn] -> [Key]
inspectOrder = (X86 reg ControlAnn -> Key) -> [X86 reg ControlAnn] -> [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ControlAnn -> Key
node (ControlAnn -> Key)
-> (X86 reg ControlAnn -> ControlAnn) -> X86 reg ControlAnn -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X86 reg ControlAnn -> ControlAnn
forall reg a. X86 reg a -> a
ann) -- don't need to reverse because thread goes in opposite order

reconstruct :: [X86 reg ControlAnn] -> [X86 reg Liveness]
reconstruct :: [X86 reg ControlAnn] -> [X86 reg Liveness]
reconstruct [X86 reg ControlAnn]
asms = {-# SCC "reconstructL" #-} (X86 reg ControlAnn -> X86 reg Liveness)
-> [X86 reg ControlAnn] -> [X86 reg Liveness]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ControlAnn -> Liveness) -> X86 reg ControlAnn -> X86 reg Liveness
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ControlAnn -> Liveness
lookupL) [X86 reg ControlAnn]
asms
    where l :: LivenessMap
l = {-# SCC "mkLiveness" #-} [X86 reg ControlAnn] -> LivenessMap
forall reg. [X86 reg ControlAnn] -> LivenessMap
mkLiveness [X86 reg ControlAnn]
asms
          lookupL :: ControlAnn -> Liveness
lookupL ControlAnn
x = (ControlAnn, Liveness) -> Liveness
forall a b. (a, b) -> b
snd ((ControlAnn, Liveness) -> Liveness)
-> (ControlAnn, Liveness) -> Liveness
forall a b. (a -> b) -> a -> b
$ Key -> LivenessMap -> (ControlAnn, Liveness)
lookupNode (ControlAnn -> Key
node ControlAnn
x) LivenessMap
l

mkLiveness :: [X86 reg ControlAnn] -> LivenessMap
mkLiveness :: [X86 reg ControlAnn] -> LivenessMap
mkLiveness [X86 reg ControlAnn]
asms = [Key] -> LivenessMap -> LivenessMap
liveness [Key]
is ([X86 reg ControlAnn] -> LivenessMap
forall reg. [X86 reg ControlAnn] -> LivenessMap
initLiveness [X86 reg ControlAnn]
asms)
    where is :: [Key]
is = [X86 reg ControlAnn] -> [Key]
forall reg. [X86 reg ControlAnn] -> [Key]
inspectOrder [X86 reg ControlAnn]
asms

liveness :: [Int] -> LivenessMap -> LivenessMap
liveness :: [Key] -> LivenessMap -> LivenessMap
liveness [Key]
is LivenessMap
nSt =
    if LivenessMap -> LivenessMap -> Bool
done LivenessMap
nSt LivenessMap
nSt'
        then LivenessMap
nSt
        else [Key] -> LivenessMap -> LivenessMap
liveness [Key]
is LivenessMap
nSt'
    where nSt' :: LivenessMap
nSt' = {-# SCC "iterNodes" #-} [Key] -> LivenessMap -> LivenessMap
iterNodes [Key]
is LivenessMap
nSt

iterNodes :: [Int] -> LivenessMap -> LivenessMap
iterNodes :: [Key] -> LivenessMap -> LivenessMap
iterNodes [Key]
is = [LivenessMap -> LivenessMap] -> LivenessMap -> LivenessMap
forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread ((Key -> LivenessMap -> LivenessMap)
-> [Key] -> [LivenessMap -> LivenessMap]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> LivenessMap -> LivenessMap
stepNode [Key]
is)

stepNode :: Int -> LivenessMap -> LivenessMap
stepNode :: Key -> LivenessMap -> LivenessMap
stepNode Key
n LivenessMap
ns = {-# SCC "stepNode" #-} Key -> (ControlAnn, Liveness) -> LivenessMap -> LivenessMap
forall a. Key -> a -> IntMap a -> IntMap a
IM.insert Key
n (ControlAnn
c, Set AbsReg -> Set AbsReg -> Liveness
Liveness Set AbsReg
ins' Set AbsReg
out') LivenessMap
ns
    where (ControlAnn
c, Liveness
l) = Key -> LivenessMap -> (ControlAnn, Liveness)
lookupNode Key
n LivenessMap
ns
          ins' :: Set AbsReg
ins' = ControlAnn -> Set AbsReg
usesNode ControlAnn
c Set AbsReg -> Set AbsReg -> Set AbsReg
forall a. Semigroup a => a -> a -> a
<> (Liveness -> Set AbsReg
out Liveness
l Set AbsReg -> Set AbsReg -> Set AbsReg
forall a. Ord a => Set a -> Set a -> Set a
S.\\ ControlAnn -> Set AbsReg
defsNode ControlAnn
c)
          out' :: Set AbsReg
out' = [Set AbsReg] -> Set AbsReg
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Liveness -> Set AbsReg) -> [Liveness] -> [Set AbsReg]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Liveness -> Set AbsReg
ins (ControlAnn -> LivenessMap -> [Liveness]
succNode ControlAnn
c LivenessMap
ns))