{-# LANGUAGE LambdaCase #-}
module Tokstyle.Cimple.Analysis.Liveness
    ( liveness
    , Liveness
    , livenessProblem
    ) where

import           Data.Fix                     (Fix (..), unFix)
import           Data.Map.Strict              (Map)
import qualified Data.Map.Strict              as Map
import           Data.Set                     (Set)
import qualified Data.Set                     as Set
import           Data.Text                    (Text)
import qualified Data.Text                    as Text
import           Language.Cimple              (Lexeme (..), NodeF (..),
                                               UnaryOp (..))
import qualified Language.Cimple              as C
import           Tokstyle.Analysis.AccessPath
import           Tokstyle.Analysis.Dataflow
import           Tokstyle.Cimple.Analysis.CFG (CFG, EdgeType, Node (..),
                                               NodeKind (..))

type Liveness = Set AccessPath

liveness :: [Node] -> CFG -> Map Node Liveness
liveness :: [Node] -> CFG -> Map Node Liveness
liveness [Node]
exits CFG
cfg = [Node]
-> CFG -> Dataflow Node EdgeType Liveness -> Map Node Liveness
forall node state edge.
(Ord node, Eq state) =>
[node]
-> Map node [(edge, node)]
-> Dataflow node edge state
-> Map node state
solveBackward [Node]
exits CFG
cfg ([Node] -> CFG -> Dataflow Node EdgeType Liveness
livenessProblem [Node]
exits CFG
cfg)

livenessProblem :: [Node] -> CFG -> Dataflow Node EdgeType Liveness
livenessProblem :: [Node] -> CFG -> Dataflow Node EdgeType Liveness
livenessProblem [Node]
_ CFG
_ = Dataflow :: forall node edge state.
(node -> state -> state)
-> (node -> edge -> state -> state)
-> (state -> state -> state)
-> state
-> Dataflow node edge state
Dataflow
    { transfer :: Node -> Liveness -> Liveness
transfer     = Node -> Liveness -> Liveness
transferFunc
    , edgeTransfer :: Node -> EdgeType -> Liveness -> Liveness
edgeTransfer = \Node
_ EdgeType
_ Liveness
s -> Liveness
s
    , merge :: Liveness -> Liveness -> Liveness
merge        = Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
Set.union
    , initial :: Liveness
initial      = Liveness
forall a. Set a
Set.empty
    }
  where
    transferFunc :: Node -> Liveness -> Liveness
    transferFunc :: Node -> Liveness -> Liveness
transferFunc (Node Int
_ NodeKind
nk) Liveness
live =
        let (Liveness
used, Liveness
defined) = NodeKind -> (Liveness, Liveness)
nodeUsesDefs NodeKind
nk
        in (Liveness
live Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Liveness
defined) Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
used

    nodeUsesDefs :: NodeKind -> (Liveness, Liveness)
nodeUsesDefs = \case
        StmtNode Node (Lexeme Text)
s   -> Node (Lexeme Text) -> (Liveness, Liveness)
stmtUsesDefs Node (Lexeme Text)
s
        BranchNode Node (Lexeme Text)
e -> Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
        NodeKind
_            -> (Liveness
forall a. Set a
Set.empty, Liveness
forall a. Set a
Set.empty)

    stmtUsesDefs :: Node (Lexeme Text) -> (Liveness, Liveness)
stmtUsesDefs Node (Lexeme Text)
s = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
s of
        ExprStmt Node (Lexeme Text)
e     -> Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
        Return (Just Node (Lexeme Text)
e) -> Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
        VarDeclStmt (Fix (VarDecl Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
_)) Maybe (Node (Lexeme Text))
mInit ->
            let (Liveness
u, Liveness
_) = (Liveness, Liveness)
-> (Node (Lexeme Text) -> (Liveness, Liveness))
-> Maybe (Node (Lexeme Text))
-> (Liveness, Liveness)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Liveness
forall a. Set a
Set.empty, Liveness
forall a. Set a
Set.empty) Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Maybe (Node (Lexeme Text))
mInit
            in (Liveness
u, AccessPath -> Liveness
forall a. a -> Set a
Set.singleton (String -> AccessPath
PathVar (Text -> String
Text.unpack Text
name)))
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> (Liveness
forall a. Set a
Set.empty, Liveness
forall a. Set a
Set.empty)

    exprUsesDefs :: C.Node (Lexeme Text) -> (Set AccessPath, Set AccessPath)
    exprUsesDefs :: Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
        VarExpr (L AlexPosn
_ LexemeClass
_ Text
name) -> (AccessPath -> Liveness
forall a. a -> Set a
Set.singleton (String -> AccessPath
PathVar (Text -> String
Text.unpack Text
name)), Liveness
forall a. Set a
Set.empty)
        UnaryExpr UnaryOp
UopDeref Node (Lexeme Text)
e ->
            let (Liveness
u, Liveness
d) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
            in (Liveness
-> (AccessPath -> Liveness) -> Maybe AccessPath -> Liveness
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Liveness
u (AccessPath -> Liveness -> Liveness
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Liveness
u) (Node (Lexeme Text) -> Maybe AccessPath
exprPath (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node)), Liveness
d)
        PointerAccess Node (Lexeme Text)
e (L AlexPosn
_ LexemeClass
_ Text
_) ->
            let (Liveness
u, Liveness
d) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
            in (Liveness
-> (AccessPath -> Liveness) -> Maybe AccessPath -> Liveness
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Liveness
u (AccessPath -> Liveness -> Liveness
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Liveness
u) (Node (Lexeme Text) -> Maybe AccessPath
exprPath (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node)), Liveness
d)
        MemberAccess Node (Lexeme Text)
e (L AlexPosn
_ LexemeClass
_ Text
_) ->
            let (Liveness
u, Liveness
d) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
            in (Liveness
-> (AccessPath -> Liveness) -> Maybe AccessPath -> Liveness
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Liveness
u (AccessPath -> Liveness -> Liveness
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Liveness
u) (Node (Lexeme Text) -> Maybe AccessPath
exprPath (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node)), Liveness
d)
        FunctionCall Node (Lexeme Text)
f [Node (Lexeme Text)]
args ->
            let (Liveness
uf, Liveness
df) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
f
                argsRes :: [(Liveness, Liveness)]
argsRes = (Node (Lexeme Text) -> (Liveness, Liveness))
-> [Node (Lexeme Text)] -> [(Liveness, Liveness)]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs [Node (Lexeme Text)]
args
            in ([Liveness] -> Liveness
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Liveness
uf Liveness -> [Liveness] -> [Liveness]
forall a. a -> [a] -> [a]
: ((Liveness, Liveness) -> Liveness)
-> [(Liveness, Liveness)] -> [Liveness]
forall a b. (a -> b) -> [a] -> [b]
map (Liveness, Liveness) -> Liveness
forall a b. (a, b) -> a
fst [(Liveness, Liveness)]
argsRes), [Liveness] -> Liveness
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Liveness
df Liveness -> [Liveness] -> [Liveness]
forall a. a -> [a] -> [a]
: ((Liveness, Liveness) -> Liveness)
-> [(Liveness, Liveness)] -> [Liveness]
forall a b. (a -> b) -> [a] -> [b]
map (Liveness, Liveness) -> Liveness
forall a b. (a, b) -> b
snd [(Liveness, Liveness)]
argsRes))
        AssignExpr Node (Lexeme Text)
l AssignOp
_ Node (Lexeme Text)
r ->
            let (Liveness
ul, Liveness
dl) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
l
                (Liveness
ur, Liveness
dr) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
r
                d :: Liveness
d = Liveness
-> (AccessPath -> Liveness) -> Maybe AccessPath -> Liveness
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Liveness
dl (AccessPath -> Liveness -> Liveness
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Liveness
dl) (Node (Lexeme Text) -> Maybe AccessPath
exprPath Node (Lexeme Text)
l)
            in (Liveness
ul Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
ur, Liveness
d Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
dr)
        BinaryExpr Node (Lexeme Text)
l BinaryOp
_ Node (Lexeme Text)
r ->
            let (Liveness
ul, Liveness
dl) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
l
                (Liveness
ur, Liveness
dr) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
r
            in (Liveness
ul Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
ur, Liveness
dl Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
dr)
        TernaryExpr Node (Lexeme Text)
c Node (Lexeme Text)
t Node (Lexeme Text)
e ->
            let (Liveness
uc, Liveness
dc) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
c
                (Liveness
ut, Liveness
dt) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
t
                (Liveness
ue, Liveness
de) = Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
            in (Liveness
uc Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
ut Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
ue, Liveness
dc Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
dt Liveness -> Liveness -> Liveness
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Liveness
de)
        ParenExpr Node (Lexeme Text)
e -> Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
        CastExpr Node (Lexeme Text)
_ Node (Lexeme Text)
e -> Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
        UnaryExpr UnaryOp
_ Node (Lexeme Text)
e -> Node (Lexeme Text) -> (Liveness, Liveness)
exprUsesDefs Node (Lexeme Text)
e
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> (Liveness
forall a. Set a
Set.empty, Liveness
forall a. Set a
Set.empty)

    exprPath :: C.Node (Lexeme Text) -> Maybe AccessPath
    exprPath :: Node (Lexeme Text) -> Maybe AccessPath
exprPath (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
        VarExpr (L AlexPosn
_ LexemeClass
_ Text
name)           -> AccessPath -> Maybe AccessPath
forall a. a -> Maybe a
Just (String -> AccessPath
PathVar (Text -> String
Text.unpack Text
name))
        UnaryExpr UnaryOp
UopDeref Node (Lexeme Text)
e           -> AccessPath -> AccessPath
PathDeref (AccessPath -> AccessPath) -> Maybe AccessPath -> Maybe AccessPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe AccessPath
exprPath Node (Lexeme Text)
e
        PointerAccess Node (Lexeme Text)
e (L AlexPosn
_ LexemeClass
_ Text
member) -> AccessPath -> String -> AccessPath
PathField (AccessPath -> String -> AccessPath)
-> Maybe AccessPath -> Maybe (String -> AccessPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe AccessPath
exprPath Node (Lexeme Text)
e Maybe (String -> AccessPath) -> Maybe String -> Maybe AccessPath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
Text.unpack Text
member)
        MemberAccess Node (Lexeme Text)
e (L AlexPosn
_ LexemeClass
_ Text
member)  -> AccessPath -> String -> AccessPath
PathField (AccessPath -> String -> AccessPath)
-> Maybe AccessPath -> Maybe (String -> AccessPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe AccessPath
exprPath Node (Lexeme Text)
e Maybe (String -> AccessPath) -> Maybe String -> Maybe AccessPath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
Text.unpack Text
member)
        NodeF (Lexeme Text) (Node (Lexeme Text))
_                              -> Maybe AccessPath
forall a. Maybe a
Nothing