{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}

module Tokstyle.Analysis.PointsTo
    ( evalExpr
    , extractRelevantState
    ) where

import           Control.Monad                                (foldM, when)
import           Control.Monad.State.Strict                   (get)
import           Data.Fix                                     (Fix (..))
import           Data.Hashable                                (hash)
import           Data.IntMap.Strict                           (IntMap)
import qualified Data.IntMap.Strict                           as IntMap
import           Data.IntSet                                  (IntSet)
import qualified Data.IntSet                                  as IntSet
import           Data.List                                    (foldl')
import           Data.Map.Strict                              (Map)
import qualified Data.Map.Strict                              as Map
import           Data.Maybe                                   (fromMaybe,
                                                               mapMaybe)
import           Data.Set                                     (Set)
import qualified Data.Set                                     as Set
import           Data.Text                                    (Text, pack)
import           Debug.Trace                                  (trace, traceM)
import           Language.Cimple                              (AlexPosn (..))
import qualified Language.Cimple                              as C
import           Language.Cimple.TraverseAst                  (AstActions (..),
                                                               astActions,
                                                               traverseAst)
import           Tokstyle.Analysis.DataFlow
import           Tokstyle.Analysis.PointsTo.ExternalSummaries (getExternalSummary,
                                                               locFromPos)
import           Tokstyle.Analysis.PointsTo.Types
import           Tokstyle.Analysis.Scope                      (ScopedId (..))
import           Tokstyle.Analysis.VTable                     (VTableMap)
import           Tokstyle.Common.TypeSystem                   (TypeDescr (..),
                                                               TypeSystem,
                                                               lookupType)

debugging :: Bool
debugging :: Bool
debugging = Bool
False

dtrace :: String -> a -> a
dtrace :: String -> a -> a
dtrace String
msg a
x = if Bool
debugging then String -> a -> a
forall a. String -> a -> a
trace String
msg a
x else a
x

dtraceM :: Monad m => String -> m ()
dtraceM :: String -> m ()
dtraceM String
msg = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugging (String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM String
msg)

-- Helper to find all reachable IMemLocs from a set of root IMemLocs
findReachable :: IntMap IntSet -> IntSet -> IntMap IntSet -> IntSet
findReachable :: IntMap IntSet -> IntSet -> IntMap IntSet -> IntSet
findReachable IntMap IntSet
fieldIdx IntSet
roots IntMap IntSet
mem = IntSet -> IntSet -> IntSet
go IntSet
roots IntSet
roots
  where
    go :: IntSet -> IntSet -> IntSet
go IntSet
current IntSet
visited =
        let
            -- Locations pointed to by current locations
            pointedTo :: IntSet
pointedTo = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions ([IntSet] -> IntSet) -> [IntSet] -> IntSet
forall a b. (a -> b) -> a -> b
$ (Key -> IntSet) -> [Key] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
l -> IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty Key
l IntMap IntSet
mem) (IntSet -> [Key]
IntSet.toList IntSet
current)
            -- Fields of current locations
            fields :: IntSet
fields = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions ([IntSet] -> IntSet) -> [IntSet] -> IntSet
forall a b. (a -> b) -> a -> b
$ (Key -> IntSet) -> [Key] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
l -> IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty Key
l IntMap IntSet
fieldIdx) (IntSet -> [Key]
IntSet.toList IntSet
current)

            newLocs :: IntSet
newLocs = IntSet
pointedTo IntSet -> IntSet -> IntSet
`IntSet.union` IntSet
fields
            next :: IntSet
next = IntSet
newLocs IntSet -> IntSet -> IntSet
`IntSet.difference` IntSet
visited
        in String -> IntSet -> IntSet
forall a. String -> a -> a
dtrace (String
"findReachable: current=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IntSet -> String
forall a. Show a => a -> String
show IntSet
current String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", next=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IntSet -> String
forall a. Show a => a -> String
show IntSet
next) (IntSet -> IntSet) -> IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$
           if IntSet -> Bool
IntSet.null IntSet
next
           then IntSet
visited
           else IntSet -> IntSet -> IntSet
go IntSet
next (IntSet
visited IntSet -> IntSet -> IntSet
`IntSet.union` IntSet
next)

-- | Extracts the relevant part of the abstract state for a function call.
extractRelevantState :: PointsToFact -> Map ScopedId IntSet -> PointsToAnalysis RelevantInputState
extractRelevantState :: PointsToFact
-> Map ScopedId IntSet -> PointsToAnalysis RelevantInputState
extractRelevantState PointsToFact
facts Map ScopedId IntSet
argMap = do
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get

    -- Ensure all StackLocs from varMap are in memMap for reachability analysis.
    -- This is needed because evalExpr for &var doesn't add it to memMap.
    let memMapWithStack :: IntMap IntSet
memMapWithStack = (IntMap IntSet -> ScopedId -> IntSet -> IntMap IntSet)
-> IntMap IntSet -> Map ScopedId IntSet -> IntMap IntSet
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\IntMap IntSet
acc ScopedId
sid IntSet
val ->
            case MemLoc -> Map MemLoc IMemLoc -> Maybe IMemLoc
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopedId -> MemLoc
StackLoc ScopedId
sid) (MemLocPool -> Map MemLoc IMemLoc
memLocToId MemLocPool
pool) of
                Just IMemLoc
iloc -> (IntSet -> IntSet -> IntSet)
-> Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
IntMap.insertWith ((IntSet -> IntSet -> IntSet) -> IntSet -> IntSet -> IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip IntSet -> IntSet -> IntSet
forall a b. a -> b -> a
const) (IMemLoc -> Key
unIMemLoc IMemLoc
iloc) IntSet
val IntMap IntSet
acc
                Maybe IMemLoc
Nothing -> IntMap IntSet
acc
            ) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts) (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
facts)

    let
        -- 1. Roots from arguments
        argRoots :: IntSet
argRoots = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions (Map ScopedId IntSet -> [IntSet]
forall k a. Map k a -> [a]
Map.elems Map ScopedId IntSet
argMap)

        -- 2. Roots from globals. Include ALL GlobalVarLocs from pool as roots.
        globalRoots :: IntSet
globalRoots = (IntSet -> Key -> MemLoc -> IntSet)
-> IntSet -> IntMap MemLoc -> IntSet
forall a b. (a -> Key -> b -> a) -> a -> IntMap b -> a
IntMap.foldlWithKey' (\IntSet
acc Key
k MemLoc
v ->
                case MemLoc
v of
                    GlobalVarLoc ScopedId
_ -> Key -> IntSet -> IntSet
IntSet.insert Key
k IntSet
acc
                    MemLoc
_              -> IntSet
acc
            ) IntSet
IntSet.empty (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)

        allRoots :: IntSet
allRoots = IntSet
argRoots IntSet -> IntSet -> IntSet
`IntSet.union` IntSet
globalRoots
        reachableLocs :: IntSet
reachableLocs = IntMap IntSet -> IntSet -> IntMap IntSet -> IntSet
findReachable (MemLocPool -> IntMap IntSet
fieldIndex MemLocPool
pool) IntSet
allRoots IntMap IntSet
memMapWithStack

        -- Filter memMap to only reachable locations
        relevantMemMap :: IntMap IntSet
relevantMemMap = IntMap IntSet -> IntSet -> IntMap IntSet
forall a. IntMap a -> IntSet -> IntMap a
IntMap.restrictKeys IntMap IntSet
memMapWithStack IntSet
reachableLocs

        -- Combine args and globals for the initial varMap of the callee
        isGlobalSid :: ScopedId -> Bool
isGlobalSid ScopedId
sid = ScopedId -> Scope
sidScope ScopedId
sid Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
/= Scope
C.Local
        relevantVarMap :: Map ScopedId IntSet
relevantVarMap = Map ScopedId IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map ScopedId IntSet
argMap ((ScopedId -> IntSet -> Bool)
-> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\ScopedId
sid IntSet
_ -> ScopedId -> Bool
isGlobalSid ScopedId
sid) (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
facts))

    RelevantInputState -> PointsToAnalysis RelevantInputState
forall (m :: * -> *) a. Monad m => a -> m a
return (RelevantInputState -> PointsToAnalysis RelevantInputState)
-> RelevantInputState -> PointsToAnalysis RelevantInputState
forall a b. (a -> b) -> a -> b
$ PointsToFact -> RelevantInputState
RelevantInputState (PointsToFact -> RelevantInputState)
-> PointsToFact -> RelevantInputState
forall a b. (a -> b) -> a -> b
$ Map ScopedId IntSet -> IntMap IntSet -> IntSet -> PointsToFact
PointsToFact Map ScopedId IntSet
relevantVarMap IntMap IntSet
relevantMemMap (PointsToFact -> IntSet
unknownWrites PointsToFact
facts)


-- Helper to get the top-level lexeme from a node, if it exists.
getLexeme :: C.Node (C.Lexeme l) -> Maybe (C.Lexeme l)
getLexeme :: Node (Lexeme l) -> Maybe (Lexeme l)
getLexeme (Fix (C.VarExpr Lexeme l
l))         = Lexeme l -> Maybe (Lexeme l)
forall a. a -> Maybe a
Just Lexeme l
l
getLexeme (Fix (C.MemberAccess Node (Lexeme l)
_ Lexeme l
l))  = Lexeme l -> Maybe (Lexeme l)
forall a. a -> Maybe a
Just Lexeme l
l
getLexeme (Fix (C.PointerAccess Node (Lexeme l)
_ Lexeme l
l)) = Lexeme l -> Maybe (Lexeme l)
forall a. a -> Maybe a
Just Lexeme l
l
getLexeme Node (Lexeme l)
_                           = Maybe (Lexeme l)
forall a. Maybe a
Nothing

-- A helper function to recursively evaluate the base of a member/pointer access.
evalBaseExpr :: PointsToFact -> PointsToContext ScopedId -> Int -> C.Node (C.Lexeme ScopedId) -> PointsToAnalysis IntSet
evalBaseExpr :: PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalBaseExpr PointsToFact
_ PointsToContext ScopedId
_ Key
_ (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid))) =
    case ScopedId -> Scope
sidScope ScopedId
sid of
        Scope
C.Local -> do
            IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
StackLoc ScopedId
sid)
            IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)
        Scope
_       -> do
            IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
GlobalVarLoc ScopedId
sid)
            IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)
evalBaseExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.PointerAccess Node (Lexeme ScopedId)
baseExpr Lexeme ScopedId
_)) =
    PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
evalBaseExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.MemberAccess Node (Lexeme ScopedId)
baseExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId{sidName :: ScopedId -> Text
sidName=Text
fName}))) = do
    IntSet
baseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalBaseExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    let baseIMemLocs :: [IMemLoc]
baseIMemLocs = (Key -> IMemLoc) -> [Key] -> [IMemLoc]
forall a b. (a -> b) -> [a] -> [b]
map Key -> IMemLoc
IMemLoc (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)
    let baseMemLocs :: [MemLoc]
baseMemLocs = (IMemLoc -> MemLoc) -> [IMemLoc] -> [MemLoc]
forall a b. (a -> b) -> [a] -> [b]
map (\IMemLoc
iloc -> MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc (IMemLoc -> Key
unIMemLoc IMemLoc
iloc) (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)) [IMemLoc]
baseIMemLocs
    [IMemLoc]
fieldILocs <- (MemLoc -> PointsToAnalysis IMemLoc)
-> [MemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\MemLoc
base -> MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base Text
fName)) [MemLoc]
baseMemLocs
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ [Key] -> IntSet
IntSet.fromList ((IMemLoc -> Key) -> [IMemLoc] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map IMemLoc -> Key
unIMemLoc [IMemLoc]
fieldILocs)
evalBaseExpr PointsToFact
_ PointsToContext ScopedId
_ Key
_ Node (Lexeme ScopedId)
_ = do
    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)

-- Evaluates a C expression to determine the set of memory locations it might refer to.
evalExpr :: PointsToFact -> PointsToContext ScopedId -> Int -> C.Node (C.Lexeme ScopedId) -> PointsToAnalysis IntSet
evalExpr :: PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
_ PointsToContext ScopedId
_ Key
_ (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId{sidName :: ScopedId -> Text
sidName=Text
"nullptr"}))) = do
    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
NullLoc
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)
evalExpr PointsToFact
facts PointsToContext ScopedId
_ Key
_ (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid))) =
    case ScopedId -> Map ScopedId IntSet -> Maybe IntSet
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
sid (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
facts) of
        Just IntSet
locs -> IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
locs
        Maybe IntSet
Nothing   ->
            case ScopedId -> Scope
sidScope ScopedId
sid of
                Scope
C.Local -> do
                    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc
                    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)
                Scope
_       -> do
                    IMemLoc
globalLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
GlobalVarLoc ScopedId
sid)
                    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault (Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
globalLoc)) (IMemLoc -> Key
unIMemLoc IMemLoc
globalLoc) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts)
evalExpr PointsToFact
_ PointsToContext ScopedId
_ Key
_ (Fix (C.UnaryExpr UnaryOp
C.UopAddress (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid))))) =
    case ScopedId -> Scope
sidScope ScopedId
sid of
        Scope
C.Local -> do
            IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
StackLoc ScopedId
sid)
            IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)
        Scope
_       -> do
            IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
GlobalVarLoc ScopedId
sid)
            IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)
evalExpr PointsToFact
_ PointsToContext ScopedId
_ Key
_ (Fix (C.UnaryExpr UnaryOp
C.UopAddress (Fix (C.MemberAccess (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId
structId))) (C.L AlexPosn
_ LexemeClass
_ ScopedId{sidName :: ScopedId -> Text
sidName=Text
fName}))))) = do
    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc (ScopedId -> MemLoc
StackLoc ScopedId
structId) Text
fName)
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.UnaryExpr UnaryOp
C.UopAddress (Fix (C.PointerAccess Node (Lexeme ScopedId)
baseExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId{sidName :: ScopedId -> Text
sidName=Text
fName}))))) = do
    IntSet
baseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    let baseMemLocs :: [MemLoc]
baseMemLocs = (Key -> MemLoc) -> [Key] -> [MemLoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
i -> MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
i (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)) (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)
    [IMemLoc]
fieldILocs <- (MemLoc -> PointsToAnalysis IMemLoc)
-> [MemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\MemLoc
base -> MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base Text
fName)) [MemLoc]
baseMemLocs
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ [Key] -> IntSet
IntSet.fromList ((IMemLoc -> Key) -> [IMemLoc] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map IMemLoc -> Key
unIMemLoc [IMemLoc]
fieldILocs)
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.UnaryExpr UnaryOp
C.UopDeref Node (Lexeme ScopedId)
expr)) = do
    IntSet
locs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
expr
    IMemLoc
unknownLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc
    let unknownResult :: IntSet
unknownResult = if Key -> IntSet -> Bool
IntSet.member (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc) IntSet
locs
                        then PointsToFact -> IntSet
unknownWrites PointsToFact
facts IntSet -> IntSet -> IntSet
`IntSet.union` (Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc))
                        else IntSet
IntSet.empty
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    let derefLoc :: Key -> PointsToAnalysis IntSet
derefLoc Key
ilocInt = do
            let loc :: MemLoc
loc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)
            case MemLoc
loc of
                StackLoc ScopedId
sid            -> IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> ScopedId -> Map ScopedId IntSet -> IntSet
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntSet
IntSet.empty ScopedId
sid (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
facts)
                epl :: MemLoc
epl@ExternalParamLoc {} -> do
                    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
epl
                    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault (Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc)) (IMemLoc -> Key
unIMemLoc IMemLoc
iloc) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts)
                MemLoc
heapOrFieldOrGlb        -> do
                    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
heapOrFieldOrGlb
                    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty (IMemLoc -> Key
unIMemLoc IMemLoc
iloc) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts)
    [IntSet]
derefedLocs <- (Key -> PointsToAnalysis IntSet)
-> [Key] -> StateT MemLocPool Identity [IntSet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Key -> PointsToAnalysis IntSet
derefLoc (IntSet -> [Key]
IntSet.toList IntSet
locs)
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet -> IntSet) -> IntSet -> [IntSet] -> IntSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntSet -> IntSet -> IntSet
IntSet.union IntSet
unknownResult [IntSet]
derefedLocs
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.PointerAccess Node (Lexeme ScopedId)
baseExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId{sidName :: ScopedId -> Text
sidName=Text
fName}))) = do
    IntSet
baseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    -- V-Table resolution
    IntSet
vtableResults <- (IntSet -> Key -> PointsToAnalysis IntSet)
-> IntSet -> [Key] -> PointsToAnalysis IntSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IntSet
acc Key
ilocInt -> do
        let loc :: MemLoc
loc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)
        case MemLoc
loc of
            GlobalVarLoc ScopedId
vtableSid ->
                case ScopedId
-> Map ScopedId (Map Text ScopedId) -> Maybe (Map Text ScopedId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
vtableSid (PointsToContext ScopedId -> Map ScopedId (Map Text ScopedId)
forall l. PointsToContext l -> Map ScopedId (Map Text ScopedId)
pcVTableMap PointsToContext ScopedId
ctx) of
                    Just Map Text ScopedId
fields ->
                        case Text -> Map Text ScopedId -> Maybe ScopedId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
fName Map Text ScopedId
fields of
                            Just ScopedId
funcSid -> do
                                IMemLoc
funcLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
GlobalVarLoc ScopedId
funcSid)
                                IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet -> IntSet
IntSet.insert (IMemLoc -> Key
unIMemLoc IMemLoc
funcLoc) IntSet
acc
                            Maybe ScopedId
Nothing      -> IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
acc
                    Maybe (Map Text ScopedId)
Nothing -> IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
acc
            MemLoc
_ -> IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
acc
        ) IntSet
IntSet.empty (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)

    -- Regular field access
    IntSet
regularResults <- (IntSet -> Key -> PointsToAnalysis IntSet)
-> IntSet -> [Key] -> PointsToAnalysis IntSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IntSet
acc Key
ilocInt -> do
        let base :: MemLoc
base = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)
        IMemLoc
fieldLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base Text
fName)
        let deref :: IntSet
deref = IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty (IMemLoc -> Key
unIMemLoc IMemLoc
fieldLoc) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts)
        IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IntSet.union IntSet
deref IntSet
acc
        ) IntSet
IntSet.empty (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)

    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IntSet.union IntSet
vtableResults IntSet
regularResults
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.MemberAccess Node (Lexeme ScopedId)
baseExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId{sidName :: ScopedId -> Text
sidName=Text
fName}))) = do
    IntSet
baseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalBaseExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    (IntSet -> Key -> PointsToAnalysis IntSet)
-> IntSet -> [Key] -> PointsToAnalysis IntSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IntSet
acc Key
ilocInt -> do
        let base :: MemLoc
base = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)
        IMemLoc
fieldLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base Text
fName)
        let deref :: IntSet
deref = IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty (IMemLoc -> Key
unIMemLoc IMemLoc
fieldLoc) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts)
        IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IntSet.union IntSet
deref IntSet
acc
        ) IntSet
IntSet.empty (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.ArrayAccess Node (Lexeme ScopedId)
baseExpr Node (Lexeme ScopedId)
idxExpr)) = do
    IntSet
baseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalBaseExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    let fieldName :: Text
fieldName = case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
idxExpr of
            C.LiteralExpr LiteralType
C.Int (C.L AlexPosn
_ LexemeClass
_ ScopedId
idxLexeme) -> ScopedId -> Text
sidName ScopedId
idxLexeme
            NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_                                       -> Text
"[]"
    (IntSet -> Key -> PointsToAnalysis IntSet)
-> IntSet -> [Key] -> PointsToAnalysis IntSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IntSet
acc Key
ilocInt -> do
        let base :: MemLoc
base = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)
        IMemLoc
fieldLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base Text
fieldName)
        let deref :: IntSet
deref = IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty (IMemLoc -> Key
unIMemLoc IMemLoc
fieldLoc) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts)
        IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IntSet.union IntSet
deref IntSet
acc
        ) IntSet
IntSet.empty (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.CastExpr Node (Lexeme ScopedId)
_ Node (Lexeme ScopedId)
expr)) = PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
expr
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.FunctionCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args)) = do
    IntSet
calleeLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
calleeExpr
    let pos :: AlexPosn
pos = case Node (Lexeme ScopedId) -> Maybe (Lexeme ScopedId)
forall l. Node (Lexeme l) -> Maybe (Lexeme l)
getLexeme Node (Lexeme ScopedId)
calleeExpr of
            Just (C.L AlexPosn
p LexemeClass
_ ScopedId
_) -> AlexPosn
p
            Maybe (Lexeme ScopedId)
Nothing          -> Key -> Key -> Key -> AlexPosn
C.AlexPn Key
0 Key
0 Key
0

    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    IMemLoc
unknownLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc

    let applySummary :: Key -> PointsToAnalysis IntSet
applySummary Key
ilocInt = do
            let loc :: MemLoc
loc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)
            case MemLoc
loc of
                StackLoc ScopedId
sid     -> ScopedId -> PointsToAnalysis IntSet
handleCall ScopedId
sid
                GlobalVarLoc ScopedId
sid -> ScopedId -> PointsToAnalysis IntSet
handleCall ScopedId
sid
                MemLoc
_                -> IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc) -- Not a function call

        handleCall :: ScopedId -> PointsToAnalysis IntSet
handleCall ScopedId
sid =
            case ScopedId -> Maybe ExternalSummary
getExternalSummary ScopedId
sid of
                Just ExternalSummary
summary -> do
                    (Set MemLoc
retLocs, Bool
_) <- ExternalSummary
summary (PointsToContext ScopedId -> String
forall l. PointsToContext l -> String
pcFilePath PointsToContext ScopedId
ctx) AlexPosn
pos [Node (Lexeme ScopedId)]
args
                    [IMemLoc]
internedRetLocs <- (MemLoc -> PointsToAnalysis IMemLoc)
-> [MemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MemLoc -> PointsToAnalysis IMemLoc
intern (Set MemLoc -> [MemLoc]
forall a. Set a -> [a]
Set.toList Set MemLoc
retLocs)
                    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ [Key] -> IntSet
IntSet.fromList ((IMemLoc -> Key) -> [IMemLoc] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map IMemLoc -> Key
unIMemLoc [IMemLoc]
internedRetLocs)
                Maybe ExternalSummary
Nothing      ->
                    let GlobalEnv Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
gEnv = PointsToContext ScopedId -> GlobalEnv
forall l. PointsToContext l -> GlobalEnv
pcGlobalEnv PointsToContext ScopedId
ctx
                    in do
                        let funcMap :: Map ScopedId [Node (Lexeme ScopedId)]
funcMap = PointsToContext ScopedId -> Map ScopedId [Node (Lexeme ScopedId)]
forall l.
PointsToContext l -> Map ScopedId [Node (Lexeme ScopedId)]
pcFuncs PointsToContext ScopedId
ctx
                        case ScopedId
-> Map ScopedId [Node (Lexeme ScopedId)]
-> Maybe [Node (Lexeme ScopedId)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
sid Map ScopedId [Node (Lexeme ScopedId)]
funcMap of
                            Just [Node (Lexeme ScopedId)]
_ -> do -- Internal function
                                let calleeFuncs :: [Node (Lexeme ScopedId)]
calleeFuncs = [Node (Lexeme ScopedId)]
-> Maybe [Node (Lexeme ScopedId)] -> [Node (Lexeme ScopedId)]
forall a. a -> Maybe a -> a
fromMaybe (String -> [Node (Lexeme ScopedId)]
forall a. HasCallStack => String -> a
error (String -> [Node (Lexeme ScopedId)])
-> String -> [Node (Lexeme ScopedId)]
forall a b. (a -> b) -> a -> b
$ String
"Function AST not found for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedId -> String
forall a. Show a => a -> String
show ScopedId
sid) (ScopedId
-> Map ScopedId [Node (Lexeme ScopedId)]
-> Maybe [Node (Lexeme ScopedId)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
sid Map ScopedId [Node (Lexeme ScopedId)]
funcMap)
                                let calleeFunc :: Node (Lexeme ScopedId)
calleeFunc = [Node (Lexeme ScopedId)] -> Node (Lexeme ScopedId)
forall a. [a] -> a
head [Node (Lexeme ScopedId)]
calleeFuncs
                                let params :: [ScopedId]
params = Node (Lexeme ScopedId) -> [ScopedId]
getParams Node (Lexeme ScopedId)
calleeFunc
                                [IntSet]
argLocs <- (Node (Lexeme ScopedId) -> PointsToAnalysis IntSet)
-> [Node (Lexeme ScopedId)] -> StateT MemLocPool Identity [IntSet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId) [Node (Lexeme ScopedId)]
args
                                let initialVarMap :: Map ScopedId IntSet
initialVarMap = [(ScopedId, IntSet)] -> Map ScopedId IntSet
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScopedId, IntSet)] -> Map ScopedId IntSet)
-> [(ScopedId, IntSet)] -> Map ScopedId IntSet
forall a b. (a -> b) -> a -> b
$ [ScopedId] -> [IntSet] -> [(ScopedId, IntSet)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ScopedId]
params [IntSet]
argLocs

                                RelevantInputState
relevantState <- PointsToFact
-> Map ScopedId IntSet -> PointsToAnalysis RelevantInputState
extractRelevantState PointsToFact
facts Map ScopedId IntSet
initialVarMap

                                case (ScopedId, RelevantInputState)
-> Map
     (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
-> Maybe (FunctionSummary, PointsToFact)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopedId
sid, RelevantInputState
relevantState) Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
gEnv of
                                    Just (FunctionSummary
summary, PointsToFact
_) -> IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ FunctionSummary -> IntSet
fsReturnValue FunctionSummary
summary
                                    Maybe (FunctionSummary, PointsToFact)
Nothing           -> IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc) -- Unsummarized internal call
                            Maybe [Node (Lexeme ScopedId)]
Nothing -> -- Truly external
                                IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc)

    [IntSet]
results <- (Key -> PointsToAnalysis IntSet)
-> [Key] -> StateT MemLocPool Identity [IntSet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Key -> PointsToAnalysis IntSet
applySummary (IntSet -> [Key]
IntSet.toList IntSet
calleeLocs)
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions [IntSet]
results
evalExpr PointsToFact
_ PointsToContext ScopedId
_ Key
_ Node (Lexeme ScopedId)
_ = do
    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc) -- Default for unhandled expressions
-- Evaluates the left-hand side of an assignment to a set of memory locations.
evalLhsExpr :: PointsToFact -> PointsToContext ScopedId -> Int -> C.Node (C.Lexeme ScopedId) -> PointsToAnalysis IntSet
evalLhsExpr :: PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalLhsExpr PointsToFact
_ PointsToContext ScopedId
_ Key
_ (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid))) = do
    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
StackLoc ScopedId
sid)
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)
evalLhsExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.UnaryExpr UnaryOp
C.UopDeref Node (Lexeme ScopedId)
expr)) = PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
expr
evalLhsExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.MemberAccess Node (Lexeme ScopedId)
baseExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId{sidName :: ScopedId -> Text
sidName=Text
fName}))) = do
    IntSet
baseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalBaseExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    let baseMemLocs :: [MemLoc]
baseMemLocs = (Key -> MemLoc) -> [Key] -> [MemLoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
i -> MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
i (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)) (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)
    [IMemLoc]
fieldILocs <- (MemLoc -> PointsToAnalysis IMemLoc)
-> [MemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\MemLoc
base -> MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base Text
fName)) [MemLoc]
baseMemLocs
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ [Key] -> IntSet
IntSet.fromList ((IMemLoc -> Key) -> [IMemLoc] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map IMemLoc -> Key
unIMemLoc [IMemLoc]
fieldILocs)
evalLhsExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.PointerAccess Node (Lexeme ScopedId)
baseExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId{sidName :: ScopedId -> Text
sidName=Text
fName}))) = do
    IntSet
baseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    let baseMemLocs :: [MemLoc]
baseMemLocs = (Key -> MemLoc) -> [Key] -> [MemLoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
i -> MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
i (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)) (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)
    [IMemLoc]
fieldILocs <- (MemLoc -> PointsToAnalysis IMemLoc)
-> [MemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\MemLoc
base -> MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base Text
fName)) [MemLoc]
baseMemLocs
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ [Key] -> IntSet
IntSet.fromList ((IMemLoc -> Key) -> [IMemLoc] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map IMemLoc -> Key
unIMemLoc [IMemLoc]
fieldILocs)
evalLhsExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId (Fix (C.ArrayAccess Node (Lexeme ScopedId)
baseExpr Node (Lexeme ScopedId)
idxExpr)) = do
    IntSet
baseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalBaseExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
baseExpr
    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    let baseMemLocs :: [MemLoc]
baseMemLocs = (Key -> MemLoc) -> [Key] -> [MemLoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
i -> MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
i (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)) (IntSet -> [Key]
IntSet.toList IntSet
baseLocs)
    [IMemLoc]
fieldILocs <- case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
idxExpr of
        C.LiteralExpr LiteralType
C.Int (C.L AlexPosn
_ LexemeClass
_ ScopedId
idxLexeme) ->
            (MemLoc -> PointsToAnalysis IMemLoc)
-> [MemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\MemLoc
base -> MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base (ScopedId -> Text
sidName ScopedId
idxLexeme))) [MemLoc]
baseMemLocs
        NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> -- Non-constant index, smash the array.
            (MemLoc -> PointsToAnalysis IMemLoc)
-> [MemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\MemLoc
base -> MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
base Text
"[]")) [MemLoc]
baseMemLocs
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ [Key] -> IntSet
IntSet.fromList ((IMemLoc -> Key) -> [IMemLoc] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map IMemLoc -> Key
unIMemLoc [IMemLoc]
fieldILocs)
evalLhsExpr PointsToFact
_ PointsToContext ScopedId
_ Key
_ Node (Lexeme ScopedId)
_ = do
    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc
    IntSet -> PointsToAnalysis IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> PointsToAnalysis IntSet)
-> IntSet -> PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
iloc)

-- | A helper function to encapsulate the logic for handling a function call within the data flow analysis.
-- It resolves the callee, looks up or generates a summary, applies the summary's effects,
-- and returns the updated facts, any new work for the fixpoint solver, and the return value of the call.
handleFunctionCall :: PointsToContext ScopedId
                   -> ScopedId
                   -> Int
                   -> PointsToFact
                   -> C.Node (C.Lexeme ScopedId)
                   -> [C.Node (C.Lexeme ScopedId)]
                   -> PointsToAnalysis (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
handleFunctionCall :: PointsToContext ScopedId
-> ScopedId
-> Key
-> PointsToFact
-> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
handleFunctionCall PointsToContext ScopedId
ctx ScopedId
funcId Key
nodeId PointsToFact
facts Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args = do
    IntSet
calleeLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
calleeExpr
    let pos :: AlexPosn
pos = case Node (Lexeme ScopedId) -> Maybe (Lexeme ScopedId)
forall l. Node (Lexeme l) -> Maybe (Lexeme l)
getLexeme Node (Lexeme ScopedId)
calleeExpr of
            Just (C.L AlexPosn
p LexemeClass
_ ScopedId
_) -> AlexPosn
p
            Maybe (Lexeme ScopedId)
Nothing          -> Key -> Key -> Key -> AlexPosn
C.AlexPn Key
0 Key
0 Key
0

    MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
    IMemLoc
unknownLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc

    let processCall :: Key
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
processCall Key
ilocInt = do
            let loc :: MemLoc
loc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)
            case MemLoc
loc of
                GlobalVarLoc ScopedId
sid -> ScopedId
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
handleCall ScopedId
sid
                MemLoc
_                -> ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
facts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty), Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc))

        handleCall :: ScopedId
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
handleCall ScopedId
sid =
            if ScopedId -> Text
sidName ScopedId
sid Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"memcpy", Text
"memmove"] then do
                let destExpr :: Node (Lexeme ScopedId)
destExpr = [Node (Lexeme ScopedId)]
args [Node (Lexeme ScopedId)] -> Key -> Node (Lexeme ScopedId)
forall a. [a] -> Key -> a
!! Key
0
                let srcExpr :: Node (Lexeme ScopedId)
srcExpr = [Node (Lexeme ScopedId)]
args [Node (Lexeme ScopedId)] -> Key -> Node (Lexeme ScopedId)
forall a. [a] -> Key -> a
!! Key
1
                IntSet
destBaseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
destExpr
                IntSet
srcBaseLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
srcExpr

                -- Helper to replace the base of a memory location.
                let rebase :: MemLoc -> MemLoc -> MemLoc -> MemLoc
rebase MemLoc
oldBase MemLoc
newBase MemLoc
targetLoc =
                        if MemLoc
targetLoc MemLoc -> MemLoc -> Bool
forall a. Eq a => a -> a -> Bool
== MemLoc
oldBase
                        then MemLoc
newBase
                        else case MemLoc
targetLoc of
                            FieldLoc MemLoc
b Text
f -> MemLoc -> Text -> MemLoc
FieldLoc (MemLoc -> MemLoc -> MemLoc -> MemLoc
rebase MemLoc
oldBase MemLoc
newBase MemLoc
b) Text
f
                            MemLoc
_            -> MemLoc
targetLoc

                -- Helper to get all transitive fields of a base location.
                let getTransitiveFields :: IMemLoc -> MemLocPool -> [Key]
getTransitiveFields IMemLoc
baseIloc MemLocPool
p =
                        let immediate :: [Key]
immediate = IntSet -> [Key]
IntSet.toList (IntSet -> [Key]) -> IntSet -> [Key]
forall a b. (a -> b) -> a -> b
$ IntSet -> Key -> IntMap IntSet -> IntSet
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty (IMemLoc -> Key
unIMemLoc IMemLoc
baseIloc) (MemLocPool -> IntMap IntSet
fieldIndex MemLocPool
p)
                        in [Key]
immediate [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ (Key -> [Key]) -> [Key] -> [Key]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Key
f -> IMemLoc -> MemLocPool -> [Key]
getTransitiveFields (Key -> IMemLoc
IMemLoc Key
f) MemLocPool
p) [Key]
immediate

                -- Group sources by destination to handle multiple sources for one dest correctly.
                let destToSources :: IntMap [Key]
destToSources = ([Key] -> [Key] -> [Key]) -> [(Key, [Key])] -> IntMap [Key]
forall a. (a -> a -> a) -> [(Key, a)] -> IntMap a
IntMap.fromListWith [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
(++) [(Key
d, [Key
s]) | Key
d <- IntSet -> [Key]
IntSet.toList IntSet
destBaseLocs, Key
s <- IntSet -> [Key]
IntSet.toList IntSet
srcBaseLocs]

                IntMap IntSet
finalMemMap <- (IntMap IntSet
 -> (Key, [Key]) -> StateT MemLocPool Identity (IntMap IntSet))
-> IntMap IntSet
-> [(Key, [Key])]
-> StateT MemLocPool Identity (IntMap IntSet)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IntMap IntSet
accMem (Key
dIlocInt, [Key]
srcIlocInts) -> do
                    MemLocPool
currentPool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
                    let dLoc :: MemLoc
dLoc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
dIlocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
currentPool)

                    -- Compute all updates for this destination from all its sources.
                    IntMap IntSet
updatesForDest <- (IntMap IntSet
 -> Key -> StateT MemLocPool Identity (IntMap IntSet))
-> IntMap IntSet
-> [Key]
-> StateT MemLocPool Identity (IntMap IntSet)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IntMap IntSet
accUpdates Key
srcIlocInt -> do
                        let sLoc :: MemLoc
sLoc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
srcIlocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
currentPool)
                        -- Identify all source locations to copy (base + all transitive fields)
                        let allSrcIlocs :: [Key]
allSrcIlocs = Key
srcIlocInt Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: IMemLoc -> MemLocPool -> [Key]
getTransitiveFields (Key -> IMemLoc
IMemLoc Key
srcIlocInt) MemLocPool
currentPool

                        (IntMap IntSet
 -> Key -> StateT MemLocPool Identity (IntMap IntSet))
-> IntMap IntSet
-> [Key]
-> StateT MemLocPool Identity (IntMap IntSet)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IntMap IntSet
innerUpdates Key
srcFieldInt -> do
                            case Key -> IntMap IntSet -> Maybe IntSet
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
srcFieldInt (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts) of
                                Maybe IntSet
Nothing -> IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return IntMap IntSet
innerUpdates
                                Just IntSet
v -> do
                                    -- We need to re-get pool because intern might have run in previous iteration
                                    MemLocPool
p <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
                                    let srcFieldLoc :: MemLoc
srcFieldLoc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
srcFieldInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
p)
                                    let destFieldLoc :: MemLoc
destFieldLoc = MemLoc -> MemLoc -> MemLoc -> MemLoc
rebase MemLoc
sLoc MemLoc
dLoc MemLoc
srcFieldLoc
                                    IMemLoc
destFieldIloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
destFieldLoc
                                    IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet))
-> IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet)
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet -> IntSet)
-> Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
IntMap.insertWith IntSet -> IntSet -> IntSet
IntSet.union (IMemLoc -> Key
unIMemLoc IMemLoc
destFieldIloc) IntSet
v IntMap IntSet
innerUpdates
                            ) IntMap IntSet
accUpdates [Key]
allSrcIlocs
                        ) IntMap IntSet
forall a. IntMap a
IntMap.empty [Key]
srcIlocInts

                    -- Apply updates to accMem.
                    -- If we have a single destination base, we can perform a strong update (overwrite).
                    -- Otherwise, we must perform a weak update (merge).
                    if IntSet -> Key
IntSet.size IntSet
destBaseLocs Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
1
                        then IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet))
-> IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet)
forall a b. (a -> b) -> a -> b
$ IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. IntMap a -> IntMap a -> IntMap a
IntMap.union IntMap IntSet
updatesForDest IntMap IntSet
accMem -- Strong update: updates win
                        else IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet))
-> IntMap IntSet -> StateT MemLocPool Identity (IntMap IntSet)
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet -> IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith IntSet -> IntSet -> IntSet
IntSet.union IntMap IntSet
accMem IntMap IntSet
updatesForDest -- Weak update
                    ) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts) (IntMap [Key] -> [(Key, [Key])]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap [Key]
destToSources)

                let newFacts :: PointsToFact
newFacts = PointsToFact
facts { memMap :: IntMap IntSet
memMap = IntMap IntSet
finalMemMap }
                IntSet
memcpyRetLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
newFacts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
destExpr
                ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
newFacts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty), IntSet
memcpyRetLocs)

            else if ScopedId -> Text
sidName ScopedId
sid Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"getaddrinfo" then do
                let resExpr :: Node (Lexeme ScopedId)
resExpr = [Node (Lexeme ScopedId)]
args [Node (Lexeme ScopedId)] -> Key -> Node (Lexeme ScopedId)
forall a. [a] -> Key -> a
!! Key
3
                IntSet
resLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
resExpr
                IMemLoc
newHeapLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern (Text -> MemLoc
HeapLoc (String -> AlexPosn -> Text
locFromPos (PointsToContext ScopedId -> String
forall l. PointsToContext l -> String
pcFilePath PointsToContext ScopedId
ctx) AlexPosn
pos))
                let rhsLocs :: IntSet
rhsLocs = Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
newHeapLoc)
                MemLocPool
pool' <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
                let update :: Key -> PointsToFact -> PointsToFact
update Key
ilocInt PointsToFact
acc =
                        let loc :: MemLoc
loc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool')
                        in case MemLoc
loc of
                            StackLoc ScopedId
sid' -> PointsToFact
acc { varMap :: Map ScopedId IntSet
varMap = ScopedId -> IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopedId
sid' IntSet
rhsLocs (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
acc) }
                            MemLoc
_             -> PointsToFact
acc { memMap :: IntMap IntSet
memMap = Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
ilocInt IntSet
rhsLocs (PointsToFact -> IntMap IntSet
memMap PointsToFact
acc) }
                let newFacts :: PointsToFact
newFacts = (Key -> PointsToFact -> PointsToFact)
-> PointsToFact -> IntSet -> PointsToFact
forall b. (Key -> b -> b) -> b -> IntSet -> b
IntSet.foldr Key -> PointsToFact -> PointsToFact
update PointsToFact
facts IntSet
resLocs
                ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
newFacts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty), IntSet
IntSet.empty) -- Returns int
            else if ScopedId -> Text
sidName ScopedId
sid Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"inet_ntop" then do
                IntSet
inetNtopRetLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId ([Node (Lexeme ScopedId)]
args [Node (Lexeme ScopedId)] -> Key -> Node (Lexeme ScopedId)
forall a. [a] -> Key -> a
!! Key
2) -- dst
                ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
facts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty), IntSet
inetNtopRetLocs)
            else if ScopedId -> Text
sidName ScopedId
sid Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"strrchr" then do
                IntSet
strrchrRetLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId ([Node (Lexeme ScopedId)]
args [Node (Lexeme ScopedId)] -> Key -> Node (Lexeme ScopedId)
forall a. [a] -> Key -> a
!! Key
0) -- str
                ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
facts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty), IntSet
strrchrRetLocs)
            else
                case ScopedId -> Maybe ExternalSummary
getExternalSummary ScopedId
sid of
                    Just ExternalSummary
summary -> do
                        (Set MemLoc
summaryRetLocs, Bool
_) <- ExternalSummary
summary (PointsToContext ScopedId -> String
forall l. PointsToContext l -> String
pcFilePath PointsToContext ScopedId
ctx) AlexPosn
pos [Node (Lexeme ScopedId)]
args
                        [IMemLoc]
internedRetLocs <- (MemLoc -> PointsToAnalysis IMemLoc)
-> [MemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MemLoc -> PointsToAnalysis IMemLoc
intern (Set MemLoc -> [MemLoc]
forall a. Set a -> [a]
Set.toList Set MemLoc
summaryRetLocs)
                        ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
facts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty), [Key] -> IntSet
IntSet.fromList ((IMemLoc -> Key) -> [IMemLoc] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map IMemLoc -> Key
unIMemLoc [IMemLoc]
internedRetLocs))
                    Maybe ExternalSummary
Nothing -> -- No external summary
                        let funcMap :: Map ScopedId [Node (Lexeme ScopedId)]
funcMap = PointsToContext ScopedId -> Map ScopedId [Node (Lexeme ScopedId)]
forall l.
PointsToContext l -> Map ScopedId [Node (Lexeme ScopedId)]
pcFuncs PointsToContext ScopedId
ctx
                        in case ScopedId
-> Map ScopedId [Node (Lexeme ScopedId)]
-> Maybe [Node (Lexeme ScopedId)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
sid Map ScopedId [Node (Lexeme ScopedId)]
funcMap of
                            Just [Node (Lexeme ScopedId)]
_ -> do -- Internal function, proceed with context-sensitive analysis
                                let GlobalEnv Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
gEnv = PointsToContext ScopedId -> GlobalEnv
forall l. PointsToContext l -> GlobalEnv
pcGlobalEnv PointsToContext ScopedId
ctx
                                let calleeFuncs :: [Node (Lexeme ScopedId)]
calleeFuncs = [Node (Lexeme ScopedId)]
-> Maybe [Node (Lexeme ScopedId)] -> [Node (Lexeme ScopedId)]
forall a. a -> Maybe a -> a
fromMaybe (String -> [Node (Lexeme ScopedId)]
forall a. HasCallStack => String -> a
error (String -> [Node (Lexeme ScopedId)])
-> String -> [Node (Lexeme ScopedId)]
forall a b. (a -> b) -> a -> b
$ String
"Function AST not found for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedId -> String
forall a. Show a => a -> String
show ScopedId
sid) (ScopedId
-> Map ScopedId [Node (Lexeme ScopedId)]
-> Maybe [Node (Lexeme ScopedId)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
sid Map ScopedId [Node (Lexeme ScopedId)]
funcMap)
                                let calleeFunc :: Node (Lexeme ScopedId)
calleeFunc = [Node (Lexeme ScopedId)] -> Node (Lexeme ScopedId)
forall a. [a] -> a
head [Node (Lexeme ScopedId)]
calleeFuncs -- Assume first def is representative
                                let params :: [ScopedId]
params = Node (Lexeme ScopedId) -> [ScopedId]
getParams Node (Lexeme ScopedId)
calleeFunc
                                [IntSet]
argLocs <- (Node (Lexeme ScopedId) -> PointsToAnalysis IntSet)
-> [Node (Lexeme ScopedId)] -> StateT MemLocPool Identity [IntSet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId) [Node (Lexeme ScopedId)]
args
                                let initialVarMap :: Map ScopedId IntSet
initialVarMap = [(ScopedId, IntSet)] -> Map ScopedId IntSet
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScopedId, IntSet)] -> Map ScopedId IntSet)
-> [(ScopedId, IntSet)] -> Map ScopedId IntSet
forall a b. (a -> b) -> a -> b
$ [ScopedId] -> [IntSet] -> [(ScopedId, IntSet)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ScopedId]
params [IntSet]
argLocs

                                RelevantInputState
relevantState <- PointsToFact
-> Map ScopedId IntSet -> PointsToAnalysis RelevantInputState
extractRelevantState PointsToFact
facts Map ScopedId IntSet
initialVarMap

                                case (ScopedId, RelevantInputState)
-> Map
     (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
-> Maybe (FunctionSummary, PointsToFact)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopedId
sid, RelevantInputState
relevantState) Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
gEnv of
                                    Just (FunctionSummary
summary, PointsToFact
_) -> do
                                        (PointsToFact
updatedFacts, IntSet
summaryRetLocs) <- PointsToFact
-> FunctionSummary -> PointsToAnalysis (PointsToFact, IntSet)
applySummary PointsToFact
facts FunctionSummary
summary
                                        ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
updatedFacts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty), IntSet
summaryRetLocs)
                                    Maybe (FunctionSummary, PointsToFact)
Nothing ->
                                        ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
facts, (ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState)
forall a. a -> Set a
Set.singleton (ScopedId
sid, RelevantInputState
relevantState)), Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc))
                            Maybe [Node (Lexeme ScopedId)]
Nothing -> -- Truly external and unsummarized
                                ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PointsToFact
facts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty), Key -> IntSet
IntSet.singleton (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc))

        applySummary :: PointsToFact -> FunctionSummary -> PointsToAnalysis (PointsToFact, IntSet)
        applySummary :: PointsToFact
-> FunctionSummary -> PointsToAnalysis (PointsToFact, IntSet)
applySummary PointsToFact
currentFacts FunctionSummary
summary = do
            let ret :: IntSet
ret = FunctionSummary -> IntSet
fsReturnValue FunctionSummary
summary
            let paramEff :: Map Key IntSet
paramEff = FunctionSummary -> Map Key IntSet
fsParamEffects FunctionSummary
summary
            let memEff :: IntMap IntSet
memEff = FunctionSummary -> IntMap IntSet
fsMemEffects FunctionSummary
summary

            String -> StateT MemLocPool Identity ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> StateT MemLocPool Identity ())
-> String -> StateT MemLocPool Identity ()
forall a b. (a -> b) -> a -> b
$ String
"applySummary: current varMap: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map ScopedId IntSet -> String
forall a. Show a => a -> String
show (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
currentFacts)
            String -> StateT MemLocPool Identity ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> StateT MemLocPool Identity ())
-> String -> StateT MemLocPool Identity ()
forall a b. (a -> b) -> a -> b
$ String
"applySummary: memEff: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IntMap IntSet -> String
forall a. Show a => a -> String
show IntMap IntSet
memEff

            -- Apply memory effects WEAKLY to ensure soundness.
            let newMemMap :: IntMap IntSet
newMemMap = (IntSet -> IntSet -> IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith IntSet -> IntSet -> IntSet
IntSet.union IntMap IntSet
memEff (PointsToFact -> IntMap IntSet
memMap PointsToFact
currentFacts)

            -- Sync varMap from memEff WEAKLY, as StackLocs are in both.
            MemLocPool
currentPool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
            let newVarMap :: Map ScopedId IntSet
newVarMap = (Map ScopedId IntSet -> Key -> IntSet -> Map ScopedId IntSet)
-> Map ScopedId IntSet -> IntMap IntSet -> Map ScopedId IntSet
forall a b. (a -> Key -> b -> a) -> a -> IntMap b -> a
IntMap.foldlWithKey' (\Map ScopedId IntSet
acc Key
k IntSet
v ->
                    case Key -> IntMap MemLoc -> Maybe MemLoc
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup Key
k (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
currentPool) of
                        Just (StackLoc ScopedId
sid) -> (IntSet -> IntSet -> IntSet)
-> ScopedId -> IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith IntSet -> IntSet -> IntSet
IntSet.union ScopedId
sid IntSet
v Map ScopedId IntSet
acc
                        Maybe MemLoc
_ -> Map ScopedId IntSet
acc
                    ) (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
currentFacts) IntMap IntSet
memEff

            String -> StateT MemLocPool Identity ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> StateT MemLocPool Identity ())
-> String -> StateT MemLocPool Identity ()
forall a b. (a -> b) -> a -> b
$ String
"applySummary: newVarMap: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map ScopedId IntSet -> String
forall a. Show a => a -> String
show Map ScopedId IntSet
newVarMap

            let factsWithMemEffects :: PointsToFact
factsWithMemEffects = PointsToFact
currentFacts { memMap :: IntMap IntSet
memMap = IntMap IntSet
newMemMap, varMap :: Map ScopedId IntSet
varMap = Map ScopedId IntSet
newVarMap }

            -- Then, apply parameter effects on top of that.
            PointsToFact
updatedFacts <- (PointsToFact
 -> (Key, IntSet) -> StateT MemLocPool Identity PointsToFact)
-> PointsToFact
-> [(Key, IntSet)]
-> StateT MemLocPool Identity PointsToFact
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (PointsToFact
-> PointsToFact
-> (Key, IntSet)
-> StateT MemLocPool Identity PointsToFact
applyEffect PointsToFact
facts) PointsToFact
factsWithMemEffects (Map Key IntSet -> [(Key, IntSet)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Key IntSet
paramEff)
            (PointsToFact, IntSet) -> PointsToAnalysis (PointsToFact, IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
updatedFacts, IntSet
ret)

        applyEffect :: PointsToFact -> PointsToFact -> (Int, IntSet) -> PointsToAnalysis PointsToFact
        applyEffect :: PointsToFact
-> PointsToFact
-> (Key, IntSet)
-> StateT MemLocPool Identity PointsToFact
applyEffect PointsToFact
initialFacts PointsToFact
currentFacts (Key
argIdx, IntSet
newLocs)
            | IntSet -> Bool
IntSet.null IntSet
newLocs = PointsToFact -> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) a. Monad m => a -> m a
return PointsToFact
currentFacts
            | Bool
otherwise = do
                let argExpr :: Node (Lexeme ScopedId)
argExpr = [Node (Lexeme ScopedId)]
args [Node (Lexeme ScopedId)] -> Key -> Node (Lexeme ScopedId)
forall a. [a] -> Key -> a
!! Key
argIdx
                IntSet
argLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
initialFacts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
argExpr
                MemLocPool
pool' <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
                case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
argExpr of
                    C.UnaryExpr UnaryOp
C.UopAddress (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId
argSid))) -> do
                        let updatedMemMap :: IntMap IntSet
updatedMemMap = (IntMap IntSet -> Key -> IntMap IntSet)
-> IntMap IntSet -> IntSet -> IntMap IntSet
forall a. (a -> Key -> a) -> a -> IntSet -> a
IntSet.foldl' (\IntMap IntSet
acc Key
ilocInt -> Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
ilocInt IntSet
newLocs IntMap IntSet
acc) (PointsToFact -> IntMap IntSet
memMap PointsToFact
currentFacts) IntSet
argLocs
                        PointsToFact -> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact -> StateT MemLocPool Identity PointsToFact)
-> PointsToFact -> StateT MemLocPool Identity PointsToFact
forall a b. (a -> b) -> a -> b
$ PointsToFact
currentFacts { memMap :: IntMap IntSet
memMap = IntMap IntSet
updatedMemMap, varMap :: Map ScopedId IntSet
varMap = ScopedId -> IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopedId
argSid IntSet
newLocs (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
currentFacts) }
                    NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> do
                        let update :: Key -> PointsToFact -> PointsToFact
update Key
ilocInt PointsToFact
acc =
                                let acc' :: PointsToFact
acc' = PointsToFact
acc { memMap :: IntMap IntSet
memMap = Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
ilocInt IntSet
newLocs (PointsToFact -> IntMap IntSet
memMap PointsToFact
acc) }
                                    loc :: MemLoc
loc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool')
                                in case MemLoc
loc of
                                    StackLoc ScopedId
sid -> PointsToFact
acc' { varMap :: Map ScopedId IntSet
varMap = ScopedId -> IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopedId
sid IntSet
newLocs (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
acc') }
                                    MemLoc
_            -> PointsToFact
acc'
                        PointsToFact -> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact -> StateT MemLocPool Identity PointsToFact)
-> PointsToFact -> StateT MemLocPool Identity PointsToFact
forall a b. (a -> b) -> a -> b
$ (Key -> PointsToFact -> PointsToFact)
-> PointsToFact -> IntSet -> PointsToFact
forall b. (Key -> b -> b) -> b -> IntSet -> b
IntSet.foldr Key -> PointsToFact -> PointsToFact
update PointsToFact
currentFacts IntSet
argLocs

    [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
results <- (Key
 -> StateT
      MemLocPool
      Identity
      ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet))
-> [Key]
-> StateT
     MemLocPool
     Identity
     [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Key
-> StateT
     MemLocPool
     Identity
     ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
processCall (IntSet -> [Key]
IntSet.toList IntSet
calleeLocs)
    let unpackedResults :: [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
unpackedResults = [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
results
    let resultFacts :: [PointsToFact]
resultFacts = (((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
 -> PointsToFact)
-> [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
-> [PointsToFact]
forall a b. (a -> b) -> [a] -> [b]
map ((PointsToFact, Set (ScopedId, RelevantInputState)) -> PointsToFact
forall a b. (a, b) -> a
fst ((PointsToFact, Set (ScopedId, RelevantInputState))
 -> PointsToFact)
-> (((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
    -> (PointsToFact, Set (ScopedId, RelevantInputState)))
-> ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> PointsToFact
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> (PointsToFact, Set (ScopedId, RelevantInputState))
forall a b. (a, b) -> a
fst) [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
unpackedResults
    let resultEdges :: [Set (ScopedId, RelevantInputState)]
resultEdges = (((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
 -> Set (ScopedId, RelevantInputState))
-> [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
-> [Set (ScopedId, RelevantInputState)]
forall a b. (a -> b) -> [a] -> [b]
map ((PointsToFact, Set (ScopedId, RelevantInputState))
-> Set (ScopedId, RelevantInputState)
forall a b. (a, b) -> b
snd ((PointsToFact, Set (ScopedId, RelevantInputState))
 -> Set (ScopedId, RelevantInputState))
-> (((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
    -> (PointsToFact, Set (ScopedId, RelevantInputState)))
-> ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> Set (ScopedId, RelevantInputState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> (PointsToFact, Set (ScopedId, RelevantInputState))
forall a b. (a, b) -> a
fst) [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
unpackedResults
    let resultRetLocs :: [IntSet]
resultRetLocs = (((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
 -> IntSet)
-> [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
-> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map ((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)
-> IntSet
forall a b. (a, b) -> b
snd [((PointsToFact, Set (ScopedId, RelevantInputState)), IntSet)]
unpackedResults

    PointsToFact
finalFacts <- if [PointsToFact] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PointsToFact]
resultFacts then PointsToFact -> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) a. Monad m => a -> m a
return PointsToFact
facts else (PointsToFact
 -> PointsToFact -> StateT MemLocPool Identity PointsToFact)
-> PointsToFact
-> [PointsToFact]
-> StateT MemLocPool Identity PointsToFact
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (PointsToContext ScopedId
-> PointsToFact
-> PointsToFact
-> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) (c :: * -> *) l a callCtx.
DataFlow m c l a callCtx =>
c l -> a -> a -> m a
join PointsToContext ScopedId
ctx) ([PointsToFact] -> PointsToFact
forall a. [a] -> a
head [PointsToFact]
resultFacts) ([PointsToFact] -> [PointsToFact]
forall a. [a] -> [a]
tail [PointsToFact]
resultFacts)
    let finalEdges :: Set (ScopedId, RelevantInputState)
finalEdges = [Set (ScopedId, RelevantInputState)]
-> Set (ScopedId, RelevantInputState)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set (ScopedId, RelevantInputState)]
resultEdges
    let retLocs :: IntSet
retLocs = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions [IntSet]
resultRetLocs
    (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
finalFacts, Set (ScopedId, RelevantInputState)
finalEdges, IntSet
retLocs)

instance DataFlow PointsToAnalysis PointsToContext ScopedId PointsToFact RelevantInputState where
    emptyFacts :: PointsToContext ScopedId -> StateT MemLocPool Identity PointsToFact
emptyFacts PointsToContext ScopedId
_ = PointsToFact -> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact -> StateT MemLocPool Identity PointsToFact)
-> PointsToFact -> StateT MemLocPool Identity PointsToFact
forall a b. (a -> b) -> a -> b
$ Map ScopedId IntSet -> IntMap IntSet -> IntSet -> PointsToFact
PointsToFact Map ScopedId IntSet
forall k a. Map k a
Map.empty IntMap IntSet
forall a. IntMap a
IntMap.empty IntSet
IntSet.empty

    transfer :: PointsToContext ScopedId
-> ScopedId
-> Key
-> PointsToFact
-> Node (Lexeme ScopedId)
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
transfer PointsToContext ScopedId
ctx ScopedId
funcId Key
nodeId PointsToFact
facts stmt :: Node (Lexeme ScopedId)
stmt@(Fix NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
s') = do
        let traceMsg :: String
traceMsg = String
"transfer: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (ScopedId -> Text
sidName ScopedId
funcId) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NodeF (Lexeme ScopedId) () -> String
forall a. Show a => a -> String
show ((Node (Lexeme ScopedId) -> ())
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
-> NodeF (Lexeme ScopedId) ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Node (Lexeme ScopedId) -> ()
forall a b. a -> b -> a
const ()) NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
s')
        (PointsToFact
facts', Set (ScopedId, RelevantInputState)
newEdges) <- case NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
s' of
            C.VarDeclStmt (Fix (C.VarDecl Node (Lexeme ScopedId)
_ (C.L AlexPosn
_ LexemeClass
_ ScopedId
lhsSid) [Node (Lexeme ScopedId)]
_)) (Just Node (Lexeme ScopedId)
rhs) ->
                let
                    handleTheCall :: Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
handleTheCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args = do
                        (PointsToFact
finalFacts, Set (ScopedId, RelevantInputState)
finalEdges, IntSet
retLocs) <- PointsToContext ScopedId
-> ScopedId
-> Key
-> PointsToFact
-> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
handleFunctionCall PointsToContext ScopedId
ctx ScopedId
funcId Key
nodeId PointsToFact
facts Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                        (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
finalFacts { varMap :: Map ScopedId IntSet
varMap = ScopedId -> IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopedId
lhsSid IntSet
retLocs (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
finalFacts) }, Set (ScopedId, RelevantInputState)
finalEdges)
                in
                    case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
rhs of
                        C.CastExpr Node (Lexeme ScopedId)
_ (Fix (C.FunctionCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args)) -> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
handleTheCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                        C.FunctionCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args                  -> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
handleTheCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                        NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> do
                            IntSet
locs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
rhs
                            (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
facts { varMap :: Map ScopedId IntSet
varMap = ScopedId -> IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopedId
lhsSid IntSet
locs (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
facts) }, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty)

            C.ExprStmt (Fix (C.AssignExpr Node (Lexeme ScopedId)
lhs AssignOp
_ Node (Lexeme ScopedId)
rhs)) ->
                let
                    handleTheCall :: Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
handleTheCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args = do
                        (PointsToFact
factsAfterCall, Set (ScopedId, RelevantInputState)
finalEdges, IntSet
retLocs) <- PointsToContext ScopedId
-> ScopedId
-> Key
-> PointsToFact
-> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
handleFunctionCall PointsToContext ScopedId
ctx ScopedId
funcId Key
nodeId PointsToFact
facts Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                        IntSet
lhsLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalLhsExpr PointsToFact
factsAfterCall PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
lhs
                        -- Need to properly check for UnknownLoc.
                        IMemLoc
unknownLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc
                        let newUnknowns' :: IntSet
newUnknowns' = if Key -> IntSet -> Bool
IntSet.member (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc) IntSet
lhsLocs
                                           then PointsToFact -> IntSet
unknownWrites PointsToFact
factsAfterCall IntSet -> IntSet -> IntSet
`IntSet.union` IntSet
retLocs
                                           else PointsToFact -> IntSet
unknownWrites PointsToFact
factsAfterCall

                        MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
                        let update :: Key -> PointsToFact -> PointsToFact
update Key
ilocInt PointsToFact
acc =
                                let acc' :: PointsToFact
acc' = PointsToFact
acc { memMap :: IntMap IntSet
memMap = Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
ilocInt IntSet
retLocs (PointsToFact -> IntMap IntSet
memMap PointsToFact
acc) }
                                in case MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool) of
                                    StackLoc ScopedId
sid -> PointsToFact
acc' { varMap :: Map ScopedId IntSet
varMap = ScopedId -> IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopedId
sid IntSet
retLocs (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
acc') }
                                    MemLoc
_            -> PointsToFact
acc'
                        (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Key -> PointsToFact -> PointsToFact)
-> PointsToFact -> IntSet -> PointsToFact
forall b. (Key -> b -> b) -> b -> IntSet -> b
IntSet.foldr Key -> PointsToFact -> PointsToFact
update (PointsToFact
factsAfterCall { unknownWrites :: IntSet
unknownWrites = IntSet
newUnknowns' }) IntSet
lhsLocs, Set (ScopedId, RelevantInputState)
finalEdges)
                in
                    case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
rhs of
                        C.CastExpr Node (Lexeme ScopedId)
_ (Fix (C.FunctionCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args)) -> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
handleTheCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                        C.FunctionCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args -> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
handleTheCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                        NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> do
                            IntSet
lhsLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalLhsExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
lhs
                            IntSet
rhsLocs <- PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
rhs
                            IMemLoc
unknownLoc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc
                            let newUnknowns :: IntSet
newUnknowns = if Key -> IntSet -> Bool
IntSet.member (IMemLoc -> Key
unIMemLoc IMemLoc
unknownLoc) IntSet
lhsLocs
                                        then PointsToFact -> IntSet
unknownWrites PointsToFact
facts IntSet -> IntSet -> IntSet
`IntSet.union` IntSet
rhsLocs
                                        else PointsToFact -> IntSet
unknownWrites PointsToFact
facts

                            MemLocPool
pool <- StateT MemLocPool Identity MemLocPool
forall s (m :: * -> *). MonadState s m => m s
get
                            -- Check if this assignment is to a union field.
                            let isUnionAssignment :: Bool
isUnionAssignment = (Key -> Bool) -> [Key] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Key
ilocInt ->
                                    case MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool) of
                                        FieldLoc (StackLoc ScopedId
sid) Text
_ ->
                                            case ScopedId
-> Map ScopedId (Node (Lexeme ScopedId))
-> Maybe (Node (Lexeme ScopedId))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
sid (PointsToContext ScopedId -> Map ScopedId (Node (Lexeme ScopedId))
forall l.
PointsToContext l -> Map ScopedId (Node (Lexeme ScopedId))
pcVarTypes PointsToContext ScopedId
ctx) of
                                                Just Node (Lexeme ScopedId)
tyNode -> case Node (Lexeme ScopedId) -> Maybe Text
getTypeName Node (Lexeme ScopedId)
tyNode of
                                                    Just Text
typeName -> case Text -> TypeSystem -> Maybe TypeDescr
lookupType Text
typeName (PointsToContext ScopedId -> TypeSystem
forall l. PointsToContext l -> TypeSystem
pcTypeSystem PointsToContext ScopedId
ctx) of
                                                        Just (UnionDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)]
_) -> Bool
True
                                                        Maybe TypeDescr
_                     -> Bool
False
                                                    Maybe Text
_ -> Bool
False
                                                Maybe (Node (Lexeme ScopedId))
_ -> Bool
False
                                        MemLoc
_ -> Bool
False
                                    ) (IntSet -> [Key]
IntSet.toList IntSet
lhsLocs)

                            PointsToFact
updatedFacts <-
                                if Bool
isUnionAssignment then
                                    -- Handle union assignment atomically.
                                    let
                                        -- We only need one FieldLoc to find the base and all sibling fields.
                                        oneFieldLocInt :: Key
oneFieldLocInt = if IntSet -> Bool
IntSet.null IntSet
lhsLocs then String -> Key
forall a. HasCallStack => String -> a
error String
"LHS of union assignment is empty" else IntSet -> Key
IntSet.findMin IntSet
lhsLocs
                                        oneFieldLoc :: MemLoc
oneFieldLoc = MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
oneFieldLocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool)
                                    in do
                                        [IMemLoc]
allFieldsToUpdate <- case MemLoc
oneFieldLoc of
                                            FieldLoc baseLoc :: MemLoc
baseLoc@(StackLoc ScopedId
sid) Text
_ ->
                                                case ScopedId
-> Map ScopedId (Node (Lexeme ScopedId))
-> Maybe (Node (Lexeme ScopedId))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
sid (PointsToContext ScopedId -> Map ScopedId (Node (Lexeme ScopedId))
forall l.
PointsToContext l -> Map ScopedId (Node (Lexeme ScopedId))
pcVarTypes PointsToContext ScopedId
ctx) of
                                                    Just Node (Lexeme ScopedId)
tyNode -> case Node (Lexeme ScopedId) -> Maybe Text
getTypeName Node (Lexeme ScopedId)
tyNode of
                                                        Just Text
typeName -> case Text -> TypeSystem -> Maybe TypeDescr
lookupType Text
typeName (PointsToContext ScopedId -> TypeSystem
forall l. PointsToContext l -> TypeSystem
pcTypeSystem PointsToContext ScopedId
ctx) of
                                                            Just (UnionDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)]
fields) -> do
                                                                let allFieldNames :: [Text]
allFieldNames = ((Lexeme Text, TypeInfo) -> Text)
-> [(Lexeme Text, TypeInfo)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Lexeme Text -> Text
forall text. Lexeme text -> text
C.lexemeText (Lexeme Text -> Text)
-> ((Lexeme Text, TypeInfo) -> Lexeme Text)
-> (Lexeme Text, TypeInfo)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> Lexeme Text
forall a b. (a, b) -> a
fst) [(Lexeme Text, TypeInfo)]
fields
                                                                (Text -> PointsToAnalysis IMemLoc)
-> [Text] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Text
fName -> MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc MemLoc
baseLoc Text
fName)) [Text]
allFieldNames
                                                            Maybe TypeDescr
_ -> [IMemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (m :: * -> *) a. Monad m => a -> m a
return [Key -> IMemLoc
IMemLoc Key
oneFieldLocInt]
                                                        Maybe Text
_ -> [IMemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (m :: * -> *) a. Monad m => a -> m a
return [Key -> IMemLoc
IMemLoc Key
oneFieldLocInt]
                                                    Maybe (Node (Lexeme ScopedId))
_ -> [IMemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (m :: * -> *) a. Monad m => a -> m a
return [Key -> IMemLoc
IMemLoc Key
oneFieldLocInt]
                                            MemLoc
_ -> [IMemLoc] -> StateT MemLocPool Identity [IMemLoc]
forall (m :: * -> *) a. Monad m => a -> m a
return [Key -> IMemLoc
IMemLoc Key
oneFieldLocInt]

                                        let updatedMemMap :: IntMap IntSet
updatedMemMap = (IntMap IntSet -> IMemLoc -> IntMap IntSet)
-> IntMap IntSet -> [IMemLoc] -> IntMap IntSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntMap IntSet
m IMemLoc
iloc -> Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert (IMemLoc -> Key
unIMemLoc IMemLoc
iloc) IntSet
rhsLocs IntMap IntSet
m) (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts) [IMemLoc]
allFieldsToUpdate
                                        PointsToFact -> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact -> StateT MemLocPool Identity PointsToFact)
-> PointsToFact -> StateT MemLocPool Identity PointsToFact
forall a b. (a -> b) -> a -> b
$ PointsToFact
facts { memMap :: IntMap IntSet
memMap = IntMap IntSet
updatedMemMap, unknownWrites :: IntSet
unknownWrites = IntSet
newUnknowns }
                                else
                                    -- Use the original fold for non-union assignments.
                                    let
                                        update :: Key -> PointsToFact -> PointsToFact
update Key
ilocInt PointsToFact
acc =
                                            let acc' :: PointsToFact
acc' = PointsToFact
acc { memMap :: IntMap IntSet
memMap = Key -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
ilocInt IntSet
rhsLocs (PointsToFact -> IntMap IntSet
memMap PointsToFact
acc) }
                                            in case MemLoc -> Key -> IntMap MemLoc -> MemLoc
forall a. a -> Key -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Key
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool) of
                                                StackLoc ScopedId
sid -> PointsToFact
acc' { varMap :: Map ScopedId IntSet
varMap = ScopedId -> IntSet -> Map ScopedId IntSet -> Map ScopedId IntSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ScopedId
sid IntSet
rhsLocs (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
acc') }
                                                MemLoc
_            -> PointsToFact
acc'
                                    in
                                        PointsToFact -> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact -> StateT MemLocPool Identity PointsToFact)
-> PointsToFact -> StateT MemLocPool Identity PointsToFact
forall a b. (a -> b) -> a -> b
$ (Key -> PointsToFact -> PointsToFact)
-> PointsToFact -> IntSet -> PointsToFact
forall b. (Key -> b -> b) -> b -> IntSet -> b
IntSet.foldr Key -> PointsToFact -> PointsToFact
update (PointsToFact
facts { unknownWrites :: IntSet
unknownWrites = IntSet
newUnknowns }) IntSet
lhsLocs
                            (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
updatedFacts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty)

            C.ExprStmt (Fix (C.FunctionCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args)) -> do
                (PointsToFact
finalFacts, Set (ScopedId, RelevantInputState)
finalEdges, IntSet
_) <- PointsToContext ScopedId
-> ScopedId
-> Key
-> PointsToFact
-> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
handleFunctionCall PointsToContext ScopedId
ctx ScopedId
funcId Key
nodeId PointsToFact
facts Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
finalFacts, Set (ScopedId, RelevantInputState)
finalEdges)

            C.Return (Just Node (Lexeme ScopedId)
expr) -> do
                let
                    -- The return value itself is handled by the fixpoint driver by inspecting
                    -- the exit node's facts. Here, we just need to ensure that if the return
                    -- expression contains a function call, we generate the necessary work for it.
                    PointsToAnalysis IntSet
_ = PointsToFact
-> PointsToContext ScopedId
-> Key
-> Node (Lexeme ScopedId)
-> PointsToAnalysis IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Key
nodeId Node (Lexeme ScopedId)
expr
                case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
expr of
                    C.FunctionCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args -> do
                        (PointsToFact
finalFacts, Set (ScopedId, RelevantInputState)
finalEdges, IntSet
_) <- PointsToContext ScopedId
-> ScopedId
-> Key
-> PointsToFact
-> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
handleFunctionCall PointsToContext ScopedId
ctx ScopedId
funcId Key
nodeId PointsToFact
facts Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                        (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
finalFacts, Set (ScopedId, RelevantInputState)
finalEdges)
                    C.CastExpr Node (Lexeme ScopedId)
_ (Fix (C.FunctionCall Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args)) -> do
                        (PointsToFact
finalFacts, Set (ScopedId, RelevantInputState)
finalEdges, IntSet
_) <- PointsToContext ScopedId
-> ScopedId
-> Key
-> PointsToFact
-> Node (Lexeme ScopedId)
-> [Node (Lexeme ScopedId)]
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState), IntSet)
handleFunctionCall PointsToContext ScopedId
ctx ScopedId
funcId Key
nodeId PointsToFact
facts Node (Lexeme ScopedId)
calleeExpr [Node (Lexeme ScopedId)]
args
                        (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
finalFacts, Set (ScopedId, RelevantInputState)
finalEdges)
                    NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
facts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty)

            NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact
facts, Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty)
        (PointsToFact, Set (ScopedId, RelevantInputState))
-> PointsToAnalysis
     (PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> PointsToFact -> PointsToFact
forall a. String -> a -> a
dtrace (String
traceMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  facts': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PointsToFact -> String
forall a. Show a => a -> String
show PointsToFact
facts') PointsToFact
facts', Set (ScopedId, RelevantInputState)
newEdges)

    join :: PointsToContext ScopedId
-> PointsToFact
-> PointsToFact
-> StateT MemLocPool Identity PointsToFact
join PointsToContext ScopedId
_ (PointsToFact Map ScopedId IntSet
vm1 IntMap IntSet
mm1 IntSet
uw1) (PointsToFact Map ScopedId IntSet
vm2 IntMap IntSet
mm2 IntSet
uw2) =
        PointsToFact -> StateT MemLocPool Identity PointsToFact
forall (m :: * -> *) a. Monad m => a -> m a
return (PointsToFact -> StateT MemLocPool Identity PointsToFact)
-> PointsToFact -> StateT MemLocPool Identity PointsToFact
forall a b. (a -> b) -> a -> b
$ Map ScopedId IntSet -> IntMap IntSet -> IntSet -> PointsToFact
PointsToFact ((IntSet -> IntSet -> IntSet)
-> Map ScopedId IntSet
-> Map ScopedId IntSet
-> Map ScopedId IntSet
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith IntSet -> IntSet -> IntSet
IntSet.union Map ScopedId IntSet
vm1 Map ScopedId IntSet
vm2)
                     ((IntSet -> IntSet -> IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith IntSet -> IntSet -> IntSet
IntSet.union IntMap IntSet
mm1 IntMap IntSet
mm2)
                     (IntSet -> IntSet -> IntSet
IntSet.union IntSet
uw1 IntSet
uw2)

getParams :: C.Node (C.Lexeme ScopedId) -> [ScopedId]
getParams :: Node (Lexeme ScopedId) -> [ScopedId]
getParams (Fix (C.FunctionDefn Scope
_ (Fix (C.FunctionPrototype Node (Lexeme ScopedId)
_ Lexeme ScopedId
_ [Node (Lexeme ScopedId)]
params)) Node (Lexeme ScopedId)
_)) =
    (Node (Lexeme ScopedId) -> Maybe ScopedId)
-> [Node (Lexeme ScopedId)] -> [ScopedId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme ScopedId) -> Maybe ScopedId
forall a. Fix (NodeF (Lexeme a)) -> Maybe a
getParamId [Node (Lexeme ScopedId)]
params
  where
    getParamId :: Fix (NodeF (Lexeme a)) -> Maybe a
getParamId (Fix (C.VarDecl Fix (NodeF (Lexeme a))
_ (C.L AlexPosn
_ LexemeClass
_ a
sid) [Fix (NodeF (Lexeme a))]
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
sid
    getParamId Fix (NodeF (Lexeme a))
_                                   = Maybe a
forall a. Maybe a
Nothing
getParams Node (Lexeme ScopedId)
_ = []

getTypeName :: C.Node (C.Lexeme ScopedId) -> Maybe Text
getTypeName :: Node (Lexeme ScopedId) -> Maybe Text
getTypeName (Fix NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
node) = case NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
node of
    C.TyUserDefined (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (ScopedId -> Text
sidName ScopedId
sid)
    C.TyStruct (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid)      -> Text -> Maybe Text
forall a. a -> Maybe a
Just (ScopedId -> Text
sidName ScopedId
sid)
    C.TyUnion (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid)       -> Text -> Maybe Text
forall a. a -> Maybe a
Just (ScopedId -> Text
sidName ScopedId
sid)
    C.TyConst Node (Lexeme ScopedId)
t                   -> Node (Lexeme ScopedId) -> Maybe Text
getTypeName Node (Lexeme ScopedId)
t
    NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_                             -> Maybe Text
forall a. Maybe a
Nothing