{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeSynonymInstances  #-}
-- | This module implements an inter-procedural, context-sensitive, summary-based
-- points-to analysis for C code.
--
-- The analysis determines the set of abstract memory locations that each pointer
-- variable could point to at any given program point. This is a foundational
-- analysis required for many subsequent static analyses, such as taint tracking.
--
-- The core algorithm works as follows:
-- 1.  **AST Traversal**: It first traverses the Abstract Syntax Tree (AST) of the
--     entire program to find all function definitions and declarations.
-- 2.  **Worklist Algorithm**: It uses a worklist algorithm to iteratively analyze
--     functions until a fixed point is reached. The worklist contains pairs of
--     (FunctionName, Context), ensuring that functions are re-analyzed if their
--     calling context changes.
-- 3.  **Intra-procedural Analysis**: For each function, it performs a standard
--     forward dataflow analysis over its Control Flow Graph (CFG). The state
--     (or "facts") at each point is a `PointsToMap`, which maps abstract
--     locations to the set of locations they point to.
-- 4.  **Function Summaries**: After analyzing a function, it generates a
--     `PointsToSummary`. This summary captures the function's effect on pointers,
--     including what it returns and what side effects it has on pointers passed
--     as arguments. This is the key to scalability, as it avoids re-analyzing
--     a function's body at every call site.
-- 5.  **Context Sensitivity**: The analysis is context-sensitive, meaning it can
--     distinguish between different call sites of the same function. The `Context`
--     is a list of node IDs (hashes) representing the call stack. This allows for
--     more precise summaries and handling of recursion.
-- 6.  **Fixed-Point Iteration**: The worklist algorithm continues until the
--     summaries for all functions stabilize (i.e., no longer change). When a
--     function's summary changes, all of its callers are added back to the
--     worklist to be re-analyzed with the updated information. This process
--     guarantees that the analysis correctly handles complex interactions,
--     including mutual recursion.
module Tokstyle.Analysis.PointsTo
    ( PointsToMap
    , PointsToContext(..)
    , PointsToState(..)
    , PointsToSummary
    , PointsToSummaryData(..)
    , MacroDefinitionMap
    , buildPointsToContext
    , analyzeFunctionWithSummaries
    , toAbstractLocation
    , analyzeStatementForPointers -- Export for testing
    , fixpointSummaries
    , evalPointsToSet
    , transferPointsToState
    ) where

import           Control.Monad               (when)
import           Control.Monad.State.Strict  (State, evalState, execState, get,
                                              modify, put)
import           Data.Fix                    (Fix (..), foldFix)
import           Data.Foldable               (asum, foldl')
import           Data.List                   (find, findIndex)
import           Data.Map.Strict             (Map)
import qualified Data.Map.Strict             as Map
import           Data.Maybe                  (fromJust, fromMaybe, isJust,
                                              mapMaybe)
import           Data.Set                    (Set)
import qualified Data.Set                    as Set
import           Data.Text                   (Text)
import qualified Data.Text                   as T
import           Debug.Trace                 (trace, traceShow)
import qualified Language.Cimple             as C
import           Language.Cimple.TraverseAst (AstActions (..), astActions,
                                              traverseAst)
import           Text.Groom                  (groom)
import           Tokstyle.Analysis.Context   (kLimit, pushContext)
import           Tokstyle.Analysis.DataFlow
import           Tokstyle.Analysis.Types     (AbstractLocation (..), CallGraph,
                                              CallSite (..), CallType (..),
                                              Context, FunctionName,
                                              PointsToMap, PointsToSummary,
                                              PointsToSummaryData (..),
                                              getCallers, lookupOrError,
                                              toAbstractLocation)
import           Tokstyle.Worklist

fakeTestSource :: FilePath
fakeTestSource :: FilePath
fakeTestSource = FilePath
"test.c"

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

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

-- | A map from a macro's name to its AST definition node.
type MacroDefinitionMap = Map FunctionName (C.Node (C.Lexeme Text))

-- | The state for the points-to analysis, including the points-to map and
-- the set of currently defined macros.
data PointsToState = PointsToState
    { PointsToState -> PointsToMap
ptsMap    :: PointsToMap
    , PointsToState -> MacroDefinitionMap
ptsMacros :: MacroDefinitionMap
    } deriving (PointsToState -> PointsToState -> Bool
(PointsToState -> PointsToState -> Bool)
-> (PointsToState -> PointsToState -> Bool) -> Eq PointsToState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PointsToState -> PointsToState -> Bool
$c/= :: PointsToState -> PointsToState -> Bool
== :: PointsToState -> PointsToState -> Bool
$c== :: PointsToState -> PointsToState -> Bool
Eq, Int -> PointsToState -> ShowS
[PointsToState] -> ShowS
PointsToState -> FilePath
(Int -> PointsToState -> ShowS)
-> (PointsToState -> FilePath)
-> ([PointsToState] -> ShowS)
-> Show PointsToState
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PointsToState] -> ShowS
$cshowList :: [PointsToState] -> ShowS
show :: PointsToState -> FilePath
$cshow :: PointsToState -> FilePath
showsPrec :: Int -> PointsToState -> ShowS
$cshowsPrec :: Int -> PointsToState -> ShowS
Show)

-- | The context for the inter-procedural analysis. This data structure holds
-- all the global information needed while analyzing the program.
data PointsToContext l = PointsToContext
    { -- | The global call graph of the program. This is initially built from
      -- direct calls and is updated dynamically as function pointers are resolved.
      PointsToContext l -> CallGraph
ptcCallGraph        :: CallGraph
      -- | The current, evolving map of summaries for all functions. This is the
      -- central piece of state for the summary-based analysis. It's a map from
      -- function names to another map from calling contexts to the summary for
      -- that specific context.
    , PointsToContext l -> Map FunctionName PointsToSummary
ptcSummaries        :: Map FunctionName PointsToSummary
      -- | A map from function names to their AST definitions. Used to find the
      -- code for a function when it needs to be analyzed.
    , PointsToContext l -> MacroDefinitionMap
ptcFuncDefs         :: FunctionDefs
      -- | A map from function names to their AST declarations (or definitions).
      -- Used to check if an identifier is a function.
    , PointsToContext l -> MacroDefinitionMap
ptcFuncDecls        :: FunctionDefs
      -- | A map from struct/union names to their AST definitions.
    , PointsToContext l -> Map FunctionName (Node (Lexeme l))
ptcStructDefs       :: Map Text (C.Node (C.Lexeme l))
      -- | A map from variable names to their type AST nodes for the current scope.
    , PointsToContext l -> Map FunctionName (Node (Lexeme l))
ptcVarTypes         :: Map Text (C.Node (C.Lexeme l))
      -- | The current call stack context, used for context-sensitive analysis.
    , PointsToContext l -> Context
ptcCurrentContext   :: Context
      -- | A dynamically constructed call graph that tracks calls discovered
      -- during the analysis (e.g., through function pointers). This is more
      -- precise than the initial, static call graph.
    , PointsToContext l
-> Map (FunctionName, Context) (Set (FunctionName, Context))
ptcDynamicCallGraph :: Map (FunctionName, Context) (Set (FunctionName, Context))
      -- | A cache of the Control Flow Graphs (CFGs) that have been analyzed.
      -- This avoids rebuilding the CFG for the same function and context pair.
    , PointsToContext l
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
ptcAnalyzedCfgs     :: Map (FunctionName, Context) (CFG Text PointsToState)
      -- | The set of local variables (including parameters) for the function
      -- currently being analyzed. This is crucial for distinguishing between
      -- local and global variables.
    , PointsToContext l -> Set FunctionName
ptcLocalVars        :: Set Text
    , PointsToContext l -> MacroDefinitionMap
ptcFileMacros       :: MacroDefinitionMap
    }

-- | The PointsTo analysis is an instance of the generic DataFlow framework.
instance DataFlow PointsToContext Text PointsToState where
    emptyFacts :: PointsToContext FunctionName -> PointsToState
emptyFacts PointsToContext FunctionName
_ = PointsToMap -> MacroDefinitionMap -> PointsToState
PointsToState PointsToMap
forall k a. Map k a
Map.empty MacroDefinitionMap
forall k a. Map k a
Map.empty

    join :: PointsToContext FunctionName
-> PointsToState -> PointsToState -> PointsToState
join PointsToContext FunctionName
_ (PointsToState PointsToMap
map1 MacroDefinitionMap
macros1) (PointsToState PointsToMap
map2 MacroDefinitionMap
macros2) =
        PointsToState :: PointsToMap -> MacroDefinitionMap -> PointsToState
PointsToState
            { ptsMap :: PointsToMap
ptsMap = (Set AbstractLocation
 -> Set AbstractLocation -> Set AbstractLocation)
-> PointsToMap -> PointsToMap -> PointsToMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union PointsToMap
map1 PointsToMap
map2
            , ptsMacros :: MacroDefinitionMap
ptsMacros = MacroDefinitionMap -> MacroDefinitionMap -> MacroDefinitionMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union MacroDefinitionMap
macros1 MacroDefinitionMap
macros2
            }

    transfer :: PointsToContext FunctionName
-> FunctionName
-> PointsToState
-> Node (Lexeme FunctionName)
-> (PointsToState, Set (FunctionName, Context))
transfer = PointsToContext FunctionName
-> FunctionName
-> PointsToState
-> Node (Lexeme FunctionName)
-> (PointsToState, Set (FunctionName, Context))
transferPointsToState

-- | The new top-level transfer function. It inspects the current statement
-- and either updates the macro map or delegates to the existing points-to logic.
transferPointsToState :: PointsToContext Text -> FunctionName -> PointsToState -> C.Node (C.Lexeme Text) -> (PointsToState, Set (FunctionName, Context))
transferPointsToState :: PointsToContext FunctionName
-> FunctionName
-> PointsToState
-> Node (Lexeme FunctionName)
-> (PointsToState, Set (FunctionName, Context))
transferPointsToState PointsToContext FunctionName
ctx FunctionName
funcName PointsToState
currentState Node (Lexeme FunctionName)
stmt =
    case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
stmt of
        -- A macro is defined. Add it to the current state's macro map.
        C.PreprocDefineMacro (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_ Node (Lexeme FunctionName)
_ ->
            let newMacros :: MacroDefinitionMap
newMacros = FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
stmt (PointsToState -> MacroDefinitionMap
ptsMacros PointsToState
currentState)
            in FilePath
-> (PointsToState, Set (FunctionName, Context))
-> (PointsToState, Set (FunctionName, Context))
forall a. FilePath -> a -> a
dtrace (FilePath
"Defining macro: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
name) (PointsToState
currentState { ptsMacros :: MacroDefinitionMap
ptsMacros = MacroDefinitionMap
newMacros }, Set (FunctionName, Context)
forall a. Set a
Set.empty)

        -- A macro is undefined. Remove it from the current state's macro map.
        C.PreprocUndef (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) ->
            let newMacros :: MacroDefinitionMap
newMacros = FunctionName -> MacroDefinitionMap -> MacroDefinitionMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FunctionName
name (PointsToState -> MacroDefinitionMap
ptsMacros PointsToState
currentState)
            in (PointsToState
currentState { ptsMacros :: MacroDefinitionMap
ptsMacros = MacroDefinitionMap
newMacros }, Set (FunctionName, Context)
forall a. Set a
Set.empty)

        -- This is a statement that can affect pointers.
        NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ ->
            -- Delegate to a new function that handles pointer logic.
            -- Crucially, we pass the current, flow-sensitive macro map to it.
            let (PointsToMap
newPtsMap, Set (FunctionName, Context)
newWork) = MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (PointsToMap, Set (FunctionName, Context))
analyzeStatementForPointers (PointsToState -> MacroDefinitionMap
ptsMacros PointsToState
currentState) PointsToContext FunctionName
ctx FunctionName
funcName (PointsToState -> PointsToMap
ptsMap PointsToState
currentState) Node (Lexeme FunctionName)
stmt
            in (PointsToState
currentState { ptsMap :: PointsToMap
ptsMap = PointsToMap
newPtsMap }, Set (FunctionName, Context)
newWork)

-- | The transfer function for a single statement. It takes the current points-to
-- state and a statement, and returns the new state and a set of new functions
-- that need to be added to the worklist (due to being called).
analyzeStatementForPointers :: MacroDefinitionMap -> PointsToContext Text -> Text -> PointsToMap -> C.Node (C.Lexeme Text) -> (PointsToMap, Set (FunctionName, Context))
analyzeStatementForPointers :: MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (PointsToMap, Set (FunctionName, Context))
analyzeStatementForPointers MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
stmt =
    let tracePrefix :: FilePath
tracePrefix = FilePath
"PointsTo.analyzeStatementForPointers (" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
funcName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"): "
    in FilePath
-> (PointsToMap, Set (FunctionName, Context))
-> (PointsToMap, Set (FunctionName, Context))
forall a. FilePath -> a -> a
dtrace ([FilePath] -> FilePath
unlines [ FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"STATE_IN: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToMap -> FilePath
forall a. Show a => a -> FilePath
groom PointsToMap
currentPtsMap
                       , FilePath
"  STMT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
stmt
                       , FilePath
"  LOCAL VARS: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set FunctionName -> FilePath
forall a. Show a => a -> FilePath
groom (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx)
                       ]) ((PointsToMap, Set (FunctionName, Context))
 -> (PointsToMap, Set (FunctionName, Context)))
-> (PointsToMap, Set (FunctionName, Context))
-> (PointsToMap, Set (FunctionName, Context))
forall a b. (a -> b) -> a -> b
$ case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
stmt of

    -- An expression statement just transfers the effects of the inner expression.
    C.ExprStmt Node (Lexeme FunctionName)
expr -> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (PointsToMap, Set (FunctionName, Context))
analyzeStatementForPointers MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
expr

    C.AssignExpr (Fix (C.CastExpr Node (Lexeme FunctionName)
_ Node (Lexeme FunctionName)
lhs)) AssignOp
op Node (Lexeme FunctionName)
rhs ->
        MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (PointsToMap, Set (FunctionName, Context))
analyzeStatementForPointers MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap (NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
-> Node (Lexeme FunctionName)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme FunctionName)
-> AssignOp
-> Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall lexeme a. a -> AssignOp -> a -> NodeF lexeme a
C.AssignExpr Node (Lexeme FunctionName)
lhs AssignOp
op Node (Lexeme FunctionName)
rhs))

    -- Case: *p = &y or *p = q (Assignment to a dereferenced pointer)
    -- This is a "strong update" where we change what a location points to.
    C.AssignExpr (Fix (C.UnaryExpr UnaryOp
C.UopDeref Node (Lexeme FunctionName)
lhsPtr)) AssignOp
C.AopEq Node (Lexeme FunctionName)
rhs ->
        let
            -- First, find out what `lhsPtr` points to. This gives us the locations
            -- on the heap or stack that we need to update.
            (Set AbstractLocation
lhsPointsToSet, Set (FunctionName, Context)
work1) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
lhsPtr
            -- Second, find out what the `rhs` expression points to.
            (Set AbstractLocation
rhsPointsToSet, Set (FunctionName, Context)
work2) = case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
rhs of
                C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) -> (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
VarLocation FunctionName
name), Set (FunctionName, Context)
forall a. Set a
Set.empty)
                NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_                        -> MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
rhs
            -- For every location that `lhsPtr` can point to, we update its
            -- points-to set to be the `rhsPointsToSet`.
            updates :: PointsToMap
updates = [(AbstractLocation, Set AbstractLocation)] -> PointsToMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (AbstractLocation
loc, Set AbstractLocation
rhsPointsToSet) | AbstractLocation
loc <- Set AbstractLocation -> [AbstractLocation]
forall a. Set a -> [a]
Set.toList Set AbstractLocation
lhsPointsToSet ]
        in
            (FilePath -> PointsToMap -> PointsToMap
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines [ FilePath
"Assign *p="
                                            , FilePath
"  STMT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
stmt
                                            , FilePath
"  LHS points to: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
lhsPointsToSet
                                            , FilePath
"  RHS points to: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
rhsPointsToSet
                                            , FilePath
"  UPDATES: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToMap -> FilePath
forall a. Show a => a -> FilePath
groom PointsToMap
updates
                                            ]) (PointsToMap -> PointsToMap) -> PointsToMap -> PointsToMap
forall a b. (a -> b) -> a -> b
$ PointsToMap -> PointsToMap -> PointsToMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union PointsToMap
updates PointsToMap
currentPtsMap, Set (FunctionName, Context)
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (FunctionName, Context)
work1 Set (FunctionName, Context)
work2)

    -- Case: p->field = &y or p->field = q (Assignment to a struct field via pointer)
    C.AssignExpr (Fix (C.PointerAccess Node (Lexeme FunctionName)
ptrExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
fieldName))) AssignOp
C.AopEq Node (Lexeme FunctionName)
rhs ->
        let
            -- Find out what the base pointer `ptrExpr` points to.
            (Set AbstractLocation
ptrPointsToSet, Set (FunctionName, Context)
work1) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
ptrExpr
            -- Find out what the `rhs` points to.
            (Set AbstractLocation
rhsPointsToSet, Set (FunctionName, Context)
work2) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
rhs
            -- For each abstract location `loc` that `ptrExpr` can point to, we
            -- update the points-to set of its field `fieldName`.
            updates :: PointsToMap
updates = [(AbstractLocation, Set AbstractLocation)] -> PointsToMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
loc FunctionName
fieldName, Set AbstractLocation
rhsPointsToSet) | AbstractLocation
loc <- Set AbstractLocation -> [AbstractLocation]
forall a. Set a -> [a]
Set.toList Set AbstractLocation
ptrPointsToSet ]
        in
            (FilePath -> PointsToMap -> PointsToMap
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines [FilePath
"Assign p->field=q"
                                            , FilePath
"  STMT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
stmt
                                            , FilePath
"  LHS points to: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
ptrPointsToSet
                                            , FilePath
"  RHS points to: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
rhsPointsToSet
                                            , FilePath
"  UPDATES: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToMap -> FilePath
forall a. Show a => a -> FilePath
groom PointsToMap
updates
                                            ]) (PointsToMap -> PointsToMap) -> PointsToMap -> PointsToMap
forall a b. (a -> b) -> a -> b
$ PointsToMap -> PointsToMap -> PointsToMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union PointsToMap
currentPtsMap PointsToMap
updates, Set (FunctionName, Context)
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (FunctionName, Context)
work1 Set (FunctionName, Context)
work2)

    -- Case: s.field = &y (Assignment to a struct field directly)
    C.AssignExpr (Fix (C.MemberAccess Node (Lexeme FunctionName)
structExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
fieldName))) AssignOp
C.AopEq Node (Lexeme FunctionName)
rhs ->
        let
            structLoc :: AbstractLocation
structLoc = HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
structExpr
            (Set AbstractLocation
rhsPointsToSet, Set (FunctionName, Context)
work) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
rhs
            finalRhsSet :: Set AbstractLocation
finalRhsSet = if Set AbstractLocation -> Bool
forall a. Set a -> Bool
Set.null Set AbstractLocation
rhsPointsToSet
                          then case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
rhs of
                                 C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) | FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) Bool -> Bool -> Bool
|| FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDecls PointsToContext FunctionName
ctx) ->
                                     AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
FunctionLocation FunctionName
name)
                                 C.UnaryExpr UnaryOp
C.UopAddress (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name))) | FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) Bool -> Bool -> Bool
|| FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDecls PointsToContext FunctionName
ctx) ->
                                     AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
FunctionLocation FunctionName
name)
                                 NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> Set AbstractLocation
rhsPointsToSet
                          else Set AbstractLocation
rhsPointsToSet

            -- Check if the base is a union type
            baseVarName :: FunctionName
baseVarName = Node (Lexeme FunctionName) -> FunctionName
getBaseVarName Node (Lexeme FunctionName)
structExpr
            baseTypeNode :: Maybe (Node (Lexeme FunctionName))
baseTypeNode = FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
baseVarName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> Map FunctionName (Node (Lexeme l))
ptcVarTypes PointsToContext FunctionName
ctx)
            (Bool
isUnion, PointsToMap
updates) = case Maybe (Node (Lexeme FunctionName))
baseTypeNode of
                Just (Fix (C.TyUserDefined (C.L AlexPosn
_ LexemeClass
_ FunctionName
typeName))) ->
                    case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
typeName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> Map FunctionName (Node (Lexeme l))
ptcStructDefs PointsToContext FunctionName
ctx) of
                        Just (Fix (C.Union Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
members)) ->
                            let memberNames :: [FunctionName]
memberNames = [Node (Lexeme FunctionName)] -> [FunctionName]
getMemberNames [Node (Lexeme FunctionName)]
members
                            in (Bool
True, [(AbstractLocation, Set AbstractLocation)] -> PointsToMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
member, Set AbstractLocation
finalRhsSet) | FunctionName
member <- [FunctionName]
memberNames ])
                        Maybe (Node (Lexeme FunctionName))
_ -> (Bool
False, AbstractLocation -> Set AbstractLocation -> PointsToMap
forall k a. k -> a -> Map k a
Map.singleton (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
fieldName) Set AbstractLocation
finalRhsSet)
                Just (Fix (C.TyUnion (C.L AlexPosn
_ LexemeClass
_ FunctionName
typeName))) ->
                    case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
typeName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> Map FunctionName (Node (Lexeme l))
ptcStructDefs PointsToContext FunctionName
ctx) of
                        Just (Fix (C.Union Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
members)) ->
                            let memberNames :: [FunctionName]
memberNames = [Node (Lexeme FunctionName)] -> [FunctionName]
getMemberNames [Node (Lexeme FunctionName)]
members
                            in (Bool
True, [(AbstractLocation, Set AbstractLocation)] -> PointsToMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
member, Set AbstractLocation
finalRhsSet) | FunctionName
member <- [FunctionName]
memberNames ])
                        Maybe (Node (Lexeme FunctionName))
_ -> (Bool
False, AbstractLocation -> Set AbstractLocation -> PointsToMap
forall k a. k -> a -> Map k a
Map.singleton (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
fieldName) Set AbstractLocation
finalRhsSet)
                Maybe (Node (Lexeme FunctionName))
_ -> (Bool
False, AbstractLocation -> Set AbstractLocation -> PointsToMap
forall k a. k -> a -> Map k a
Map.singleton (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
fieldName) Set AbstractLocation
finalRhsSet)
        in
            (FilePath -> PointsToMap -> PointsToMap
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines [ FilePath
"Assign s.field=q"
                                            , FilePath
"  STMT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
stmt
                                            , FilePath
"  LHS: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
fieldName)
                                            , FilePath
"  RHS points to: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
finalRhsSet
                                            , FilePath
"  IS_UNION: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
isUnion
                                            , FilePath
"  UPDATES: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToMap -> FilePath
forall a. Show a => a -> FilePath
groom PointsToMap
updates
                                            ]) (PointsToMap -> PointsToMap) -> PointsToMap -> PointsToMap
forall a b. (a -> b) -> a -> b
$ (Set AbstractLocation
 -> Set AbstractLocation -> Set AbstractLocation)
-> PointsToMap -> PointsToMap -> PointsToMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union PointsToMap
currentPtsMap PointsToMap
updates, Set (FunctionName, Context)
work)

    -- Case: p = &x; (Address-of assignment)
    C.AssignExpr Node (Lexeme FunctionName)
lhs AssignOp
C.AopEq (Fix (C.UnaryExpr UnaryOp
C.UopAddress Node (Lexeme FunctionName)
rhs)) ->
        let lhsLoc :: AbstractLocation
lhsLoc = HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
lhs
            -- The RHS is the abstract location of the variable `x` itself.
            -- If `rhs` is a function, we create a `FunctionLocation`.
            rhsLoc :: AbstractLocation
rhsLoc = case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
rhs of
                C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) | FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) Bool -> Bool -> Bool
|| FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDecls PointsToContext FunctionName
ctx) -> FunctionName -> AbstractLocation
FunctionLocation FunctionName
name
                NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
rhs
        in (FilePath -> PointsToMap -> PointsToMap
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines [ FilePath
"Assign p=&x"
                                           , FilePath
"  STMT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
stmt
                                           , FilePath
"  LHS LOC: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom AbstractLocation
lhsLoc
                                           , FilePath
"  RHS LOC: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom AbstractLocation
rhsLoc
                                           ]) (PointsToMap -> PointsToMap) -> PointsToMap -> PointsToMap
forall a b. (a -> b) -> a -> b
$ AbstractLocation
-> Set AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
lhsLoc (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
rhsLoc) PointsToMap
currentPtsMap, Set (FunctionName, Context)
forall a. Set a
Set.empty)

    -- Case: q = p (pointer copy) or r = f(p) (assignment from function call)
    C.AssignExpr Node (Lexeme FunctionName)
lhs AssignOp
C.AopEq Node (Lexeme FunctionName)
rhs ->
        let lhsLoc :: AbstractLocation
lhsLoc = HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
lhs
            -- Evaluate the RHS to find out what it points to.
            (Set AbstractLocation
rhsPointsTo, Set (FunctionName, Context)
newWork) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
rhs
            newState :: PointsToMap
newState = if Set AbstractLocation -> Bool
forall a. Set a -> Bool
Set.null Set AbstractLocation
rhsPointsTo
                then case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
rhs of
                   -- Handle assignment of a function name directly.
                   C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) | FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) ->
                       AbstractLocation
-> Set AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
lhsLoc (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
FunctionLocation FunctionName
name)) PointsToMap
currentPtsMap
                   C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) ->
                       AbstractLocation
-> Set AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
lhsLoc (Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
VarLocation FunctionName
name)) (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FunctionName -> AbstractLocation
VarLocation FunctionName
name) PointsToMap
currentPtsMap)) PointsToMap
currentPtsMap
                   -- If the RHS is a function call, we've already evaluated it.
                   C.FunctionCall Node (Lexeme FunctionName)
_ [Node (Lexeme FunctionName)]
_ ->
                       let (Set AbstractLocation
pointsTo, Set (FunctionName, Context)
_) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
rhs in
                       AbstractLocation
-> Set AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
lhsLoc Set AbstractLocation
pointsTo PointsToMap
currentPtsMap
                   C.BinaryExpr {} ->
                       AbstractLocation
-> Set AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
lhsLoc Set AbstractLocation
forall a. Set a
Set.empty PointsToMap
currentPtsMap
                   -- If the RHS points to nothing (e.g., `p = NULL`), we remove the
                   -- entry for the LHS variable, as it no longer points to anything.
                   NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete AbstractLocation
lhsLoc PointsToMap
currentPtsMap
                else AbstractLocation
-> Set AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
lhsLoc Set AbstractLocation
rhsPointsTo PointsToMap
currentPtsMap
        in (FilePath -> PointsToMap -> PointsToMap
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines [ FilePath
"Assign generic"
                                           , FilePath
"  STMT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
stmt
                                           , FilePath
"  LHS LOC: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom AbstractLocation
lhsLoc
                                           , FilePath
"  RHS points to: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
rhsPointsTo
                                           ]) PointsToMap
newState, Set (FunctionName, Context)
newWork)

    -- Case: f(p) (standalone function call, handled for its side effects)
    C.FunctionCall Node (Lexeme FunctionName)
callExpr [Node (Lexeme FunctionName)]
args ->
        case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
callExpr of
            C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
calleeName) ->
                FilePath
-> (PointsToMap, Set (FunctionName, Context))
-> (PointsToMap, Set (FunctionName, Context))
forall a. FilePath -> a -> a
dtrace (FilePath
"FunctionCall: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
calleeName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
", MACROS IN SCOPE: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FunctionName] -> FilePath
forall a. Show a => a -> FilePath
groom (MacroDefinitionMap -> [FunctionName]
forall k a. Map k a -> [k]
Map.keys MacroDefinitionMap
currentMacros)) ((PointsToMap, Set (FunctionName, Context))
 -> (PointsToMap, Set (FunctionName, Context)))
-> (PointsToMap, Set (FunctionName, Context))
-> (PointsToMap, Set (FunctionName, Context))
forall a b. (a -> b) -> a -> b
$
                case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
calleeName MacroDefinitionMap
currentMacros of
                    Just Node (Lexeme FunctionName)
macroDefNode ->
                        Node (Lexeme FunctionName)
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> (PointsToMap, Set (FunctionName, Context))
analyzeMacroBody Node (Lexeme FunctionName)
macroDefNode [Node (Lexeme FunctionName)]
args MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap
                    Maybe (Node (Lexeme FunctionName))
Nothing ->
                        Node (Lexeme FunctionName)
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> (PointsToMap, Set (FunctionName, Context))
analyzeFunctionCall Node (Lexeme FunctionName)
callExpr [Node (Lexeme FunctionName)]
args MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap
            C.LiteralExpr LiteralType
C.ConstId (C.L AlexPosn
_ LexemeClass
_ FunctionName
calleeName) ->
                FilePath
-> (PointsToMap, Set (FunctionName, Context))
-> (PointsToMap, Set (FunctionName, Context))
forall a. FilePath -> a -> a
dtrace (FilePath
"FunctionCall (Literal): " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
calleeName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
", MACROS IN SCOPE: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FunctionName] -> FilePath
forall a. Show a => a -> FilePath
groom (MacroDefinitionMap -> [FunctionName]
forall k a. Map k a -> [k]
Map.keys MacroDefinitionMap
currentMacros)) ((PointsToMap, Set (FunctionName, Context))
 -> (PointsToMap, Set (FunctionName, Context)))
-> (PointsToMap, Set (FunctionName, Context))
-> (PointsToMap, Set (FunctionName, Context))
forall a b. (a -> b) -> a -> b
$
                case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
calleeName MacroDefinitionMap
currentMacros of
                    Just Node (Lexeme FunctionName)
macroDefNode ->
                        Node (Lexeme FunctionName)
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> (PointsToMap, Set (FunctionName, Context))
analyzeMacroBody Node (Lexeme FunctionName)
macroDefNode [Node (Lexeme FunctionName)]
args MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap
                    Maybe (Node (Lexeme FunctionName))
Nothing ->
                        Node (Lexeme FunctionName)
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> (PointsToMap, Set (FunctionName, Context))
analyzeFunctionCall Node (Lexeme FunctionName)
callExpr [Node (Lexeme FunctionName)]
args MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap
            NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> Node (Lexeme FunctionName)
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> (PointsToMap, Set (FunctionName, Context))
analyzeFunctionCall Node (Lexeme FunctionName)
callExpr [Node (Lexeme FunctionName)]
args MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap

    -- Case: int *p = get_x(); (Variable declaration with initialization)
    C.VarDeclStmt (Fix (C.VarDecl Node (Lexeme FunctionName)
_ (C.L AlexPosn
_ LexemeClass
_ FunctionName
varName) [Node (Lexeme FunctionName)]
_)) (Just Node (Lexeme FunctionName)
initializer) ->
        let varLoc :: AbstractLocation
varLoc = FunctionName -> AbstractLocation
VarLocation FunctionName
varName
            (Set AbstractLocation
rhsPointsTo, Set (FunctionName, Context)
newWork) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap (case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
initializer of C.CastExpr Node (Lexeme FunctionName)
_ Node (Lexeme FunctionName)
inner -> Node (Lexeme FunctionName)
inner; NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> Node (Lexeme FunctionName)
initializer)
            newState :: PointsToMap
newState = if Set AbstractLocation -> Bool
forall a. Set a -> Bool
Set.null Set AbstractLocation
rhsPointsTo
                then AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete AbstractLocation
varLoc PointsToMap
currentPtsMap
                else AbstractLocation
-> Set AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
varLoc Set AbstractLocation
rhsPointsTo PointsToMap
currentPtsMap
        in (FilePath -> PointsToMap -> PointsToMap
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines [ FilePath
"VarDecl"
                                           , FilePath
"  STMT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
stmt
                                           , FilePath
"  VAR LOC: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom AbstractLocation
varLoc
                                           , FilePath
"  RHS points to: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
rhsPointsTo
                                           ]) PointsToMap
newState, Set (FunctionName, Context)
newWork)

    -- Other statements don't affect points-to information in this simplified model.
    NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> (PointsToMap
currentPtsMap, Set (FunctionName, Context)
forall a. Set a
Set.empty)

analyzeFunctionCall :: C.Node (C.Lexeme Text) -> [C.Node (C.Lexeme Text)] -> MacroDefinitionMap -> PointsToContext Text -> Text -> PointsToMap -> (PointsToMap, Set (FunctionName, Context))
analyzeFunctionCall :: Node (Lexeme FunctionName)
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> (PointsToMap, Set (FunctionName, Context))
analyzeFunctionCall Node (Lexeme FunctionName)
callExpr [Node (Lexeme FunctionName)]
args MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap =
    let
        nodeId :: Int
nodeId = Node (Lexeme FunctionName) -> Int
forall a. Hashable a => Node a -> Int
C.getNodeId Node (Lexeme FunctionName)
callExpr
        -- Determine the possible callees. This can be a direct call or an
        -- indirect call through a function pointer.
        ([FunctionName]
calleeNames, Set AbstractLocation
indirectCalleePointsTo, Set (FunctionName, Context)
newWorkFromEval) = case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
callExpr of
            C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) | FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) -> ([FunctionName
name], Set AbstractLocation
forall a. Set a
Set.empty, Set (FunctionName, Context)
forall a. Set a
Set.empty)
            NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> let (Set AbstractLocation
pointsTo, Set (FunctionName, Context)
work) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
callExpr in ([], Set AbstractLocation
pointsTo, Set (FunctionName, Context)
work)

        -- Resolve function pointers to get a list of function names.
        indirectCalleeNames :: [FunctionName]
indirectCalleeNames = (AbstractLocation -> Maybe FunctionName)
-> [AbstractLocation] -> [FunctionName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\AbstractLocation
loc -> case AbstractLocation
loc of FunctionLocation FunctionName
fname -> FunctionName -> Maybe FunctionName
forall a. a -> Maybe a
Just FunctionName
fname; AbstractLocation
_ -> Maybe FunctionName
forall a. Maybe a
Nothing) (Set AbstractLocation -> [AbstractLocation]
forall a. Set a -> [a]
Set.toList Set AbstractLocation
indirectCalleePointsTo)
        allCalleeNames :: [FunctionName]
allCalleeNames = [FunctionName]
calleeNames [FunctionName] -> [FunctionName] -> [FunctionName]
forall a. [a] -> [a] -> [a]
++ [FunctionName]
indirectCalleeNames

        -- Process the side effects of each possible callee.
        processCallee :: PointsToMap -> FunctionName -> PointsToMap
        processCallee :: PointsToMap -> FunctionName -> PointsToMap
processCallee PointsToMap
current_state FunctionName
calleeName =
            let
                -- Create the new context for this specific call site.
                newContext :: Context
newContext = Int -> Int -> Context -> Context
pushContext Int
kLimit Int
nodeId (PointsToContext FunctionName -> Context
forall l. PointsToContext l -> Context
ptcCurrentContext PointsToContext FunctionName
ctx)
                -- Look up the summary for the callee in the new context.
                summariesForCallee :: PointsToSummary
summariesForCallee = PointsToSummary -> Maybe PointsToSummary -> PointsToSummary
forall a. a -> Maybe a -> a
fromMaybe PointsToSummary
forall k a. Map k a
Map.empty (FunctionName
-> Map FunctionName PointsToSummary -> Maybe PointsToSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
calleeName (PointsToContext FunctionName -> Map FunctionName PointsToSummary
forall l. PointsToContext l -> Map FunctionName PointsToSummary
ptcSummaries PointsToContext FunctionName
ctx))
                summary :: PointsToSummaryData
summary = PointsToSummaryData
-> Maybe PointsToSummaryData -> PointsToSummaryData
forall a. a -> Maybe a -> a
fromMaybe (PointsToSummaryData
-> Maybe PointsToSummaryData -> PointsToSummaryData
forall a. a -> Maybe a -> a
fromMaybe PointsToSummaryData
emptySummaryData (Context -> PointsToSummary -> Maybe PointsToSummaryData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [] PointsToSummary
summariesForCallee)) (Context -> PointsToSummary -> Maybe PointsToSummaryData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Context
newContext PointsToSummary
summariesForCallee)
                paramNames :: [FunctionName]
paramNames = MacroDefinitionMap -> FunctionName -> [FunctionName]
getParamNamesFromDef (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) FunctionName
calleeName

                -- `substitute` is a crucial helper function. It translates an abstract
                -- location from the callee's summary into the caller's context.
                substitute :: AbstractLocation -> Set AbstractLocation
substitute AbstractLocation
loc =
                    let
                        -- A helper to evaluate an argument at a call site, looking through casts.
                        evalArg :: Node (Lexeme FunctionName) -> Set AbstractLocation
evalArg Node (Lexeme FunctionName)
arg = case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
arg of
                            C.CastExpr Node (Lexeme FunctionName)
_ Node (Lexeme FunctionName)
innerExpr             -> Node (Lexeme FunctionName) -> Set AbstractLocation
evalArg Node (Lexeme FunctionName)
innerExpr
                            C.UnaryExpr UnaryOp
C.UopAddress Node (Lexeme FunctionName)
innerExpr -> AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
innerExpr)
                            C.FunctionCall {} ->
                                (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a, b) -> a
fst ((Set AbstractLocation, Set (FunctionName, Context))
 -> Set AbstractLocation)
-> (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
current_state Node (Lexeme FunctionName)
arg
                            C.VarExpr Lexeme FunctionName
_ ->
                                let argLoc :: AbstractLocation
argLoc = HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
arg
                                in Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
argLoc) (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
argLoc PointsToMap
current_state)
                            C.LiteralExpr {} -> Set AbstractLocation
forall a. Set a
Set.empty -- Literals don't point to anything.
                            C.SizeofType {} -> Set AbstractLocation
forall a. Set a
Set.empty -- sizeof(T) doesn't point to anything.
                            C.SizeofExpr {} -> Set AbstractLocation
forall a. Set a
Set.empty -- sizeof(e) doesn't point to anything.
                            C.BinaryExpr Node (Lexeme FunctionName)
lhs BinaryOp
C.BopPlus Node (Lexeme FunctionName)
_ -> Node (Lexeme FunctionName) -> Set AbstractLocation
evalArg Node (Lexeme FunctionName)
lhs
                            C.BinaryExpr {} -> Set AbstractLocation
forall a. Set a
Set.empty -- Other binary ops don't point to anything.
                            NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (Maybe (Set AbstractLocation) -> Set AbstractLocation)
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
arg) PointsToMap
current_state
                    in case AbstractLocation
loc of
                    -- If the location is a parameter, substitute it with what the
                    -- corresponding argument at the call site points to.
                    VarLocation FunctionName
vName ->
                        case (FunctionName -> Bool) -> [FunctionName] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (FunctionName -> FunctionName -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionName
vName) [FunctionName]
paramNames of
                            Just Int
i -> Node (Lexeme FunctionName) -> Set AbstractLocation
evalArg ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i)
                            -- If it's not a parameter, it could be a global variable.
                            Maybe Int
Nothing -> if FunctionName -> Set FunctionName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FunctionName
vName (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx)
                                       then Set AbstractLocation
forall a. Set a
Set.empty
                                       else AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
GlobalVarLocation FunctionName
vName)
                    -- Handle dereferences similarly.
                    DerefLocation (VarLocation FunctionName
pName) ->
                        case (FunctionName -> Bool) -> [FunctionName] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (FunctionName -> FunctionName -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionName
pName) [FunctionName]
paramNames of
                            Just Int
i  -> Node (Lexeme FunctionName) -> Set AbstractLocation
evalArg ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i)
                            Maybe Int
Nothing -> AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
loc
                    -- Recursively substitute for field locations.
                    FieldLocation AbstractLocation
l FunctionName
f -> (AbstractLocation -> AbstractLocation)
-> Set AbstractLocation -> Set AbstractLocation
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (AbstractLocation -> FunctionName -> AbstractLocation
`FieldLocation` FunctionName
f) (AbstractLocation -> Set AbstractLocation
substitute AbstractLocation
l)
                    FunctionLocation FunctionName
fName -> AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
FunctionLocation FunctionName
fName)
                    AbstractLocation
_ -> AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
loc

                -- In the summary, the RHS is a set of locations. We need to substitute each of them.
                -- Iterate over all side effects (outputPointsTo) in the summary.
                updates :: PointsToMap
updates = (PointsToMap
 -> AbstractLocation -> Set AbstractLocation -> PointsToMap)
-> PointsToMap -> PointsToMap -> PointsToMap
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\PointsToMap
acc AbstractLocation
summaryLhs Set AbstractLocation
summaryRhs ->
                    let
                        -- Substitute the LHS of the summary's side effect.
                        callerLhsSet :: Set AbstractLocation
callerLhsSet = AbstractLocation -> Set AbstractLocation
substitute AbstractLocation
summaryLhs
                        -- Substitute the RHS. Any local variable from the callee's
                        -- summary that is not a parameter must be treated as a
                        -- global from the caller's perspective.
                        callerRhsSet :: Set AbstractLocation
callerRhsSet = [Set AbstractLocation] -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set AbstractLocation] -> Set AbstractLocation)
-> [Set AbstractLocation] -> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ (AbstractLocation -> Set AbstractLocation)
-> [AbstractLocation] -> [Set AbstractLocation]
forall a b. (a -> b) -> [a] -> [b]
map (\AbstractLocation
loc -> case AbstractLocation
loc of
                            VarLocation FunctionName
vName | FunctionName
vName FunctionName -> [FunctionName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FunctionName]
paramNames -> AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
GlobalVarLocation FunctionName
vName)
                            AbstractLocation
_ -> AbstractLocation -> Set AbstractLocation
substitute AbstractLocation
loc
                            ) (Set AbstractLocation -> [AbstractLocation]
forall a. Set a -> [a]
Set.toList Set AbstractLocation
summaryRhs)
                        newUpdates :: PointsToMap
newUpdates = (AbstractLocation -> Set AbstractLocation)
-> Set AbstractLocation -> PointsToMap
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Set AbstractLocation -> AbstractLocation -> Set AbstractLocation
forall a b. a -> b -> a
const Set AbstractLocation
callerRhsSet) Set AbstractLocation
callerLhsSet
                    in
                        (Set AbstractLocation
 -> Set AbstractLocation -> Set AbstractLocation)
-> PointsToMap -> PointsToMap -> PointsToMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union PointsToMap
acc PointsToMap
newUpdates
                    ) PointsToMap
forall k a. Map k a
Map.empty (PointsToSummaryData -> PointsToMap
outputPointsTo PointsToSummaryData
summary)

            in
                -- Apply the updates to the caller's state.
                let updatedState :: PointsToMap
updatedState = (Set AbstractLocation
 -> Set AbstractLocation -> Set AbstractLocation)
-> PointsToMap -> PointsToMap -> PointsToMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union PointsToMap
updates PointsToMap
current_state
                in FilePath -> PointsToMap -> PointsToMap
forall a. FilePath -> a -> a
dtrace (FilePath
"processCallee for " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
calleeName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
":\n  UPDATES: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToMap -> FilePath
forall a. Show a => a -> FilePath
groom PointsToMap
updates FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n  CURRENT_STATE: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToMap -> FilePath
forall a. Show a => a -> FilePath
groom PointsToMap
current_state FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n  UPDATED_STATE: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToMap -> FilePath
forall a. Show a => a -> FilePath
groom PointsToMap
updatedState) PointsToMap
updatedState

        -- Fold over all possible callees and apply their summary effects.
        newState :: PointsToMap
newState = (PointsToMap -> FunctionName -> PointsToMap)
-> PointsToMap -> [FunctionName] -> PointsToMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PointsToMap -> FunctionName -> PointsToMap
processCallee PointsToMap
currentPtsMap [FunctionName]
allCalleeNames
        -- Add all callees to the worklist for future analysis.
        newWork :: Set (FunctionName, Context)
newWork = Set (FunctionName, Context)
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (FunctionName, Context)
newWorkFromEval (Set (FunctionName, Context) -> Set (FunctionName, Context))
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a b. (a -> b) -> a -> b
$ [(FunctionName, Context)] -> Set (FunctionName, Context)
forall a. Ord a => [a] -> Set a
Set.fromList ([(FunctionName, Context)] -> Set (FunctionName, Context))
-> [(FunctionName, Context)] -> Set (FunctionName, Context)
forall a b. (a -> b) -> a -> b
$ (FunctionName -> (FunctionName, Context))
-> [FunctionName] -> [(FunctionName, Context)]
forall a b. (a -> b) -> [a] -> [b]
map (\FunctionName
name -> (FunctionName
name, Int -> Int -> Context -> Context
pushContext Int
kLimit Int
nodeId (PointsToContext FunctionName -> Context
forall l. PointsToContext l -> Context
ptcCurrentContext PointsToContext FunctionName
ctx))) [FunctionName]
allCalleeNames
    in
        (PointsToMap
newState, Set (FunctionName, Context)
newWork)

substituteInNode :: Map Text (C.Node (C.Lexeme Text)) -> C.Node (C.Lexeme Text) -> C.Node (C.Lexeme Text)
substituteInNode :: MacroDefinitionMap
-> Node (Lexeme FunctionName) -> Node (Lexeme FunctionName)
substituteInNode MacroDefinitionMap
subMap = (NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
 -> Node (Lexeme FunctionName))
-> Node (Lexeme FunctionName) -> Node (Lexeme FunctionName)
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
-> Node (Lexeme FunctionName)
go
  where
    go :: NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
-> Node (Lexeme FunctionName)
go (C.VarExpr lexeme :: Lexeme FunctionName
lexeme@(C.L AlexPosn
_ LexemeClass
_ FunctionName
name)) =
        Node (Lexeme FunctionName)
-> Maybe (Node (Lexeme FunctionName)) -> Node (Lexeme FunctionName)
forall a. a -> Maybe a -> a
fromMaybe (NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
-> Node (Lexeme FunctionName)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme FunctionName
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall lexeme a. lexeme -> NodeF lexeme a
C.VarExpr Lexeme FunctionName
lexeme)) (FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
name MacroDefinitionMap
subMap)
    go NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
other = NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
-> Node (Lexeme FunctionName)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
other

analyzeMacroBody :: C.Node (C.Lexeme Text) -> [C.Node (C.Lexeme Text)] -> MacroDefinitionMap -> PointsToContext Text -> FunctionName -> PointsToMap -> (PointsToMap, Set (FunctionName, Context))
analyzeMacroBody :: Node (Lexeme FunctionName)
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> (PointsToMap, Set (FunctionName, Context))
analyzeMacroBody (Fix (C.PreprocDefineMacro Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
macroParams Node (Lexeme FunctionName)
body)) [Node (Lexeme FunctionName)]
callArgs MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
initialPtsMap =
    let
        paramNames :: [FunctionName]
paramNames = (Node (Lexeme FunctionName) -> Maybe FunctionName)
-> [Node (Lexeme FunctionName)] -> [FunctionName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case (Fix (C.MacroParam (C.L AlexPosn
_ LexemeClass
_ FunctionName
name))) -> FunctionName -> Maybe FunctionName
forall a. a -> Maybe a
Just FunctionName
name; Node (Lexeme FunctionName)
_ -> Maybe FunctionName
forall a. Maybe a
Nothing) [Node (Lexeme FunctionName)]
macroParams
        substitutionMap :: MacroDefinitionMap
substitutionMap = [(FunctionName, Node (Lexeme FunctionName))] -> MacroDefinitionMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FunctionName, Node (Lexeme FunctionName))]
 -> MacroDefinitionMap)
-> [(FunctionName, Node (Lexeme FunctionName))]
-> MacroDefinitionMap
forall a b. (a -> b) -> a -> b
$ [FunctionName]
-> [Node (Lexeme FunctionName)]
-> [(FunctionName, Node (Lexeme FunctionName))]
forall a b. [a] -> [b] -> [(a, b)]
zip [FunctionName]
paramNames [Node (Lexeme FunctionName)]
callArgs
        substitutedBody :: Node (Lexeme FunctionName)
substitutedBody = MacroDefinitionMap
-> Node (Lexeme FunctionName) -> Node (Lexeme FunctionName)
substituteInNode MacroDefinitionMap
substitutionMap Node (Lexeme FunctionName)
body

        -- The macro body can be a single statement or a compound statement.
        -- We need to handle both cases.
        getStmts :: Fix (NodeF lexeme) -> [Fix (NodeF lexeme)]
getStmts (Fix (C.MacroBodyStmt (Fix (C.CompoundStmt [Fix (NodeF lexeme)]
stmts)))) = [Fix (NodeF lexeme)]
stmts
        getStmts (Fix (C.MacroBodyStmt Fix (NodeF lexeme)
stmt))                         = [Fix (NodeF lexeme)
stmt]
        getStmts Fix (NodeF lexeme)
_                                                    = []

        substitutedStmts :: [Node (Lexeme FunctionName)]
substitutedStmts = Node (Lexeme FunctionName) -> [Node (Lexeme FunctionName)]
forall lexeme. Fix (NodeF lexeme) -> [Fix (NodeF lexeme)]
getStmts Node (Lexeme FunctionName)
substitutedBody
    in
        ((PointsToMap, Set (FunctionName, Context))
 -> Node (Lexeme FunctionName)
 -> (PointsToMap, Set (FunctionName, Context)))
-> (PointsToMap, Set (FunctionName, Context))
-> [Node (Lexeme FunctionName)]
-> (PointsToMap, Set (FunctionName, Context))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            (\(PointsToMap
accMap, Set (FunctionName, Context)
accWork) Node (Lexeme FunctionName)
stmt ->
                let (PointsToMap
newMap, Set (FunctionName, Context)
newWork) = MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (PointsToMap, Set (FunctionName, Context))
analyzeStatementForPointers MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
accMap Node (Lexeme FunctionName)
stmt
                in (PointsToMap
newMap, Set (FunctionName, Context)
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (FunctionName, Context)
accWork Set (FunctionName, Context)
newWork))
            (PointsToMap
initialPtsMap, Set (FunctionName, Context)
forall a. Set a
Set.empty)
            [Node (Lexeme FunctionName)]
substitutedStmts
analyzeMacroBody Node (Lexeme FunctionName)
_ [Node (Lexeme FunctionName)]
_ MacroDefinitionMap
_ PointsToContext FunctionName
_ FunctionName
_ PointsToMap
currentPtsMap = (PointsToMap
currentPtsMap, Set (FunctionName, Context)
forall a. Set a
Set.empty)

-- | Checks if a variable name refers to a global variable within the current scope.
-- A variable is considered global if it's not a parameter and not in the set of
-- locally declared variables for the current function.
isGlobalVar :: Set Text -> [Text] -> Text -> Bool
isGlobalVar :: Set FunctionName -> [FunctionName] -> FunctionName -> Bool
isGlobalVar Set FunctionName
localVars [FunctionName]
params FunctionName
varName =
    let result :: Bool
result = Bool -> Bool
not (FunctionName
varName FunctionName -> [FunctionName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FunctionName]
params) Bool -> Bool -> Bool
&& Bool -> Bool
not (FunctionName -> Set FunctionName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FunctionName
varName Set FunctionName
localVars)
    in FilePath -> Bool -> Bool
forall a. FilePath -> a -> a
dtrace (FilePath
"isGlobalVar: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
varName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" in " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FunctionName] -> FilePath
forall a. Show a => a -> FilePath
groom [FunctionName]
params FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" with locals " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set FunctionName -> FilePath
forall a. Show a => a -> FilePath
groom Set FunctionName
localVars FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" -> " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
result) Bool
result

-- | Evaluates an expression to determine the set of abstract locations it points to.
-- This is a key part of the transfer function, used to resolve the RHS of assignments
-- and the targets of function calls.
evalPointsToSet :: MacroDefinitionMap -> PointsToContext Text -> Set Text -> FunctionName -> PointsToMap -> C.Node (C.Lexeme Text) -> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet :: MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx Set FunctionName
localVars FunctionName
funcName PointsToMap
currentPtsMap Node (Lexeme FunctionName)
expr =
    let result :: (Set AbstractLocation, Set (FunctionName, Context))
result = Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
go Node (Lexeme FunctionName)
expr
    in FilePath
-> (Set AbstractLocation, Set (FunctionName, Context))
-> (Set AbstractLocation, Set (FunctionName, Context))
forall a. FilePath -> a -> a
dtrace ([FilePath] -> FilePath
unlines [ FilePath
"PointsTo.evalPointsToSet:"
                       , FilePath
"  EXPR: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
expr
                       , FilePath
"  STATE: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToMap -> FilePath
forall a. Show a => a -> FilePath
groom PointsToMap
currentPtsMap
                       , FilePath
"  RESULT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Set AbstractLocation, Set (FunctionName, Context)) -> FilePath
forall a. Show a => a -> FilePath
groom (Set AbstractLocation, Set (FunctionName, Context))
result
                       , FilePath
"  LOCAL VARS: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set FunctionName -> FilePath
forall a. Show a => a -> FilePath
groom Set FunctionName
localVars
                       ]) (Set AbstractLocation, Set (FunctionName, Context))
result
  where
    go :: Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
go localExpr :: Node (Lexeme FunctionName)
localExpr@(Fix NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
node) = FilePath
-> (Set AbstractLocation, Set (FunctionName, Context))
-> (Set AbstractLocation, Set (FunctionName, Context))
forall a. FilePath -> a -> a
dtrace (FilePath
"PointsTo.evalPointsToSet.go: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
-> FilePath
forall a. Show a => a -> FilePath
show NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
node) ((Set AbstractLocation, Set (FunctionName, Context))
 -> (Set AbstractLocation, Set (FunctionName, Context)))
-> (Set AbstractLocation, Set (FunctionName, Context))
-> (Set AbstractLocation, Set (FunctionName, Context))
forall a b. (a -> b) -> a -> b
$ case NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
node of

        -- Case: A direct function call, e.g., `f(x)`.
        C.FunctionCall callExpr :: Node (Lexeme FunctionName)
callExpr@(Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
calleeName))) [Node (Lexeme FunctionName)]
args ->
            case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
calleeName (PointsToState -> MacroDefinitionMap
ptsMacros (PointsToMap -> MacroDefinitionMap -> PointsToState
PointsToState PointsToMap
currentPtsMap MacroDefinitionMap
currentMacros)) of
                Just Node (Lexeme FunctionName)
macroDefNode ->
                    let (PointsToMap
newPtsMap, Set (FunctionName, Context)
newWork) = Node (Lexeme FunctionName)
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
-> PointsToContext FunctionName
-> FunctionName
-> PointsToMap
-> (PointsToMap, Set (FunctionName, Context))
analyzeMacroBody Node (Lexeme FunctionName)
macroDefNode [Node (Lexeme FunctionName)]
args MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx FunctionName
funcName PointsToMap
currentPtsMap
                    in (Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
callExpr) PointsToMap
newPtsMap), Set (FunctionName, Context)
newWork)
                Maybe (Node (Lexeme FunctionName))
Nothing ->
                    let
                        nodeId :: Int
nodeId = Node (Lexeme FunctionName) -> Int
forall a. Hashable a => Node a -> Int
C.getNodeId Node (Lexeme FunctionName)
localExpr
                        newContext :: Context
newContext = Int -> Int -> Context -> Context
pushContext Int
kLimit Int
nodeId (PointsToContext FunctionName -> Context
forall l. PointsToContext l -> Context
ptcCurrentContext PointsToContext FunctionName
ctx)
                        -- Look up the summary for the callee.
                        summariesForCallee :: PointsToSummary
summariesForCallee = PointsToSummary -> Maybe PointsToSummary -> PointsToSummary
forall a. a -> Maybe a -> a
fromMaybe PointsToSummary
forall k a. Map k a
Map.empty (FunctionName
-> Map FunctionName PointsToSummary -> Maybe PointsToSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
calleeName (PointsToContext FunctionName -> Map FunctionName PointsToSummary
forall l. PointsToContext l -> Map FunctionName PointsToSummary
ptcSummaries PointsToContext FunctionName
ctx))
                        summary :: PointsToSummaryData
summary = PointsToSummaryData
-> Maybe PointsToSummaryData -> PointsToSummaryData
forall a. a -> Maybe a -> a
fromMaybe (PointsToSummaryData
-> Maybe PointsToSummaryData -> PointsToSummaryData
forall a. a -> Maybe a -> a
fromMaybe PointsToSummaryData
emptySummaryData (Context -> PointsToSummary -> Maybe PointsToSummaryData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [] PointsToSummary
summariesForCallee)) (Context -> PointsToSummary -> Maybe PointsToSummaryData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Context
newContext PointsToSummary
summariesForCallee)
                        paramNames :: [FunctionName]
paramNames = MacroDefinitionMap -> FunctionName -> [FunctionName]
getParamNamesFromDef (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) FunctionName
calleeName
                        -- The same substitution logic as in `analyzeStatementForPointers` is used here
                        -- to translate the summary's return values into the caller's context.
                        substitute :: AbstractLocation -> Set AbstractLocation
substitute AbstractLocation
loc = case AbstractLocation
loc of
                            VarLocation FunctionName
paramName ->
                                (case (FunctionName -> Bool) -> [FunctionName] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (FunctionName -> FunctionName -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionName
paramName) [FunctionName]
paramNames of
                                    Just Int
i  -> (case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i) of
                                                   C.UnaryExpr UnaryOp
C.UopAddress Node (Lexeme FunctionName)
innerExpr ->
                                                       let innerLoc :: AbstractLocation
innerLoc = case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
innerExpr of
                                                               C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) | FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) Bool -> Bool -> Bool
|| FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDecls PointsToContext FunctionName
ctx) -> FunctionName -> AbstractLocation
FunctionLocation FunctionName
name
                                                               NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
innerExpr
                                                       in AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
innerLoc
                                                   C.FunctionCall {} ->
                                                       (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a, b) -> a
fst ((Set AbstractLocation, Set (FunctionName, Context))
 -> Set AbstractLocation)
-> (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i)
                                                   C.VarExpr Lexeme FunctionName
_ ->
                                                       let argLoc :: AbstractLocation
argLoc = HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i)
                                                       in Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
argLoc) (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
argLoc PointsToMap
currentPtsMap)
                                                   NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a, b) -> a
fst ((Set AbstractLocation, Set (FunctionName, Context))
 -> Set AbstractLocation)
-> (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i))
                                    Maybe Int
Nothing -> if Set FunctionName -> [FunctionName] -> FunctionName -> Bool
isGlobalVar Set FunctionName
localVars [FunctionName]
paramNames FunctionName
paramName
                                               then AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
GlobalVarLocation FunctionName
paramName)
                                               else AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
VarLocation FunctionName
paramName))
                            FunctionLocation FunctionName
fName -> AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
FunctionLocation FunctionName
fName)
                            DerefLocation (VarLocation FunctionName
paramName) ->
                                (case (FunctionName -> Bool) -> [FunctionName] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (FunctionName -> FunctionName -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionName
paramName) [FunctionName]
paramNames of
                                    Just Int
i  -> (case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i) of
                                                   C.UnaryExpr UnaryOp
C.UopAddress Node (Lexeme FunctionName)
innerExpr ->
                                                       let innerLoc :: AbstractLocation
innerLoc = case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
innerExpr of
                                                               C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) | FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) Bool -> Bool -> Bool
|| FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDecls PointsToContext FunctionName
ctx) -> FunctionName -> AbstractLocation
FunctionLocation FunctionName
name
                                                               NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
innerExpr
                                                       in AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
innerLoc
                                                   C.FunctionCall {} ->
                                                       (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a, b) -> a
fst ((Set AbstractLocation, Set (FunctionName, Context))
 -> Set AbstractLocation)
-> (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i)
                                                   C.VarExpr Lexeme FunctionName
_ ->
                                                       let argLoc :: AbstractLocation
argLoc = HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i)
                                                       in Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
argLoc) (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
argLoc PointsToMap
currentPtsMap)
                                                   NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a, b) -> a
fst ((Set AbstractLocation, Set (FunctionName, Context))
 -> Set AbstractLocation)
-> (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
currentPtsMap ([Node (Lexeme FunctionName)]
args [Node (Lexeme FunctionName)] -> Int -> Node (Lexeme FunctionName)
forall a. [a] -> Int -> a
!! Int
i))
                                    Maybe Int
Nothing -> AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
loc)
                        -- A `ReturnLocation` in a summary means the function returns
                        -- one of its parameters. We substitute it with the actual
                        -- argument passed at the call site.
                            ReturnLocation FunctionName
fName ->
                                let calleeSummary :: PointsToSummaryData
calleeSummary = PointsToSummaryData
-> Maybe PointsToSummaryData -> PointsToSummaryData
forall a. a -> Maybe a -> a
fromMaybe PointsToSummaryData
emptySummaryData (FunctionName
-> Map FunctionName PointsToSummary -> Maybe PointsToSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
fName (PointsToContext FunctionName -> Map FunctionName PointsToSummary
forall l. PointsToContext l -> Map FunctionName PointsToSummary
ptcSummaries PointsToContext FunctionName
ctx) Maybe PointsToSummary
-> (PointsToSummary -> Maybe PointsToSummaryData)
-> Maybe PointsToSummaryData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PointsToSummary
sm -> Context -> PointsToSummary -> Maybe PointsToSummaryData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Context
newContext PointsToSummary
sm)
                                in Set AbstractLocation -> Set AbstractLocation
substituteSet (PointsToSummaryData -> Set AbstractLocation
returnPointsTo PointsToSummaryData
calleeSummary)
                            AbstractLocation
_ -> AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton AbstractLocation
loc
                        substituteSet :: Set AbstractLocation -> Set AbstractLocation
substituteSet = [Set AbstractLocation] -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set AbstractLocation] -> Set AbstractLocation)
-> (Set AbstractLocation -> [Set AbstractLocation])
-> Set AbstractLocation
-> Set AbstractLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbstractLocation -> Set AbstractLocation)
-> [AbstractLocation] -> [Set AbstractLocation]
forall a b. (a -> b) -> [a] -> [b]
map AbstractLocation -> Set AbstractLocation
substitute ([AbstractLocation] -> [Set AbstractLocation])
-> (Set AbstractLocation -> [AbstractLocation])
-> Set AbstractLocation
-> [Set AbstractLocation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set AbstractLocation -> [AbstractLocation]
forall a. Set a -> [a]
Set.toList
                    in
                        -- Special handling for `malloc`: we treat it as returning a unique
                        -- heap location based on the call site's node ID.
                        if FunctionName
calleeName FunctionName -> FunctionName -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionName
"malloc"
                        then (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (Int -> AbstractLocation
HeapLocation (Node (Lexeme FunctionName) -> Int
forall a. Hashable a => Node a -> Int
C.getNodeId Node (Lexeme FunctionName)
localExpr)), Set (FunctionName, Context)
forall a. Set a
Set.empty)
                        -- Otherwise, apply the substitution to the summary's `returnPointsTo`.
                        else (Set AbstractLocation -> Set AbstractLocation
substituteSet (PointsToSummaryData -> Set AbstractLocation
returnPointsTo PointsToSummaryData
summary), (FunctionName, Context) -> Set (FunctionName, Context)
forall a. a -> Set a
Set.singleton (FunctionName
calleeName, Context
newContext))

        -- Case: An indirect function call, e.g., `s->fp(x)`.
        C.FunctionCall (Fix (C.PointerAccess Node (Lexeme FunctionName)
ptrExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
fieldName))) [Node (Lexeme FunctionName)]
_ ->
            let
                -- First, evaluate the pointer expression to find potential structs.
                (Set AbstractLocation
ptrPointsTo, Set (FunctionName, Context)
work1) = Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
go Node (Lexeme FunctionName)
ptrExpr
                -- Then, find the field location within those structs.
                fieldLocs :: Set AbstractLocation
fieldLocs = (AbstractLocation -> AbstractLocation)
-> Set AbstractLocation -> Set AbstractLocation
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\AbstractLocation
loc -> AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
loc FunctionName
fieldName) Set AbstractLocation
ptrPointsTo
                -- Look up what those field locations point to, which should be functions.
                calleeLocs :: Set AbstractLocation
calleeLocs = Set (Set AbstractLocation) -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set AbstractLocation) -> Set AbstractLocation)
-> Set (Set AbstractLocation) -> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ (AbstractLocation -> Set AbstractLocation)
-> Set AbstractLocation -> Set (Set AbstractLocation)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\AbstractLocation
loc -> Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
loc PointsToMap
currentPtsMap)) Set AbstractLocation
fieldLocs
                calleeNames :: [FunctionName]
calleeNames = (AbstractLocation -> Maybe FunctionName)
-> [AbstractLocation] -> [FunctionName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case FunctionLocation FunctionName
name -> FunctionName -> Maybe FunctionName
forall a. a -> Maybe a
Just FunctionName
name; AbstractLocation
_ -> Maybe FunctionName
forall a. Maybe a
Nothing) (Set AbstractLocation -> [AbstractLocation]
forall a. Set a -> [a]
Set.toList Set AbstractLocation
calleeLocs)

                -- For each possible callee, get its return value from its summary.
                processCallee :: (Set AbstractLocation, Set (FunctionName, Context)) -> FunctionName -> (Set AbstractLocation, Set (FunctionName, Context))
                processCallee :: (Set AbstractLocation, Set (FunctionName, Context))
-> FunctionName
-> (Set AbstractLocation, Set (FunctionName, Context))
processCallee (Set AbstractLocation
accSet, Set (FunctionName, Context)
accWork) FunctionName
calleeName =
                    let
                        nodeId :: Int
nodeId = Node (Lexeme FunctionName) -> Int
forall a. Hashable a => Node a -> Int
C.getNodeId Node (Lexeme FunctionName)
localExpr
                        newContext :: Context
newContext = Int -> Int -> Context -> Context
pushContext Int
kLimit Int
nodeId (PointsToContext FunctionName -> Context
forall l. PointsToContext l -> Context
ptcCurrentContext PointsToContext FunctionName
ctx)
                        summariesForCallee :: PointsToSummary
summariesForCallee = PointsToSummary -> Maybe PointsToSummary -> PointsToSummary
forall a. a -> Maybe a -> a
fromMaybe PointsToSummary
forall k a. Map k a
Map.empty (FunctionName
-> Map FunctionName PointsToSummary -> Maybe PointsToSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
calleeName (PointsToContext FunctionName -> Map FunctionName PointsToSummary
forall l. PointsToContext l -> Map FunctionName PointsToSummary
ptcSummaries PointsToContext FunctionName
ctx))
                        summary :: PointsToSummaryData
summary = PointsToSummaryData
-> Maybe PointsToSummaryData -> PointsToSummaryData
forall a. a -> Maybe a -> a
fromMaybe (PointsToSummaryData
-> Maybe PointsToSummaryData -> PointsToSummaryData
forall a. a -> Maybe a -> a
fromMaybe PointsToSummaryData
emptySummaryData (Context -> PointsToSummary -> Maybe PointsToSummaryData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [] PointsToSummary
summariesForCallee)) (Context -> PointsToSummary -> Maybe PointsToSummaryData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Context
newContext PointsToSummary
summariesForCallee)
                    in
                        (Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set AbstractLocation
accSet (PointsToSummaryData -> Set AbstractLocation
returnPointsTo PointsToSummaryData
summary), Set (FunctionName, Context)
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (FunctionName, Context)
accWork ((FunctionName, Context) -> Set (FunctionName, Context)
forall a. a -> Set a
Set.singleton (FunctionName
calleeName, Context
newContext)))

            in
                ((Set AbstractLocation, Set (FunctionName, Context))
 -> FunctionName
 -> (Set AbstractLocation, Set (FunctionName, Context)))
-> (Set AbstractLocation, Set (FunctionName, Context))
-> [FunctionName]
-> (Set AbstractLocation, Set (FunctionName, Context))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Set AbstractLocation, Set (FunctionName, Context))
-> FunctionName
-> (Set AbstractLocation, Set (FunctionName, Context))
processCallee (Set AbstractLocation
forall a. Set a
Set.empty, Set (FunctionName, Context)
work1) [FunctionName]
calleeNames

        -- Case: `p->field`.
        C.PointerAccess Node (Lexeme FunctionName)
ptrExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
fieldName) ->
            let
                -- Find what `ptrExpr` points to.
                (Set AbstractLocation
ptrPointsTo, Set (FunctionName, Context)
work) = Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
go Node (Lexeme FunctionName)
ptrExpr
                -- Get the locations of the field for each of those base locations.
                fieldLocs :: Set AbstractLocation
fieldLocs = (AbstractLocation -> AbstractLocation)
-> Set AbstractLocation -> Set AbstractLocation
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\AbstractLocation
loc -> AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
loc FunctionName
fieldName) Set AbstractLocation
ptrPointsTo
                -- Look up what those field locations point to.
                results :: Set AbstractLocation
results = Set (Set AbstractLocation) -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set AbstractLocation) -> Set AbstractLocation)
-> Set (Set AbstractLocation) -> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ (AbstractLocation -> Set AbstractLocation)
-> Set AbstractLocation -> Set (Set AbstractLocation)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\AbstractLocation
loc -> Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
loc PointsToMap
currentPtsMap)) Set AbstractLocation
fieldLocs
            in FilePath
-> (Set AbstractLocation, Set (FunctionName, Context))
-> (Set AbstractLocation, Set (FunctionName, Context))
forall a. FilePath -> a -> a
dtrace ([FilePath] -> FilePath
unlines [ FilePath
"PointerAccess to " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
fieldName
                               , FilePath
"  ptrPointsTo: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
ptrPointsTo
                               , FilePath
"  fieldLocs: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
fieldLocs
                               , FilePath
"  results: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
results
                               ]) (Set AbstractLocation
results, Set (FunctionName, Context)
work)

        -- Case: `s.field`.
        C.MemberAccess Node (Lexeme FunctionName)
structExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
fieldName) ->
            let
                structLoc :: AbstractLocation
structLoc = HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
structExpr
                -- Check if the base is a union type
                baseVarName :: FunctionName
baseVarName = Node (Lexeme FunctionName) -> FunctionName
getBaseVarName Node (Lexeme FunctionName)
structExpr
                baseTypeNode :: Maybe (Node (Lexeme FunctionName))
baseTypeNode = FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
baseVarName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> Map FunctionName (Node (Lexeme l))
ptcVarTypes PointsToContext FunctionName
ctx)

                (Bool
isUnion, Set AbstractLocation
pointsToSet) = case Maybe (Node (Lexeme FunctionName))
baseTypeNode of
                    Just (Fix (C.TyUserDefined (C.L AlexPosn
_ LexemeClass
_ FunctionName
typeName))) ->
                        case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
typeName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> Map FunctionName (Node (Lexeme l))
ptcStructDefs PointsToContext FunctionName
ctx) of
                            Just (Fix (C.Typedef (Fix (C.Union Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
members)) Lexeme FunctionName
_)) ->
                                let memberNames :: [FunctionName]
memberNames = [Node (Lexeme FunctionName)] -> [FunctionName]
getMemberNames [Node (Lexeme FunctionName)]
members
                                    memberLocs :: [AbstractLocation]
memberLocs = [ AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
member | FunctionName
member <- [FunctionName]
memberNames ]
                                in (Bool
True, [Set AbstractLocation] -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((AbstractLocation -> Maybe (Set AbstractLocation))
-> [AbstractLocation] -> [Set AbstractLocation]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` PointsToMap
currentPtsMap) [AbstractLocation]
memberLocs))
                            Just (Fix (C.Union Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
members)) ->
                                let memberNames :: [FunctionName]
memberNames = [Node (Lexeme FunctionName)] -> [FunctionName]
getMemberNames [Node (Lexeme FunctionName)]
members
                                    memberLocs :: [AbstractLocation]
memberLocs = [ AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
member | FunctionName
member <- [FunctionName]
memberNames ]
                                in (Bool
True, [Set AbstractLocation] -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((AbstractLocation -> Maybe (Set AbstractLocation))
-> [AbstractLocation] -> [Set AbstractLocation]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` PointsToMap
currentPtsMap) [AbstractLocation]
memberLocs))
                            Maybe (Node (Lexeme FunctionName))
_ -> (Bool
False, Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (Maybe (Set AbstractLocation) -> Set AbstractLocation)
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
fieldName) PointsToMap
currentPtsMap)
                    Just (Fix (C.TyUnion (C.L AlexPosn
_ LexemeClass
_ FunctionName
typeName))) ->
                        case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
typeName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> Map FunctionName (Node (Lexeme l))
ptcStructDefs PointsToContext FunctionName
ctx) of
                            Just (Fix (C.Union Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
members)) ->
                                let memberNames :: [FunctionName]
memberNames = [Node (Lexeme FunctionName)] -> [FunctionName]
getMemberNames [Node (Lexeme FunctionName)]
members
                                    memberLocs :: [AbstractLocation]
memberLocs = [ AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
member | FunctionName
member <- [FunctionName]
memberNames ]
                                in (Bool
True, [Set AbstractLocation] -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((AbstractLocation -> Maybe (Set AbstractLocation))
-> [AbstractLocation] -> [Set AbstractLocation]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` PointsToMap
currentPtsMap) [AbstractLocation]
memberLocs))
                            Maybe (Node (Lexeme FunctionName))
_ -> (Bool
False, Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (Maybe (Set AbstractLocation) -> Set AbstractLocation)
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
fieldName) PointsToMap
currentPtsMap)
                    Maybe (Node (Lexeme FunctionName))
_ -> (Bool
False, Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (Maybe (Set AbstractLocation) -> Set AbstractLocation)
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation AbstractLocation
structLoc FunctionName
fieldName) PointsToMap
currentPtsMap)
            in
                FilePath
-> (Set AbstractLocation, Set (FunctionName, Context))
-> (Set AbstractLocation, Set (FunctionName, Context))
forall a. FilePath -> a -> a
dtrace ([FilePath] -> FilePath
unlines [ FilePath
"MemberAccess to " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
fieldName
                                , FilePath
"  structLoc: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom AbstractLocation
structLoc
                                , FilePath
"  isUnion: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
isUnion
                                , FilePath
"  pointsToSet: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set AbstractLocation -> FilePath
forall a. Show a => a -> FilePath
groom Set AbstractLocation
pointsToSet
                                ]) (Set AbstractLocation
pointsToSet, Set (FunctionName, Context)
forall a. Set a
Set.empty)

        -- Case: A variable `x`.
        C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) ->
            -- If it's a known function, return its location.
            if FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) Bool -> Bool -> Bool
|| FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDecls PointsToContext FunctionName
ctx)
            then (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
FunctionLocation FunctionName
name), Set (FunctionName, Context)
forall a. Set a
Set.empty)
            -- Otherwise, look it up in the current points-to map.
            else (Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FunctionName -> AbstractLocation
VarLocation FunctionName
name) PointsToMap
currentPtsMap), Set (FunctionName, Context)
forall a. Set a
Set.empty)

        -- Case: `&x`.
        C.UnaryExpr UnaryOp
C.UopAddress Node (Lexeme FunctionName)
inner ->
            case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
inner of
                -- If taking the address of a function, return a `FunctionLocation`.
                C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) | FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) Bool -> Bool -> Bool
|| FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FunctionName
name (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDecls PointsToContext FunctionName
ctx) ->
                    (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (FunctionName -> AbstractLocation
FunctionLocation FunctionName
name), Set (FunctionName, Context)
forall a. Set a
Set.empty)
                -- Otherwise, return the abstract location of the inner expression.
                NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> (AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (HasCallStack => Node (Lexeme FunctionName) -> AbstractLocation
Node (Lexeme FunctionName) -> AbstractLocation
toAbstractLocation Node (Lexeme FunctionName)
inner), Set (FunctionName, Context)
forall a. Set a
Set.empty)

        -- Case: `*p`.
        C.UnaryExpr UnaryOp
C.UopDeref Node (Lexeme FunctionName)
ptr ->
            -- First, find out what `ptr` points to.
            let (Set AbstractLocation
ptrPointsTo, Set (FunctionName, Context)
work) = Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
go Node (Lexeme FunctionName)
ptr
            -- The result is the union of what all of those locations point to.
            in (Set (Set AbstractLocation) -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set AbstractLocation) -> Set AbstractLocation)
-> Set (Set AbstractLocation) -> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ (AbstractLocation -> Set AbstractLocation)
-> Set AbstractLocation -> Set (Set AbstractLocation)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\AbstractLocation
loc -> Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
loc PointsToMap
currentPtsMap)) Set AbstractLocation
ptrPointsTo, Set (FunctionName, Context)
work)

        -- Case: `(T *)p`.
        C.CastExpr Node (Lexeme FunctionName)
_ Node (Lexeme FunctionName)
inner ->
            Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
go Node (Lexeme FunctionName)
inner

        -- Case: `p + 1`. For simplicity, we treat pointer arithmetic as returning
        -- a pointer to the same base location. This is an over-approximation but
        -- is often sufficient.
        C.BinaryExpr Node (Lexeme FunctionName)
lhs BinaryOp
C.BopPlus Node (Lexeme FunctionName)
_ ->
            Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
go Node (Lexeme FunctionName)
lhs

        -- Other expressions don't point to anything in this model.
        NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> (Set AbstractLocation
forall a. Set a
Set.empty, Set (FunctionName, Context)
forall a. Set a
Set.empty)



getParamName :: C.Node (C.Lexeme Text) -> Maybe Text
getParamName :: Node (Lexeme FunctionName) -> Maybe FunctionName
getParamName (Fix (C.VarDecl Node (Lexeme FunctionName)
_ (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) = FunctionName -> Maybe FunctionName
forall a. a -> Maybe a
Just FunctionName
name
getParamName Node (Lexeme FunctionName)
_                                    = Maybe FunctionName
forall a. Maybe a
Nothing

getParamNamesFromDef :: Map Text (C.Node (C.Lexeme Text)) -> Text -> [Text]
getParamNamesFromDef :: MacroDefinitionMap -> FunctionName -> [FunctionName]
getParamNamesFromDef MacroDefinitionMap
funcDefs FunctionName
funcName =
    case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
funcName MacroDefinitionMap
funcDefs of
        Just (Fix (C.FunctionDefn Scope
_ (Fix (C.FunctionPrototype Node (Lexeme FunctionName)
_ Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
params)) Node (Lexeme FunctionName)
_)) ->
            (Node (Lexeme FunctionName) -> Maybe FunctionName)
-> [Node (Lexeme FunctionName)] -> [FunctionName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme FunctionName) -> Maybe FunctionName
getParamName [Node (Lexeme FunctionName)]
params
        Maybe (Node (Lexeme FunctionName))
_ -> []

-- | A map from function names to their AST definitions.
type FunctionDefs = Map Text (C.Node (C.Lexeme Text))

-- | Finds all function definitions in the given translation units.
findFunctionDefs :: [(FilePath, [C.Node (C.Lexeme Text)])] -> FunctionDefs
findFunctionDefs :: [(FilePath, [Node (Lexeme FunctionName)])] -> MacroDefinitionMap
findFunctionDefs [(FilePath, [Node (Lexeme FunctionName)])]
tus = State MacroDefinitionMap ()
-> MacroDefinitionMap -> MacroDefinitionMap
forall s a. State s a -> s -> s
execState (AstActions (StateT MacroDefinitionMap Identity) FunctionName
-> [(FilePath, [Node (Lexeme FunctionName)])]
-> State MacroDefinitionMap ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT MacroDefinitionMap Identity) FunctionName
collector [(FilePath, [Node (Lexeme FunctionName)])]
tus) MacroDefinitionMap
forall k a. Map k a
Map.empty
  where
    collector :: AstActions (StateT MacroDefinitionMap Identity) FunctionName
collector = AstActions (StateT MacroDefinitionMap Identity) FunctionName
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
        { doNode :: FilePath
-> Node (Lexeme FunctionName)
-> State MacroDefinitionMap ()
-> State MacroDefinitionMap ()
doNode = \FilePath
_ Node (Lexeme FunctionName)
node State MacroDefinitionMap ()
act -> do
            case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
node of
                C.FunctionDefn Scope
_ (Fix (C.FunctionPrototype Node (Lexeme FunctionName)
_ (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) Node (Lexeme FunctionName)
_ ->
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
node)
                NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> () -> State MacroDefinitionMap ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            State MacroDefinitionMap ()
act
        }

-- | Finds all function declarations and definitions.
findFunctionDecls :: [(FilePath, [C.Node (C.Lexeme Text)])] -> FunctionDefs
findFunctionDecls :: [(FilePath, [Node (Lexeme FunctionName)])] -> MacroDefinitionMap
findFunctionDecls [(FilePath, [Node (Lexeme FunctionName)])]
tus = State MacroDefinitionMap ()
-> MacroDefinitionMap -> MacroDefinitionMap
forall s a. State s a -> s -> s
execState (AstActions (StateT MacroDefinitionMap Identity) FunctionName
-> [(FilePath, [Node (Lexeme FunctionName)])]
-> State MacroDefinitionMap ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT MacroDefinitionMap Identity) FunctionName
collector [(FilePath, [Node (Lexeme FunctionName)])]
tus) MacroDefinitionMap
forall k a. Map k a
Map.empty
  where
    collector :: AstActions (StateT MacroDefinitionMap Identity) FunctionName
collector = AstActions (StateT MacroDefinitionMap Identity) FunctionName
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
        { doNode :: FilePath
-> Node (Lexeme FunctionName)
-> State MacroDefinitionMap ()
-> State MacroDefinitionMap ()
doNode = \FilePath
_ Node (Lexeme FunctionName)
node State MacroDefinitionMap ()
act -> do
            case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
node of
                C.FunctionDefn Scope
_ (Fix (C.FunctionPrototype Node (Lexeme FunctionName)
_ (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) Node (Lexeme FunctionName)
_ ->
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
node)
                C.FunctionDecl Scope
_ (Fix (C.FunctionPrototype Node (Lexeme FunctionName)
_ (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) ->
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
node)
                NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> () -> State MacroDefinitionMap ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            State MacroDefinitionMap ()
act
        }

findToplevelMacros :: [C.Node (C.Lexeme Text)] -> MacroDefinitionMap
findToplevelMacros :: [Node (Lexeme FunctionName)] -> MacroDefinitionMap
findToplevelMacros [Node (Lexeme FunctionName)]
nodes =
    (MacroDefinitionMap
 -> Node (Lexeme FunctionName) -> MacroDefinitionMap)
-> MacroDefinitionMap
-> [Node (Lexeme FunctionName)]
-> MacroDefinitionMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\MacroDefinitionMap
acc Node (Lexeme FunctionName)
node -> case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
node of
        C.PreprocDefineMacro (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_ Node (Lexeme FunctionName)
_ -> FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
node MacroDefinitionMap
acc
        NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_                                       -> MacroDefinitionMap
acc
    ) MacroDefinitionMap
forall k a. Map k a
Map.empty [Node (Lexeme FunctionName)]
nodes

-- | The main entry point for the inter-procedural points-to analysis. It sets
-- up the initial context and kicks off the fixed-point iteration.
buildPointsToContext :: [(FilePath, [C.Node (C.Lexeme Text)])] -> CallGraph -> Map FunctionName PointsToSummary -> PointsToContext Text
buildPointsToContext :: [(FilePath, [Node (Lexeme FunctionName)])]
-> CallGraph
-> Map FunctionName PointsToSummary
-> PointsToContext FunctionName
buildPointsToContext [(FilePath, [Node (Lexeme FunctionName)])]
tus CallGraph
callGraph Map FunctionName PointsToSummary
initialSummaries =
    let
        funcDefs :: MacroDefinitionMap
funcDefs = [(FilePath, [Node (Lexeme FunctionName)])] -> MacroDefinitionMap
findFunctionDefs [(FilePath, [Node (Lexeme FunctionName)])]
tus
        funcDecls :: MacroDefinitionMap
funcDecls = [(FilePath, [Node (Lexeme FunctionName)])] -> MacroDefinitionMap
findFunctionDecls [(FilePath, [Node (Lexeme FunctionName)])]
tus
        structDefs :: MacroDefinitionMap
structDefs = [Node (Lexeme FunctionName)] -> MacroDefinitionMap
findStructOrUnionDefs (((FilePath, [Node (Lexeme FunctionName)])
 -> [Node (Lexeme FunctionName)])
-> [(FilePath, [Node (Lexeme FunctionName)])]
-> [Node (Lexeme FunctionName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath, [Node (Lexeme FunctionName)])
-> [Node (Lexeme FunctionName)]
forall a b. (a, b) -> b
snd [(FilePath, [Node (Lexeme FunctionName)])]
tus)
        toplevelMacros :: MacroDefinitionMap
toplevelMacros = ((FilePath, [Node (Lexeme FunctionName)]) -> MacroDefinitionMap)
-> [(FilePath, [Node (Lexeme FunctionName)])] -> MacroDefinitionMap
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Node (Lexeme FunctionName)] -> MacroDefinitionMap
findToplevelMacros ([Node (Lexeme FunctionName)] -> MacroDefinitionMap)
-> ((FilePath, [Node (Lexeme FunctionName)])
    -> [Node (Lexeme FunctionName)])
-> (FilePath, [Node (Lexeme FunctionName)])
-> MacroDefinitionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, [Node (Lexeme FunctionName)])
-> [Node (Lexeme FunctionName)]
forall a b. (a, b) -> b
snd) [(FilePath, [Node (Lexeme FunctionName)])]
tus

        -- The initial worklist contains all function definitions, each with an
        -- empty context, representing the most general analysis.
        worklist :: Worklist (FunctionName, [a])
worklist = [(FunctionName, [a])] -> Worklist (FunctionName, [a])
forall a. [a] -> Worklist a
fromList ([(FunctionName, [a])] -> Worklist (FunctionName, [a]))
-> [(FunctionName, [a])] -> Worklist (FunctionName, [a])
forall a b. (a -> b) -> a -> b
$ (FunctionName -> (FunctionName, [a]))
-> [FunctionName] -> [(FunctionName, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (, []) (MacroDefinitionMap -> [FunctionName]
forall k a. Map k a -> [k]
Map.keys MacroDefinitionMap
funcDefs)

        initialContext :: PointsToContext FunctionName
initialContext = CallGraph
-> Map FunctionName PointsToSummary
-> MacroDefinitionMap
-> MacroDefinitionMap
-> MacroDefinitionMap
-> MacroDefinitionMap
-> Context
-> Map (FunctionName, Context) (Set (FunctionName, Context))
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
-> Set FunctionName
-> MacroDefinitionMap
-> PointsToContext FunctionName
forall l.
CallGraph
-> Map FunctionName PointsToSummary
-> MacroDefinitionMap
-> MacroDefinitionMap
-> Map FunctionName (Node (Lexeme l))
-> Map FunctionName (Node (Lexeme l))
-> Context
-> Map (FunctionName, Context) (Set (FunctionName, Context))
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
-> Set FunctionName
-> MacroDefinitionMap
-> PointsToContext l
PointsToContext CallGraph
callGraph Map FunctionName PointsToSummary
initialSummaries MacroDefinitionMap
funcDefs MacroDefinitionMap
funcDecls MacroDefinitionMap
structDefs MacroDefinitionMap
forall k a. Map k a
Map.empty [] Map (FunctionName, Context) (Set (FunctionName, Context))
forall k a. Map k a
Map.empty Map (FunctionName, Context) (CFG FunctionName PointsToState)
forall k a. Map k a
Map.empty Set FunctionName
forall a. Set a
Set.empty MacroDefinitionMap
toplevelMacros
    in
        PointsToContext FunctionName
-> Worklist (FunctionName, Context) -> PointsToContext FunctionName
fixpointSummaries PointsToContext FunctionName
initialContext Worklist (FunctionName, Context)
forall a. Worklist (FunctionName, [a])
worklist

-- | Analyze a single function using the pre-computed summaries to get the final
-- points-to map at its exit points. This is useful for debugging or for
-- getting the final state of a specific function like `main`.
analyzeFunctionWithSummaries :: PointsToContext Text -> FunctionName -> PointsToMap
analyzeFunctionWithSummaries :: PointsToContext FunctionName -> FunctionName -> PointsToMap
analyzeFunctionWithSummaries PointsToContext FunctionName
ctx FunctionName
funcName =
    case FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
funcName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) of
        Maybe (Node (Lexeme FunctionName))
Nothing -> PointsToMap
forall k a. Map k a
Map.empty
        Just Node (Lexeme FunctionName)
funcDef ->
            let
                -- It's crucial to set the local variables for the function being
                -- analyzed, otherwise global/local distinction will be incorrect.
                localVars :: Set FunctionName
localVars = Set FunctionName -> Set FunctionName -> Set FunctionName
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([FunctionName] -> Set FunctionName
forall a. Ord a => [a] -> Set a
Set.fromList (MacroDefinitionMap -> FunctionName -> [FunctionName]
getParamNamesFromDef (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) FunctionName
funcName)) (Node (Lexeme FunctionName) -> Set FunctionName
findDeclaredVars Node (Lexeme FunctionName)
funcDef)
                varTypes :: MacroDefinitionMap
varTypes = Node (Lexeme FunctionName) -> MacroDefinitionMap
findVarTypes Node (Lexeme FunctionName)
funcDef
                ctxForFunc :: PointsToContext FunctionName
ctxForFunc = PointsToContext FunctionName
ctx { ptcCurrentContext :: Context
ptcCurrentContext = [], ptcLocalVars :: Set FunctionName
ptcLocalVars = Set FunctionName
localVars, ptcVarTypes :: MacroDefinitionMap
ptcVarTypes = MacroDefinitionMap
varTypes }
                -- Run the intra-procedural fixed-point analysis for this function.
                (CFG FunctionName PointsToState
finalCfg, Set (FunctionName, Context)
_) = PointsToContext FunctionName
-> FunctionName
-> CFG FunctionName PointsToState
-> (CFG FunctionName PointsToState, Set (FunctionName, Context))
forall (c :: * -> *) l a.
(DataFlow c l a, Show l, Ord l) =>
c l -> l -> CFG l a -> (CFG l a, Set (l, Context))
fixpoint PointsToContext FunctionName
ctxForFunc FunctionName
funcName (PointsToContext FunctionName
-> Node (Lexeme FunctionName)
-> PointsToState
-> CFG FunctionName PointsToState
forall (c :: * -> *) l a.
(DataFlow c l a, Pretty l, Ord l, Show l) =>
c l -> Node (Lexeme l) -> a -> CFG l a
buildCFG PointsToContext FunctionName
ctxForFunc Node (Lexeme FunctionName)
funcDef (PointsToContext FunctionName
-> Node (Lexeme FunctionName) -> PointsToState
createInitialFacts PointsToContext FunctionName
ctxForFunc Node (Lexeme FunctionName)
funcDef))
                -- Get the facts from all exit nodes of the CFG.
                exitNodes :: Context
exitNodes = (Int -> Bool) -> Context -> Context
forall a. (a -> Bool) -> [a] -> [a]
filter (\Int
n -> Context -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CFGNode FunctionName PointsToState -> Context
forall l a. CFGNode l a -> Context
cfgSuccs (FilePath
-> CFG FunctionName PointsToState
-> Int
-> CFGNode FunctionName PointsToState
forall k a. (Ord k, Show k) => FilePath -> Map k a -> k -> a
lookupOrError FilePath
"analyzeFunctionWithSummaries exitNodes" CFG FunctionName PointsToState
finalCfg Int
n))) (CFG FunctionName PointsToState -> Context
forall k a. Map k a -> [k]
Map.keys CFG FunctionName PointsToState
finalCfg)
                exitFacts :: [PointsToMap]
exitFacts = (Int -> PointsToMap) -> Context -> [PointsToMap]
forall a b. (a -> b) -> [a] -> [b]
map (PointsToState -> PointsToMap
ptsMap (PointsToState -> PointsToMap)
-> (Int -> PointsToState) -> Int -> PointsToMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFGNode FunctionName PointsToState -> PointsToState
forall l a. CFGNode l a -> a
cfgOutFacts (CFGNode FunctionName PointsToState -> PointsToState)
-> (Int -> CFGNode FunctionName PointsToState)
-> Int
-> PointsToState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> CFG FunctionName PointsToState
-> Int
-> CFGNode FunctionName PointsToState
forall k a. (Ord k, Show k) => FilePath -> Map k a -> k -> a
lookupOrError FilePath
"analyzeFunctionWithSummaries exitFacts" CFG FunctionName PointsToState
finalCfg) Context
exitNodes
            in
                -- Join the facts from all exit nodes to get the final points-to map.
                (PointsToMap -> PointsToMap -> PointsToMap)
-> PointsToMap -> [PointsToMap] -> PointsToMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Set AbstractLocation
 -> Set AbstractLocation -> Set AbstractLocation)
-> PointsToMap -> PointsToMap -> PointsToMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union) PointsToMap
forall k a. Map k a
Map.empty [PointsToMap]
exitFacts



getFuncNameFromDef :: C.Node (C.Lexeme Text) -> Text
getFuncNameFromDef :: Node (Lexeme FunctionName) -> FunctionName
getFuncNameFromDef (Fix (C.FunctionDefn Scope
_ (Fix (C.FunctionPrototype Node (Lexeme FunctionName)
_ (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) Node (Lexeme FunctionName)
_)) = FunctionName
name
getFuncNameFromDef (Fix (C.FunctionDecl Scope
_ (Fix (C.FunctionPrototype Node (Lexeme FunctionName)
_ (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)))) = FunctionName
name
getFuncNameFromDef Node (Lexeme FunctionName)
_ = FilePath -> FunctionName
forall a. HasCallStack => FilePath -> a
error FilePath
"Node is not a function definition or declaration"


-- | An empty points-to summary.
emptySummaryData :: PointsToSummaryData
emptySummaryData :: PointsToSummaryData
emptySummaryData = Set AbstractLocation -> PointsToMap -> PointsToSummaryData
PointsToSummaryData Set AbstractLocation
forall a. Set a
Set.empty PointsToMap
forall k a. Map k a
Map.empty

-- | The fixed-point iteration loop for computing function summaries. This is the
-- heart of the inter-procedural analysis.
fixpointSummaries :: PointsToContext Text -> Worklist (FunctionName, Context) -> PointsToContext Text
fixpointSummaries :: PointsToContext FunctionName
-> Worklist (FunctionName, Context) -> PointsToContext FunctionName
fixpointSummaries PointsToContext FunctionName
initialCtx Worklist (FunctionName, Context)
initialWorklist =
    let finalCtx :: PointsToContext FunctionName
finalCtx = PointsToContext FunctionName
-> Worklist (FunctionName, Context) -> PointsToContext FunctionName
go PointsToContext FunctionName
initialCtx Worklist (FunctionName, Context)
initialWorklist
        finalDynamicGraph :: Map (FunctionName, Context) (Set (FunctionName, Context))
finalDynamicGraph = PointsToContext FunctionName
-> Map (FunctionName, Context) (Set (FunctionName, Context))
forall l.
PointsToContext l
-> Map (FunctionName, Context) (Set (FunctionName, Context))
ptcDynamicCallGraph PointsToContext FunctionName
finalCtx
        -- After the analysis, convert the discovered dynamic call graph into the
        -- static `CallGraph` format for use by other analyses.
        finalStaticGraph :: CallGraph
finalStaticGraph = (CallGraph
 -> (FunctionName, Context)
 -> Set (FunctionName, Context)
 -> CallGraph)
-> CallGraph
-> Map (FunctionName, Context) (Set (FunctionName, Context))
-> CallGraph
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\CallGraph
acc (FunctionName
caller, Context
_) Set (FunctionName, Context)
dynCallees ->
                let
                    simpleCallees :: Map FunctionName (Set CallSite)
simpleCallees = (Set CallSite -> Set CallSite -> Set CallSite)
-> [(FunctionName, Set CallSite)]
-> Map FunctionName (Set CallSite)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set CallSite -> Set CallSite -> Set CallSite
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(FunctionName, Set CallSite)] -> Map FunctionName (Set CallSite))
-> [(FunctionName, Set CallSite)]
-> Map FunctionName (Set CallSite)
forall a b. (a -> b) -> a -> b
$
                        ((FunctionName, Context) -> Maybe (FunctionName, Set CallSite))
-> [(FunctionName, Context)] -> [(FunctionName, Set CallSite)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(FunctionName
callee, Context
calleeCtx) ->
                            if Context -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Context
calleeCtx then Maybe (FunctionName, Set CallSite)
forall a. Maybe a
Nothing else
                            (FunctionName, Set CallSite) -> Maybe (FunctionName, Set CallSite)
forall a. a -> Maybe a
Just (FunctionName
callee, CallSite -> Set CallSite
forall a. a -> Set a
Set.singleton (Int -> CallType -> CallSite
CallSite (Context -> Int
forall a. [a] -> a
head Context
calleeCtx) CallType
IndirectCall))
                        ) (Set (FunctionName, Context) -> [(FunctionName, Context)]
forall a. Set a -> [a]
Set.toList Set (FunctionName, Context)
dynCallees)
                    existingCallees :: Map FunctionName (Set CallSite)
existingCallees = Map FunctionName (Set CallSite)
-> Maybe (Map FunctionName (Set CallSite))
-> Map FunctionName (Set CallSite)
forall a. a -> Maybe a -> a
fromMaybe Map FunctionName (Set CallSite)
forall k a. Map k a
Map.empty (FunctionName
-> CallGraph -> Maybe (Map FunctionName (Set CallSite))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
caller CallGraph
acc)
                    newCallees :: Map FunctionName (Set CallSite)
newCallees = (Set CallSite -> Set CallSite -> Set CallSite)
-> Map FunctionName (Set CallSite)
-> Map FunctionName (Set CallSite)
-> Map FunctionName (Set CallSite)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set CallSite -> Set CallSite -> Set CallSite
forall a. Ord a => Set a -> Set a -> Set a
Set.union Map FunctionName (Set CallSite)
existingCallees Map FunctionName (Set CallSite)
simpleCallees
                in
                    FunctionName
-> Map FunctionName (Set CallSite) -> CallGraph -> CallGraph
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
caller Map FunctionName (Set CallSite)
newCallees CallGraph
acc
            ) CallGraph
forall k a. Map k a
Map.empty Map (FunctionName, Context) (Set (FunctionName, Context))
finalDynamicGraph
    in PointsToContext FunctionName
finalCtx { ptcCallGraph :: CallGraph
ptcCallGraph = CallGraph
finalStaticGraph }
  where
    go :: PointsToContext FunctionName
-> Worklist (FunctionName, Context) -> PointsToContext FunctionName
go PointsToContext FunctionName
ctx Worklist (FunctionName, Context)
worklist
        -- If the worklist is not empty, pop an item and process it.
        | Just ((FunctionName
funcName, Context
context), Worklist (FunctionName, Context)
worklist') <- Worklist (FunctionName, Context)
-> Maybe
     ((FunctionName, Context), Worklist (FunctionName, Context))
forall a. Worklist a -> Maybe (a, Worklist a)
pop Worklist (FunctionName, Context)
worklist =
            -- Don't analyze functions without a definition.
            if FunctionName -> MacroDefinitionMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember FunctionName
funcName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx)
            then PointsToContext FunctionName
-> Worklist (FunctionName, Context) -> PointsToContext FunctionName
go PointsToContext FunctionName
ctx Worklist (FunctionName, Context)
worklist'
            else
                let
                    tracePrefix :: FilePath
tracePrefix = FilePath
"PointsTo.fixpointSummaries (" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
funcName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"): "
                    funcDefs :: MacroDefinitionMap
funcDefs = PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx
                    funcDef :: Node (Lexeme FunctionName)
funcDef = Node (Lexeme FunctionName)
-> Maybe (Node (Lexeme FunctionName)) -> Node (Lexeme FunctionName)
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Node (Lexeme FunctionName)
forall a. HasCallStack => FilePath -> a
error (FilePath -> Node (Lexeme FunctionName))
-> FilePath -> Node (Lexeme FunctionName)
forall a b. (a -> b) -> a -> b
$ FilePath
"Function not found: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionName -> FilePath
T.unpack FunctionName
funcName) (FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
funcName MacroDefinitionMap
funcDefs)
                    -- Determine the set of local variables for the current function.
                    localVars :: Set FunctionName
localVars = Set FunctionName -> Set FunctionName -> Set FunctionName
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([FunctionName] -> Set FunctionName
forall a. Ord a => [a] -> Set a
Set.fromList (MacroDefinitionMap -> FunctionName -> [FunctionName]
getParamNamesFromDef MacroDefinitionMap
funcDefs FunctionName
funcName)) (Node (Lexeme FunctionName) -> Set FunctionName
findDeclaredVars Node (Lexeme FunctionName)
funcDef)
                    varTypes :: MacroDefinitionMap
varTypes = Node (Lexeme FunctionName) -> MacroDefinitionMap
findVarTypes Node (Lexeme FunctionName)
funcDef

                    -- Create a context specifically for this intra-procedural analysis.
                    ctxForIntra :: PointsToContext FunctionName
ctxForIntra = PointsToContext FunctionName
ctx { ptcCurrentContext :: Context
ptcCurrentContext = Context
context, ptcLocalVars :: Set FunctionName
ptcLocalVars = Set FunctionName
localVars, ptcVarTypes :: MacroDefinitionMap
ptcVarTypes = MacroDefinitionMap
varTypes }

                    -- Create the initial dataflow facts for the function's entry point.
                    initialFacts :: PointsToState
initialFacts = PointsToContext FunctionName
-> Node (Lexeme FunctionName) -> PointsToState
createInitialFacts PointsToContext FunctionName
ctxForIntra Node (Lexeme FunctionName)
funcDef
                    -- Run the intra-procedural analysis to get the final CFG and any newly discovered callees.
                    (CFG FunctionName PointsToState
finalCfg, Set (FunctionName, Context)
newCallees) = PointsToContext FunctionName
-> FunctionName
-> CFG FunctionName PointsToState
-> (CFG FunctionName PointsToState, Set (FunctionName, Context))
forall (c :: * -> *) l a.
(DataFlow c l a, Show l, Ord l) =>
c l -> l -> CFG l a -> (CFG l a, Set (l, Context))
fixpoint PointsToContext FunctionName
ctxForIntra FunctionName
funcName (PointsToContext FunctionName
-> Node (Lexeme FunctionName)
-> PointsToState
-> CFG FunctionName PointsToState
forall (c :: * -> *) l a.
(DataFlow c l a, Pretty l, Ord l, Show l) =>
c l -> Node (Lexeme l) -> a -> CFG l a
buildCFG PointsToContext FunctionName
ctxForIntra Node (Lexeme FunctionName)
funcDef PointsToState
initialFacts)

                    -- Update the dynamic call graph with the new findings.
                    dynamicCallGraph' :: Map (FunctionName, Context) (Set (FunctionName, Context))
dynamicCallGraph' = (FunctionName, Context)
-> Set (FunctionName, Context)
-> Map (FunctionName, Context) (Set (FunctionName, Context))
-> Map (FunctionName, Context) (Set (FunctionName, Context))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (FunctionName
funcName, Context
context) Set (FunctionName, Context)
newCallees (PointsToContext FunctionName
-> Map (FunctionName, Context) (Set (FunctionName, Context))
forall l.
PointsToContext l
-> Map (FunctionName, Context) (Set (FunctionName, Context))
ptcDynamicCallGraph PointsToContext FunctionName
ctx)

                    -- Add the newly discovered callees to the worklist.
                    worklistWithCallees :: Worklist (FunctionName, Context)
worklistWithCallees = [(FunctionName, Context)]
-> Worklist (FunctionName, Context)
-> Worklist (FunctionName, Context)
forall a. [a] -> Worklist a -> Worklist a
pushList (Set (FunctionName, Context) -> [(FunctionName, Context)]
forall a. Set a -> [a]
Set.toList Set (FunctionName, Context)
newCallees) Worklist (FunctionName, Context)
worklist'

                    -- Generate a new summary for the function based on the analysis results.
                    newSummaryData :: PointsToSummaryData
newSummaryData = PointsToContext FunctionName
-> Node (Lexeme FunctionName)
-> CFG FunctionName PointsToState
-> PointsToSummaryData
generateSummary PointsToContext FunctionName
ctxForIntra Node (Lexeme FunctionName)
funcDef CFG FunctionName PointsToState
finalCfg

                    -- Get the old summary to check if anything has changed.
                    oldSummaries :: PointsToSummary
oldSummaries = PointsToSummary -> Maybe PointsToSummary -> PointsToSummary
forall a. a -> Maybe a -> a
fromMaybe PointsToSummary
forall k a. Map k a
Map.empty (FunctionName
-> Map FunctionName PointsToSummary -> Maybe PointsToSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
funcName (PointsToContext FunctionName -> Map FunctionName PointsToSummary
forall l. PointsToContext l -> Map FunctionName PointsToSummary
ptcSummaries PointsToContext FunctionName
ctx))
                    oldSummaryData :: PointsToSummaryData
oldSummaryData = PointsToSummaryData
-> Maybe PointsToSummaryData -> PointsToSummaryData
forall a. a -> Maybe a -> a
fromMaybe PointsToSummaryData
emptySummaryData (Context -> PointsToSummary -> Maybe PointsToSummaryData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Context
context PointsToSummary
oldSummaries)

                    -- Update the global summary map with the new summary.
                    summaries' :: Map FunctionName PointsToSummary
summaries' = FunctionName
-> PointsToSummary
-> Map FunctionName PointsToSummary
-> Map FunctionName PointsToSummary
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
funcName (Context
-> PointsToSummaryData -> PointsToSummary -> PointsToSummary
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Context
context PointsToSummaryData
newSummaryData PointsToSummary
oldSummaries) (PointsToContext FunctionName -> Map FunctionName PointsToSummary
forall l. PointsToContext l -> Map FunctionName PointsToSummary
ptcSummaries PointsToContext FunctionName
ctx)

                    -- This is the core of the fixed-point logic:
                    -- If the summary has changed, we must re-analyze all functions
                    -- that call the current function (its dependents), because the
                    -- new information might change their analysis results.
                    worklist'' :: Worklist (FunctionName, Context)
worklist'' = if PointsToSummaryData
newSummaryData PointsToSummaryData -> PointsToSummaryData -> Bool
forall a. Eq a => a -> a -> Bool
/= PointsToSummaryData
oldSummaryData
                                 then
                                     let dependents :: Set (FunctionName, Context)
dependents = (Set (FunctionName, Context)
 -> (FunctionName, Context)
 -> Set (FunctionName, Context)
 -> Set (FunctionName, Context))
-> Set (FunctionName, Context)
-> Map (FunctionName, Context) (Set (FunctionName, Context))
-> Set (FunctionName, Context)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\Set (FunctionName, Context)
acc (FunctionName
caller, Context
callerCtx) Set (FunctionName, Context)
callees ->
                                                if (FunctionName, Context) -> Set (FunctionName, Context) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (FunctionName
funcName, Context
context) Set (FunctionName, Context)
callees
                                                then (FunctionName, Context)
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a. Ord a => a -> Set a -> Set a
Set.insert (FunctionName
caller, Context
callerCtx) Set (FunctionName, Context)
acc
                                                else Set (FunctionName, Context)
acc
                                            ) Set (FunctionName, Context)
forall a. Set a
Set.empty Map (FunctionName, Context) (Set (FunctionName, Context))
dynamicCallGraph'
                                     in FilePath
-> Worklist (FunctionName, Context)
-> Worklist (FunctionName, Context)
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"Summary changed, adding dependents to worklist: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set (FunctionName, Context) -> FilePath
forall a. Show a => a -> FilePath
groom Set (FunctionName, Context)
dependents) (Worklist (FunctionName, Context)
 -> Worklist (FunctionName, Context))
-> Worklist (FunctionName, Context)
-> Worklist (FunctionName, Context)
forall a b. (a -> b) -> a -> b
$ [(FunctionName, Context)]
-> Worklist (FunctionName, Context)
-> Worklist (FunctionName, Context)
forall a. [a] -> Worklist a -> Worklist a
pushList (Set (FunctionName, Context) -> [(FunctionName, Context)]
forall a. Set a -> [a]
Set.toList Set (FunctionName, Context)
dependents) Worklist (FunctionName, Context)
worklistWithCallees
                                 else
                                     Worklist (FunctionName, Context)
worklistWithCallees

                    -- Cache the analyzed CFG and update the context.
                    analyzedCfgs' :: Map (FunctionName, Context) (CFG FunctionName PointsToState)
analyzedCfgs' = (FunctionName, Context)
-> CFG FunctionName PointsToState
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (FunctionName
funcName, Context
context) CFG FunctionName PointsToState
finalCfg (PointsToContext FunctionName
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
forall l.
PointsToContext l
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
ptcAnalyzedCfgs PointsToContext FunctionName
ctx)
                    ctx' :: PointsToContext FunctionName
ctx' = PointsToContext FunctionName
ctx { ptcSummaries :: Map FunctionName PointsToSummary
ptcSummaries = Map FunctionName PointsToSummary
summaries', ptcDynamicCallGraph :: Map (FunctionName, Context) (Set (FunctionName, Context))
ptcDynamicCallGraph = Map (FunctionName, Context) (Set (FunctionName, Context))
dynamicCallGraph', ptcAnalyzedCfgs :: Map (FunctionName, Context) (CFG FunctionName PointsToState)
ptcAnalyzedCfgs = Map (FunctionName, Context) (CFG FunctionName PointsToState)
analyzedCfgs' }
                in
                    FilePath
-> PointsToContext FunctionName -> PointsToContext FunctionName
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"Processing " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
funcName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" in context " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Context -> FilePath
forall a. Show a => a -> FilePath
groom Context
context) (PointsToContext FunctionName -> PointsToContext FunctionName)
-> PointsToContext FunctionName -> PointsToContext FunctionName
forall a b. (a -> b) -> a -> b
$
                    FilePath
-> PointsToContext FunctionName -> PointsToContext FunctionName
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"Worklist: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Worklist (FunctionName, Context) -> FilePath
forall a. Show a => a -> FilePath
groom Worklist (FunctionName, Context)
worklist'') (PointsToContext FunctionName -> PointsToContext FunctionName)
-> PointsToContext FunctionName -> PointsToContext FunctionName
forall a b. (a -> b) -> a -> b
$
                    FilePath
-> PointsToContext FunctionName -> PointsToContext FunctionName
forall a. FilePath -> a -> a
dtrace (FilePath
tracePrefix FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"Summaries: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Map FunctionName PointsToSummary -> FilePath
forall a. Show a => a -> FilePath
groom Map FunctionName PointsToSummary
summaries') (PointsToContext FunctionName -> PointsToContext FunctionName)
-> PointsToContext FunctionName -> PointsToContext FunctionName
forall a b. (a -> b) -> a -> b
$
                    -- Recurse with the updated context and worklist.
                    PointsToContext FunctionName
-> Worklist (FunctionName, Context) -> PointsToContext FunctionName
go PointsToContext FunctionName
ctx' Worklist (FunctionName, Context)
worklist''
        -- If the worklist is empty, the analysis has reached a fixed point.
        | Bool
otherwise = PointsToContext FunctionName
ctx

isReturn :: C.Node (C.Lexeme Text) -> Bool
isReturn :: Node (Lexeme FunctionName) -> Bool
isReturn (Fix (C.Return Maybe (Node (Lexeme FunctionName))
_)) = Bool
True
isReturn Node (Lexeme FunctionName)
_                  = Bool
False

-- | Given a return statement, find what it points to.
getReturnPointsTo :: MacroDefinitionMap -> PointsToContext Text -> Set Text -> FunctionName -> PointsToMap -> C.Node (C.Lexeme Text) -> Set AbstractLocation
getReturnPointsTo :: MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> Set AbstractLocation
getReturnPointsTo MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx Set FunctionName
_ FunctionName
funcName PointsToMap
facts (Fix (C.Return (Just Node (Lexeme FunctionName)
expr))) =
    (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a, b) -> a
fst ((Set AbstractLocation, Set (FunctionName, Context))
 -> Set AbstractLocation)
-> (Set AbstractLocation, Set (FunctionName, Context))
-> Set AbstractLocation
forall a b. (a -> b) -> a -> b
$ MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet MacroDefinitionMap
currentMacros PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
funcName PointsToMap
facts Node (Lexeme FunctionName)
expr
getReturnPointsTo MacroDefinitionMap
_ PointsToContext FunctionName
_ Set FunctionName
_ FunctionName
_ PointsToMap
_ Node (Lexeme FunctionName)
_ = Set AbstractLocation
forall a. Set a
Set.empty

-- | Generates a function summary from the final CFG of a function.
-- A summary abstracts the function's behavior into two parts:
-- 1. `returnPointsTo`: What the function's return value can point to.
-- 2. `outputPointsTo`: The side effects on pointers passed as arguments.
generateSummary :: PointsToContext Text -> C.Node (C.Lexeme Text) -> CFG Text PointsToState -> PointsToSummaryData
generateSummary :: PointsToContext FunctionName
-> Node (Lexeme FunctionName)
-> CFG FunctionName PointsToState
-> PointsToSummaryData
generateSummary PointsToContext FunctionName
ctx Node (Lexeme FunctionName)
funcDef CFG FunctionName PointsToState
cfg =
    let
        funcName :: FunctionName
funcName = Node (Lexeme FunctionName) -> FunctionName
getFuncNameFromDef Node (Lexeme FunctionName)
funcDef
        paramNames :: Set FunctionName
paramNames = [FunctionName] -> Set FunctionName
forall a. Ord a => [a] -> Set a
Set.fromList ([FunctionName] -> Set FunctionName)
-> [FunctionName] -> Set FunctionName
forall a b. (a -> b) -> a -> b
$ MacroDefinitionMap -> FunctionName -> [FunctionName]
getParamNamesFromDef (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) FunctionName
funcName
        -- The initial facts at the function's entry.
        initialFacts :: PointsToMap
initialFacts = PointsToState -> PointsToMap
ptsMap (PointsToState -> PointsToMap) -> PointsToState -> PointsToMap
forall a b. (a -> b) -> a -> b
$ CFGNode FunctionName PointsToState -> PointsToState
forall l a. CFGNode l a -> a
cfgInFacts (FilePath
-> CFG FunctionName PointsToState
-> Int
-> CFGNode FunctionName PointsToState
forall k a. (Ord k, Show k) => FilePath -> Map k a -> k -> a
lookupOrError FilePath
"generateSummary initialFacts" CFG FunctionName PointsToState
cfg Int
0)
        -- The final facts at the function's exit.
        exitNodeId :: Int
exitNodeId = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> Context -> Maybe Int
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Int
n -> Context -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CFGNode FunctionName PointsToState -> Context
forall l a. CFGNode l a -> Context
cfgSuccs (FilePath
-> CFG FunctionName PointsToState
-> Int
-> CFGNode FunctionName PointsToState
forall k a. (Ord k, Show k) => FilePath -> Map k a -> k -> a
lookupOrError FilePath
"generateSummary exitNodeId" CFG FunctionName PointsToState
cfg Int
n))) (CFG FunctionName PointsToState -> Context
forall k a. Map k a -> [k]
Map.keys CFG FunctionName PointsToState
cfg)
        finalFacts :: PointsToMap
finalFacts = PointsToState -> PointsToMap
ptsMap (PointsToState -> PointsToMap) -> PointsToState -> PointsToMap
forall a b. (a -> b) -> a -> b
$ CFGNode FunctionName PointsToState -> PointsToState
forall l a. CFGNode l a -> a
cfgOutFacts (FilePath
-> CFG FunctionName PointsToState
-> Int
-> CFGNode FunctionName PointsToState
forall k a. (Ord k, Show k) => FilePath -> Map k a -> k -> a
lookupOrError FilePath
"generateSummary finalFacts" CFG FunctionName PointsToState
cfg Int
exitNodeId)

        -- Find all return statements in the CFG.
        returnStmts :: [Node (Lexeme FunctionName)]
returnStmts = (CFGNode FunctionName PointsToState
 -> [Node (Lexeme FunctionName)])
-> [CFGNode FunctionName PointsToState]
-> [Node (Lexeme FunctionName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Node (Lexeme FunctionName) -> Bool)
-> [Node (Lexeme FunctionName)] -> [Node (Lexeme FunctionName)]
forall a. (a -> Bool) -> [a] -> [a]
filter Node (Lexeme FunctionName) -> Bool
isReturn ([Node (Lexeme FunctionName)] -> [Node (Lexeme FunctionName)])
-> (CFGNode FunctionName PointsToState
    -> [Node (Lexeme FunctionName)])
-> CFGNode FunctionName PointsToState
-> [Node (Lexeme FunctionName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFGNode FunctionName PointsToState -> [Node (Lexeme FunctionName)]
forall l a. CFGNode l a -> [Node (Lexeme l)]
cfgStmts) (CFG FunctionName PointsToState
-> [CFGNode FunctionName PointsToState]
forall k a. Map k a -> [a]
Map.elems CFG FunctionName PointsToState
cfg)

        -- Collect the points-to sets from all return statements.
        returnSets :: [Set AbstractLocation]
returnSets = (Node (Lexeme FunctionName) -> Set AbstractLocation)
-> [Node (Lexeme FunctionName)] -> [Set AbstractLocation]
forall a b. (a -> b) -> [a] -> [b]
map (\Node (Lexeme FunctionName)
stmt ->
            let node :: CFGNode FunctionName PointsToState
node = CFGNode FunctionName PointsToState
-> Maybe (CFGNode FunctionName PointsToState)
-> CFGNode FunctionName PointsToState
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> CFGNode FunctionName PointsToState
forall a. HasCallStack => FilePath -> a
error FilePath
"cannot find node for stmt") ((CFGNode FunctionName PointsToState -> Bool)
-> [CFGNode FunctionName PointsToState]
-> Maybe (CFGNode FunctionName PointsToState)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\CFGNode FunctionName PointsToState
n -> Node (Lexeme FunctionName)
stmt Node (Lexeme FunctionName) -> [Node (Lexeme FunctionName)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CFGNode FunctionName PointsToState -> [Node (Lexeme FunctionName)]
forall l a. CFGNode l a -> [Node (Lexeme l)]
cfgStmts CFGNode FunctionName PointsToState
n) (CFG FunctionName PointsToState
-> [CFGNode FunctionName PointsToState]
forall k a. Map k a -> [a]
Map.elems CFG FunctionName PointsToState
cfg))
                stmtsBefore :: [Node (Lexeme FunctionName)]
stmtsBefore = (Node (Lexeme FunctionName) -> Bool)
-> [Node (Lexeme FunctionName)] -> [Node (Lexeme FunctionName)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Node (Lexeme FunctionName) -> Node (Lexeme FunctionName) -> Bool
forall a. Eq a => a -> a -> Bool
/= Node (Lexeme FunctionName)
stmt) (CFGNode FunctionName PointsToState -> [Node (Lexeme FunctionName)]
forall l a. CFGNode l a -> [Node (Lexeme l)]
cfgStmts CFGNode FunctionName PointsToState
node)
                (PointsToState
stateBefore, Set (FunctionName, Context)
_) = ((PointsToState, Set (FunctionName, Context))
 -> Node (Lexeme FunctionName)
 -> (PointsToState, Set (FunctionName, Context)))
-> (PointsToState, Set (FunctionName, Context))
-> [Node (Lexeme FunctionName)]
-> (PointsToState, Set (FunctionName, Context))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                    (\(PointsToState
accFacts, Set (FunctionName, Context)
accWork) Node (Lexeme FunctionName)
s ->
                        let (PointsToState
newFacts, Set (FunctionName, Context)
newWork) = PointsToContext FunctionName
-> FunctionName
-> PointsToState
-> Node (Lexeme FunctionName)
-> (PointsToState, Set (FunctionName, Context))
transferPointsToState PointsToContext FunctionName
ctx FunctionName
funcName PointsToState
accFacts Node (Lexeme FunctionName)
s
                        in (PointsToState
newFacts, Set (FunctionName, Context)
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (FunctionName, Context)
accWork Set (FunctionName, Context)
newWork))
                    (CFGNode FunctionName PointsToState -> PointsToState
forall l a. CFGNode l a -> a
cfgInFacts CFGNode FunctionName PointsToState
node, Set (FunctionName, Context)
forall a. Set a
Set.empty)
                    [Node (Lexeme FunctionName)]
stmtsBefore
            in MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> Set AbstractLocation
getReturnPointsTo (PointsToState -> MacroDefinitionMap
ptsMacros PointsToState
stateBefore) PointsToContext FunctionName
ctx Set FunctionName
paramNames FunctionName
funcName (PointsToState -> PointsToMap
ptsMap PointsToState
stateBefore) Node (Lexeme FunctionName)
stmt
            ) [Node (Lexeme FunctionName)]
returnStmts
        finalReturnPointsTo :: Set AbstractLocation
finalReturnPointsTo = (Set AbstractLocation
 -> Set AbstractLocation -> Set AbstractLocation)
-> Set AbstractLocation
-> [Set AbstractLocation]
-> Set AbstractLocation
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set AbstractLocation
forall a. Set a
Set.empty [Set AbstractLocation]
returnSets

        -- Create a reverse map from what parameters point to, back to the parameter itself.
        -- This is not currently used but could be useful for more complex summary generation.
        _paramDerefMap :: Map AbstractLocation AbstractLocation
_paramDerefMap = (Map AbstractLocation AbstractLocation
 -> FunctionName -> Map AbstractLocation AbstractLocation)
-> Map AbstractLocation AbstractLocation
-> Set FunctionName
-> Map AbstractLocation AbstractLocation
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\Map AbstractLocation AbstractLocation
acc FunctionName
pName ->
                let
                    pLoc :: AbstractLocation
pLoc = FunctionName -> AbstractLocation
VarLocation FunctionName
pName
                    pointsToSet :: Set AbstractLocation
pointsToSet = Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
pLoc PointsToMap
initialFacts)
                    derefParam :: AbstractLocation
derefParam = AbstractLocation -> AbstractLocation
DerefLocation AbstractLocation
pLoc
                in
                    (Map AbstractLocation AbstractLocation
 -> AbstractLocation -> Map AbstractLocation AbstractLocation)
-> Map AbstractLocation AbstractLocation
-> Set AbstractLocation
-> Map AbstractLocation AbstractLocation
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\Map AbstractLocation AbstractLocation
m AbstractLocation
pointedToLoc -> AbstractLocation
-> AbstractLocation
-> Map AbstractLocation AbstractLocation
-> Map AbstractLocation AbstractLocation
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
pointedToLoc AbstractLocation
derefParam Map AbstractLocation AbstractLocation
m) Map AbstractLocation AbstractLocation
acc Set AbstractLocation
pointsToSet
            ) Map AbstractLocation AbstractLocation
forall k a. Map k a
Map.empty Set FunctionName
paramNames

        -- Find side effects on pointer parameters by comparing the initial and final
        -- points-to maps.
        outputMap :: PointsToMap
outputMap = (PointsToMap
 -> AbstractLocation -> Set AbstractLocation -> PointsToMap)
-> PointsToMap -> PointsToMap -> PointsToMap
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\PointsToMap
acc AbstractLocation
loc Set AbstractLocation
val ->
            let
                -- Helper to find which parameter's data is being modified.
                _findParamForLoc :: AbstractLocation -> Maybe FunctionName
_findParamForLoc AbstractLocation
l = (Maybe FunctionName -> FunctionName -> Maybe FunctionName)
-> Maybe FunctionName -> Set FunctionName -> Maybe FunctionName
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\Maybe FunctionName
found FunctionName
pName ->
                    case Maybe FunctionName
found of
                        Just FunctionName
_  -> Maybe FunctionName
found
                        Maybe FunctionName
Nothing ->
                            let
                                pLoc :: AbstractLocation
pLoc = FunctionName -> AbstractLocation
VarLocation FunctionName
pName
                                pointsToSet :: Set AbstractLocation
pointsToSet = Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
pLoc PointsToMap
initialFacts)
                            in if AbstractLocation -> Set AbstractLocation -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member AbstractLocation
l Set AbstractLocation
pointsToSet then FunctionName -> Maybe FunctionName
forall a. a -> Maybe a
Just FunctionName
pName else Maybe FunctionName
forall a. Maybe a
Nothing
                  ) Maybe FunctionName
forall a. Maybe a
Nothing Set FunctionName
paramNames

                -- Build the LHS of the summary's side effect map. For example, if
                -- parameter `p` is modified via `*p = ...`, the summary LHS will be
                -- `DerefLocation(VarLocation("p"))`.
                buildSummaryLhs :: FunctionName -> Maybe AbstractLocation
buildSummaryLhs FunctionName
pName = case AbstractLocation
loc of
                    FieldLocation base field | AbstractLocation -> Set AbstractLocation -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member AbstractLocation
base (Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FunctionName -> AbstractLocation
VarLocation FunctionName
pName) PointsToMap
initialFacts)) ->
                        AbstractLocation -> Maybe AbstractLocation
forall a. a -> Maybe a
Just (AbstractLocation -> Maybe AbstractLocation)
-> AbstractLocation -> Maybe AbstractLocation
forall a b. (a -> b) -> a -> b
$ AbstractLocation -> FunctionName -> AbstractLocation
FieldLocation (AbstractLocation -> AbstractLocation
DerefLocation (FunctionName -> AbstractLocation
VarLocation FunctionName
pName)) FunctionName
field
                    AbstractLocation
_ -> if AbstractLocation -> Set AbstractLocation -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member AbstractLocation
loc (Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FunctionName -> AbstractLocation
VarLocation FunctionName
pName) PointsToMap
initialFacts))
                         then AbstractLocation -> Maybe AbstractLocation
forall a. a -> Maybe a
Just (AbstractLocation -> Maybe AbstractLocation)
-> AbstractLocation -> Maybe AbstractLocation
forall a b. (a -> b) -> a -> b
$ AbstractLocation -> AbstractLocation
DerefLocation (FunctionName -> AbstractLocation
VarLocation FunctionName
pName)
                         else Maybe AbstractLocation
forall a. Maybe a
Nothing

                -- Find which parameter's data is being modified.
                paramName :: Maybe FunctionName
paramName = (Maybe FunctionName -> FunctionName -> Maybe FunctionName)
-> Maybe FunctionName -> Set FunctionName -> Maybe FunctionName
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\Maybe FunctionName
found FunctionName
pName ->
                    case Maybe FunctionName
found of
                        Just FunctionName
_ -> Maybe FunctionName
found
                        Maybe FunctionName
Nothing -> if Maybe AbstractLocation -> Bool
forall a. Maybe a -> Bool
isJust (FunctionName -> Maybe AbstractLocation
buildSummaryLhs FunctionName
pName) then FunctionName -> Maybe FunctionName
forall a. a -> Maybe a
Just FunctionName
pName else Maybe FunctionName
forall a. Maybe a
Nothing
                  ) Maybe FunctionName
forall a. Maybe a
Nothing Set FunctionName
paramNames
            in
            case Maybe FunctionName
paramName of
                Just FunctionName
p ->
                    let summaryLhs :: AbstractLocation
summaryLhs = Maybe AbstractLocation -> AbstractLocation
forall a. HasCallStack => Maybe a -> a
fromJust (FunctionName -> Maybe AbstractLocation
buildSummaryLhs FunctionName
p)
                        existingVal :: Set AbstractLocation
existingVal = Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
summaryLhs PointsToMap
acc)
                    in AbstractLocation
-> Set AbstractLocation -> PointsToMap -> PointsToMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AbstractLocation
summaryLhs (Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set AbstractLocation
val Set AbstractLocation
existingVal) PointsToMap
acc
                Maybe FunctionName
Nothing -> PointsToMap
acc
            -- We only consider facts that have changed from the initial state.
            ) PointsToMap
forall k a. Map k a
Map.empty PointsToMap
finalFacts

        summary :: PointsToSummaryData
summary = Set AbstractLocation -> PointsToMap -> PointsToSummaryData
PointsToSummaryData Set AbstractLocation
finalReturnPointsTo PointsToMap
outputMap
    in
        FilePath -> PointsToSummaryData -> PointsToSummaryData
forall a. FilePath -> a -> a
dtrace ([FilePath] -> FilePath
unlines [ FilePath
"PointsTo.generateSummary (" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
funcName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"):"
                        , FilePath
"  SUMMARY: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToSummaryData -> FilePath
forall a. Show a => a -> FilePath
groom PointsToSummaryData
summary
                        ]) PointsToSummaryData
summary


getParamsFromDef :: C.Node (C.Lexeme Text) -> [C.Node (C.Lexeme Text)]
getParamsFromDef :: Node (Lexeme FunctionName) -> [Node (Lexeme FunctionName)]
getParamsFromDef (Fix (C.FunctionDefn Scope
_ (Fix (C.FunctionPrototype Node (Lexeme FunctionName)
_ Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
params)) Node (Lexeme FunctionName)
_)) = [Node (Lexeme FunctionName)]
params
getParamsFromDef (Fix (C.FunctionDecl Scope
_ (Fix (C.FunctionPrototype Node (Lexeme FunctionName)
_ Lexeme FunctionName
_ [Node (Lexeme FunctionName)]
params)))) = [Node (Lexeme FunctionName)]
params
getParamsFromDef Node (Lexeme FunctionName)
_ = []

-- | Given a callee and its context, find all the call sites (caller function,
-- caller context, and the call statement AST node) that could have resulted
-- in this call.
findCallersOf :: PointsToContext Text -> FunctionName -> Context -> [(FunctionName, Context, C.Node (C.Lexeme Text))]
findCallersOf :: PointsToContext FunctionName
-> FunctionName
-> Context
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
findCallersOf PointsToContext FunctionName
ctx FunctionName
calleeName Context
calleeContext =
    let
        dynamicCallGraph :: Map (FunctionName, Context) (Set (FunctionName, Context))
dynamicCallGraph = PointsToContext FunctionName
-> Map (FunctionName, Context) (Set (FunctionName, Context))
forall l.
PointsToContext l
-> Map (FunctionName, Context) (Set (FunctionName, Context))
ptcDynamicCallGraph PointsToContext FunctionName
ctx
        -- The context of the callee contains the node ID of the call site.
        callSiteNodeId :: Int
callSiteNodeId = Context -> Int
forall a. [a] -> a
head Context
calleeContext

        -- Helper to find the specific statement in a CFG that corresponds to a node ID.
        findCallingStmt :: CFG Text PointsToState -> Maybe (C.Node (C.Lexeme Text))
        findCallingStmt :: CFG FunctionName PointsToState
-> Maybe (Node (Lexeme FunctionName))
findCallingStmt CFG FunctionName PointsToState
cfg =
            let allStmts :: [Node (Lexeme FunctionName)]
allStmts = (CFGNode FunctionName PointsToState
 -> [Node (Lexeme FunctionName)])
-> [CFGNode FunctionName PointsToState]
-> [Node (Lexeme FunctionName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CFGNode FunctionName PointsToState -> [Node (Lexeme FunctionName)]
forall l a. CFGNode l a -> [Node (Lexeme l)]
cfgStmts (CFG FunctionName PointsToState
-> [CFGNode FunctionName PointsToState]
forall k a. Map k a -> [a]
Map.elems CFG FunctionName PointsToState
cfg)

                -- Search inside a statement for a node with the target nodeId (hash).
                -- If found, return the top-level statement itself.
                findNodeInStmt :: C.Node (C.Lexeme Text) -> Maybe (C.Node (C.Lexeme Text))
                findNodeInStmt :: Node (Lexeme FunctionName) -> Maybe (Node (Lexeme FunctionName))
findNodeInStmt Node (Lexeme FunctionName)
topStmt =
                    let
                        collector :: AstActions
  (StateT (Maybe (Node (Lexeme FunctionName))) Identity) FunctionName
collector = AstActions
  (StateT (Maybe (Node (Lexeme FunctionName))) Identity) FunctionName
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions {
                            doNode :: FilePath
-> Node (Lexeme FunctionName)
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
doNode = \FilePath
_ (Node (Lexeme FunctionName)
node :: C.Node (C.Lexeme Text)) StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
act -> do
                                -- If we found it, stop searching.
                                StateT
  (Maybe (Node (Lexeme FunctionName)))
  Identity
  (Maybe (Node (Lexeme FunctionName)))
forall s (m :: * -> *). MonadState s m => m s
get StateT
  (Maybe (Node (Lexeme FunctionName)))
  Identity
  (Maybe (Node (Lexeme FunctionName)))
-> (Maybe (Node (Lexeme FunctionName))
    -> StateT (Maybe (Node (Lexeme FunctionName))) Identity ())
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                    Just Node (Lexeme FunctionName)
_ -> () -> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                    Maybe (Node (Lexeme FunctionName))
Nothing -> do
                                        Bool
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Node (Lexeme FunctionName) -> Int
forall a. Hashable a => Node a -> Int
C.getNodeId Node (Lexeme FunctionName)
node Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
callSiteNodeId) (StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
 -> StateT (Maybe (Node (Lexeme FunctionName))) Identity ())
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe (Node (Lexeme FunctionName))
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Node (Lexeme FunctionName) -> Maybe (Node (Lexeme FunctionName))
forall a. a -> Maybe a
Just Node (Lexeme FunctionName)
topStmt)
                                        StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
act
                        }
                    in
                        StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
-> Maybe (Node (Lexeme FunctionName))
-> Maybe (Node (Lexeme FunctionName))
forall s a. State s a -> s -> s
execState (AstActions
  (StateT (Maybe (Node (Lexeme FunctionName))) Identity) FunctionName
-> [Node (Lexeme FunctionName)]
-> StateT (Maybe (Node (Lexeme FunctionName))) Identity ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions
  (StateT (Maybe (Node (Lexeme FunctionName))) Identity) FunctionName
collector [Node (Lexeme FunctionName)
topStmt]) Maybe (Node (Lexeme FunctionName))
forall a. Maybe a
Nothing
            in
                -- Find the first statement that contains the node we're looking for.
                [Maybe (Node (Lexeme FunctionName))]
-> Maybe (Node (Lexeme FunctionName))
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((Node (Lexeme FunctionName) -> Maybe (Node (Lexeme FunctionName)))
-> [Node (Lexeme FunctionName)]
-> [Maybe (Node (Lexeme FunctionName))]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme FunctionName) -> Maybe (Node (Lexeme FunctionName))
findNodeInStmt [Node (Lexeme FunctionName)]
allStmts)

        -- Iterate through the dynamic call graph to find matching callers.
        callers :: [(FunctionName, Context, Node (Lexeme FunctionName))]
callers = ([(FunctionName, Context, Node (Lexeme FunctionName))]
 -> (FunctionName, Context)
 -> Set (FunctionName, Context)
 -> [(FunctionName, Context, Node (Lexeme FunctionName))])
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> Map (FunctionName, Context) (Set (FunctionName, Context))
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\[(FunctionName, Context, Node (Lexeme FunctionName))]
acc (FunctionName
caller, Context
callerCtx) Set (FunctionName, Context)
callees ->
                FilePath
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
forall a. FilePath -> a -> a
dtrace (FilePath
"findCallersOf: checking caller (" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
caller FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
", " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Context -> FilePath
forall a. Show a => a -> FilePath
groom Context
callerCtx FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
") with callees " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set (FunctionName, Context) -> FilePath
forall a. Show a => a -> FilePath
groom Set (FunctionName, Context)
callees) ([(FunctionName, Context, Node (Lexeme FunctionName))]
 -> [(FunctionName, Context, Node (Lexeme FunctionName))])
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
forall a b. (a -> b) -> a -> b
$
                if (FunctionName, Context) -> Set (FunctionName, Context) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (FunctionName
calleeName, Context
calleeContext) Set (FunctionName, Context)
callees
                then case (FunctionName, Context)
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
-> Maybe (CFG FunctionName PointsToState)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FunctionName
caller, Context
callerCtx) (PointsToContext FunctionName
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
forall l.
PointsToContext l
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
ptcAnalyzedCfgs PointsToContext FunctionName
ctx) of
                        Just CFG FunctionName PointsToState
cfg -> case CFG FunctionName PointsToState
-> Maybe (Node (Lexeme FunctionName))
findCallingStmt CFG FunctionName PointsToState
cfg of
                            Just Node (Lexeme FunctionName)
stmt -> (FunctionName
caller, Context
callerCtx, Node (Lexeme FunctionName)
stmt) (FunctionName, Context, Node (Lexeme FunctionName))
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
forall a. a -> [a] -> [a]
: [(FunctionName, Context, Node (Lexeme FunctionName))]
acc
                            Maybe (Node (Lexeme FunctionName))
Nothing   -> FilePath
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
forall a. FilePath -> a -> a
dtrace FilePath
"findCallersOf: findCallingStmt failed" [(FunctionName, Context, Node (Lexeme FunctionName))]
acc
                        Maybe (CFG FunctionName PointsToState)
Nothing -> FilePath
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
forall a. FilePath -> a -> a
dtrace FilePath
"findCallersOf: CFG not found" [(FunctionName, Context, Node (Lexeme FunctionName))]
acc
                else [(FunctionName, Context, Node (Lexeme FunctionName))]
acc
            ) [] Map (FunctionName, Context) (Set (FunctionName, Context))
dynamicCallGraph
    in
        FilePath
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
forall a. FilePath -> a -> a
dtrace (FilePath
"findCallersOf for " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
calleeName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" in context " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Context -> FilePath
forall a. Show a => a -> FilePath
groom Context
calleeContext FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" found callers: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(FunctionName, Context)] -> FilePath
forall a. Show a => a -> FilePath
groom (((FunctionName, Context, Node (Lexeme FunctionName))
 -> (FunctionName, Context))
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> [(FunctionName, Context)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FunctionName
f,Context
c,Node (Lexeme FunctionName)
_) -> (FunctionName
f,Context
c)) [(FunctionName, Context, Node (Lexeme FunctionName))]
callers)) [(FunctionName, Context, Node (Lexeme FunctionName))]
callers

-- | Computes the initial points-to map for a callee function based on the state
-- at a specific call site in the caller.
computeFactsFromCallSite :: PointsToContext Text -> FunctionName -> (FunctionName, Context, C.Node (C.Lexeme Text)) -> PointsToState
computeFactsFromCallSite :: PointsToContext FunctionName
-> FunctionName
-> (FunctionName, Context, Node (Lexeme FunctionName))
-> PointsToState
computeFactsFromCallSite PointsToContext FunctionName
ctx FunctionName
calleeName (FunctionName
callerName, Context
callerContext, Node (Lexeme FunctionName)
callStmt) =
    let
        callerCfg :: CFG FunctionName PointsToState
callerCfg = CFG FunctionName PointsToState
-> Maybe (CFG FunctionName PointsToState)
-> CFG FunctionName PointsToState
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> CFG FunctionName PointsToState
forall a. HasCallStack => FilePath -> a
error (FilePath -> CFG FunctionName PointsToState)
-> FilePath -> CFG FunctionName PointsToState
forall a b. (a -> b) -> a -> b
$ FilePath
"CFG not found for " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
callerName) ((FunctionName, Context)
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
-> Maybe (CFG FunctionName PointsToState)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FunctionName
callerName, Context
callerContext) (PointsToContext FunctionName
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
forall l.
PointsToContext l
-> Map (FunctionName, Context) (CFG FunctionName PointsToState)
ptcAnalyzedCfgs PointsToContext FunctionName
ctx))
        callNode :: CFGNode FunctionName PointsToState
callNode = CFGNode FunctionName PointsToState
-> Maybe (CFGNode FunctionName PointsToState)
-> CFGNode FunctionName PointsToState
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> CFGNode FunctionName PointsToState
forall a. HasCallStack => FilePath -> a
error FilePath
"call node not found in CFG") (Maybe (CFGNode FunctionName PointsToState)
 -> CFGNode FunctionName PointsToState)
-> Maybe (CFGNode FunctionName PointsToState)
-> CFGNode FunctionName PointsToState
forall a b. (a -> b) -> a -> b
$ (CFGNode FunctionName PointsToState -> Bool)
-> [CFGNode FunctionName PointsToState]
-> Maybe (CFGNode FunctionName PointsToState)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\CFGNode FunctionName PointsToState
n -> Node (Lexeme FunctionName)
callStmt Node (Lexeme FunctionName) -> [Node (Lexeme FunctionName)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CFGNode FunctionName PointsToState -> [Node (Lexeme FunctionName)]
forall l a. CFGNode l a -> [Node (Lexeme l)]
cfgStmts CFGNode FunctionName PointsToState
n) (CFG FunctionName PointsToState
-> [CFGNode FunctionName PointsToState]
forall k a. Map k a -> [a]
Map.elems CFG FunctionName PointsToState
callerCfg)

        -- Re-calculate the state at the precise point *before* the call statement.
        stmtsBeforeCall :: [Node (Lexeme FunctionName)]
stmtsBeforeCall = (Node (Lexeme FunctionName) -> Bool)
-> [Node (Lexeme FunctionName)] -> [Node (Lexeme FunctionName)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Node (Lexeme FunctionName) -> Node (Lexeme FunctionName) -> Bool
forall a. Eq a => a -> a -> Bool
/= Node (Lexeme FunctionName)
callStmt) (CFGNode FunctionName PointsToState -> [Node (Lexeme FunctionName)]
forall l a. CFGNode l a -> [Node (Lexeme l)]
cfgStmts CFGNode FunctionName PointsToState
callNode)
        callerState :: PointsToState
callerState = (PointsToState, Set (FunctionName, Context)) -> PointsToState
forall a b. (a, b) -> a
fst ((PointsToState, Set (FunctionName, Context)) -> PointsToState)
-> (PointsToState, Set (FunctionName, Context)) -> PointsToState
forall a b. (a -> b) -> a -> b
$ ((PointsToState, Set (FunctionName, Context))
 -> Node (Lexeme FunctionName)
 -> (PointsToState, Set (FunctionName, Context)))
-> (PointsToState, Set (FunctionName, Context))
-> [Node (Lexeme FunctionName)]
-> (PointsToState, Set (FunctionName, Context))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            (\(PointsToState
accState, Set (FunctionName, Context)
accWork) Node (Lexeme FunctionName)
stmt ->
                let (PointsToState
newState, Set (FunctionName, Context)
newWork) = PointsToContext FunctionName
-> FunctionName
-> PointsToState
-> Node (Lexeme FunctionName)
-> (PointsToState, Set (FunctionName, Context))
transferPointsToState PointsToContext FunctionName
ctx FunctionName
callerName PointsToState
accState Node (Lexeme FunctionName)
stmt
                in (PointsToState
newState, Set (FunctionName, Context)
-> Set (FunctionName, Context) -> Set (FunctionName, Context)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (FunctionName, Context)
accWork Set (FunctionName, Context)
newWork))
            (CFGNode FunctionName PointsToState -> PointsToState
forall l a. CFGNode l a -> a
cfgInFacts CFGNode FunctionName PointsToState
callNode, Set (FunctionName, Context)
forall a. Set a
Set.empty)
            [Node (Lexeme FunctionName)]
stmtsBeforeCall

        -- Extract the arguments from the call statement.
        (Node (Lexeme FunctionName)
_, [Node (Lexeme FunctionName)]
args) = case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
callStmt of
            C.ExprStmt (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a)) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.ExprStmt (Fix (C.AssignExpr Node (Lexeme FunctionName)
_ AssignOp
_ (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a)))) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.ExprStmt (Fix (C.AssignExpr Node (Lexeme FunctionName)
_ AssignOp
_ (Fix (C.CastExpr Node (Lexeme FunctionName)
_ (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a)))))) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.ExprStmt (Fix (C.AssignExpr Node (Lexeme FunctionName)
_ AssignOp
_ (Fix (C.BinaryExpr (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a)) BinaryOp
_ Node (Lexeme FunctionName)
_)))) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.AssignExpr Node (Lexeme FunctionName)
_ AssignOp
_ (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a)) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.AssignExpr Node (Lexeme FunctionName)
_ AssignOp
_ (Fix (C.CastExpr Node (Lexeme FunctionName)
_ (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a)))) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.AssignExpr Node (Lexeme FunctionName)
_ AssignOp
_ (Fix (C.BinaryExpr (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a)) BinaryOp
_ Node (Lexeme FunctionName)
_)) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a                          -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.VarDeclStmt Node (Lexeme FunctionName)
_ (Just (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a))) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            C.VarDeclStmt Node (Lexeme FunctionName)
_ (Just (Fix (C.CastExpr Node (Lexeme FunctionName)
_ (Fix (C.FunctionCall Node (Lexeme FunctionName)
e [Node (Lexeme FunctionName)]
a))))) -> (Node (Lexeme FunctionName)
e, [Node (Lexeme FunctionName)]
a)
            NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> FilePath
-> (Node (Lexeme FunctionName), [Node (Lexeme FunctionName)])
forall a. HasCallStack => FilePath -> a
error (FilePath
 -> (Node (Lexeme FunctionName), [Node (Lexeme FunctionName)]))
-> FilePath
-> (Node (Lexeme FunctionName), [Node (Lexeme FunctionName)])
forall a b. (a -> b) -> a -> b
$ FilePath
"Unhandled call statement structure: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
callStmt

        _calleeDef :: Node (Lexeme FunctionName)
_calleeDef = Node (Lexeme FunctionName)
-> Maybe (Node (Lexeme FunctionName)) -> Node (Lexeme FunctionName)
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Node (Lexeme FunctionName)
forall a. HasCallStack => FilePath -> a
error (FilePath -> Node (Lexeme FunctionName))
-> FilePath -> Node (Lexeme FunctionName)
forall a b. (a -> b) -> a -> b
$ FilePath
"callee def not found: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FunctionName -> FilePath
T.unpack FunctionName
calleeName) (FunctionName
-> MacroDefinitionMap -> Maybe (Node (Lexeme FunctionName))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionName
calleeName (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx))
        paramNames :: [FunctionName]
paramNames = MacroDefinitionMap -> FunctionName -> [FunctionName]
getParamNamesFromDef (PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFuncDefs PointsToContext FunctionName
ctx) FunctionName
calleeName

        -- 1. Create initial parameter bindings: map each parameter of the callee
        --    to the points-to set of the corresponding argument from the caller.
        paramFactsList :: [((AbstractLocation, Set AbstractLocation),
  Set (FunctionName, Context))]
paramFactsList = (FunctionName
 -> Node (Lexeme FunctionName)
 -> ((AbstractLocation, Set AbstractLocation),
     Set (FunctionName, Context)))
-> [FunctionName]
-> [Node (Lexeme FunctionName)]
-> [((AbstractLocation, Set AbstractLocation),
     Set (FunctionName, Context))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\FunctionName
pName Node (Lexeme FunctionName)
arg ->
            let (Set AbstractLocation
pointsTo, Set (FunctionName, Context)
work) = MacroDefinitionMap
-> PointsToContext FunctionName
-> Set FunctionName
-> FunctionName
-> PointsToMap
-> Node (Lexeme FunctionName)
-> (Set AbstractLocation, Set (FunctionName, Context))
evalPointsToSet (PointsToState -> MacroDefinitionMap
ptsMacros PointsToState
callerState) PointsToContext FunctionName
ctx (PointsToContext FunctionName -> Set FunctionName
forall l. PointsToContext l -> Set FunctionName
ptcLocalVars PointsToContext FunctionName
ctx) FunctionName
callerName (PointsToState -> PointsToMap
ptsMap PointsToState
callerState) Node (Lexeme FunctionName)
arg
            in ((FunctionName -> AbstractLocation
VarLocation FunctionName
pName, Set AbstractLocation
pointsTo), Set (FunctionName, Context)
work)
          ) [FunctionName]
paramNames [Node (Lexeme FunctionName)]
args
        paramFacts :: PointsToMap
paramFacts = [(AbstractLocation, Set AbstractLocation)] -> PointsToMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((((AbstractLocation, Set AbstractLocation),
  Set (FunctionName, Context))
 -> (AbstractLocation, Set AbstractLocation))
-> [((AbstractLocation, Set AbstractLocation),
     Set (FunctionName, Context))]
-> [(AbstractLocation, Set AbstractLocation)]
forall a b. (a -> b) -> [a] -> [b]
map ((AbstractLocation, Set AbstractLocation),
 Set (FunctionName, Context))
-> (AbstractLocation, Set AbstractLocation)
forall a b. (a, b) -> a
fst [((AbstractLocation, Set AbstractLocation),
  Set (FunctionName, Context))]
paramFactsList)
        _paramWork :: Set (FunctionName, Context)
_paramWork = [Set (FunctionName, Context)] -> Set (FunctionName, Context)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((((AbstractLocation, Set AbstractLocation),
  Set (FunctionName, Context))
 -> Set (FunctionName, Context))
-> [((AbstractLocation, Set AbstractLocation),
     Set (FunctionName, Context))]
-> [Set (FunctionName, Context)]
forall a b. (a -> b) -> [a] -> [b]
map ((AbstractLocation, Set AbstractLocation),
 Set (FunctionName, Context))
-> Set (FunctionName, Context)
forall a b. (a, b) -> b
snd [((AbstractLocation, Set AbstractLocation),
  Set (FunctionName, Context))]
paramFactsList)

        -- 2. Create a worklist of all locations passed via parameters.
        worklist :: Set AbstractLocation
worklist = [Set AbstractLocation] -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (PointsToMap -> [Set AbstractLocation]
forall k a. Map k a -> [a]
Map.elems PointsToMap
paramFacts)

        -- 3. Transitively copy all reachable facts from the caller's state.
        --    This is crucial for ensuring the callee has all the necessary
        --    information about the memory state it might interact with.
        go :: (PointsToMap, Set AbstractLocation)
-> Set AbstractLocation -> PointsToMap
go (PointsToMap
acc, Set AbstractLocation
visited) Set AbstractLocation
work =
            case Set AbstractLocation
-> Maybe (AbstractLocation, Set AbstractLocation)
forall a. Set a -> Maybe (a, Set a)
Set.minView Set AbstractLocation
work of
                Maybe (AbstractLocation, Set AbstractLocation)
Nothing -> PointsToMap
acc
                Just (AbstractLocation
loc, Set AbstractLocation
restOfWork) ->
                    if AbstractLocation -> Set AbstractLocation -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member AbstractLocation
loc Set AbstractLocation
visited
                    then (PointsToMap, Set AbstractLocation)
-> Set AbstractLocation -> PointsToMap
go (PointsToMap
acc, Set AbstractLocation
visited) Set AbstractLocation
restOfWork
                    else
                        let newVisited :: Set AbstractLocation
newVisited = AbstractLocation -> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => a -> Set a -> Set a
Set.insert AbstractLocation
loc Set AbstractLocation
visited
                            pointsToSet :: Set AbstractLocation
pointsToSet = Set AbstractLocation
-> Maybe (Set AbstractLocation) -> Set AbstractLocation
forall a. a -> Maybe a -> a
fromMaybe Set AbstractLocation
forall a. Set a
Set.empty (AbstractLocation -> PointsToMap -> Maybe (Set AbstractLocation)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AbstractLocation
loc (PointsToState -> PointsToMap
ptsMap PointsToState
callerState))
                            -- Find all field locations based on the current location.
                            fieldFacts :: PointsToMap
fieldFacts = (AbstractLocation -> Set AbstractLocation -> Bool)
-> PointsToMap -> PointsToMap
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\AbstractLocation
k Set AbstractLocation
_ -> case AbstractLocation
k of
                                FieldLocation AbstractLocation
base FunctionName
_ -> AbstractLocation
base AbstractLocation -> AbstractLocation -> Bool
forall a. Eq a => a -> a -> Bool
== AbstractLocation
loc
                                AbstractLocation
_                    -> Bool
False) (PointsToState -> PointsToMap
ptsMap PointsToState
callerState)
                            -- Add the current location's points-to set AND its field facts to the accumulator.
                            newAcc :: PointsToMap
newAcc = (Set AbstractLocation
 -> Set AbstractLocation -> Set AbstractLocation)
-> [PointsToMap] -> PointsToMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union [PointsToMap
acc, AbstractLocation -> Set AbstractLocation -> PointsToMap
forall k a. k -> a -> Map k a
Map.singleton AbstractLocation
loc Set AbstractLocation
pointsToSet, PointsToMap
fieldFacts]
                            -- Add the newly discovered locations from both the points-to set and the field values to the worklist.
                            newWorkItems :: Set AbstractLocation
newWorkItems = [Set AbstractLocation] -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set AbstractLocation
pointsToSet, [Set AbstractLocation] -> Set AbstractLocation
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (PointsToMap -> [Set AbstractLocation]
forall k a. Map k a -> [a]
Map.elems PointsToMap
fieldFacts)]
                            newWork :: Set AbstractLocation
newWork = Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set AbstractLocation
restOfWork (Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set AbstractLocation
newWorkItems Set AbstractLocation
newVisited)
                        in (PointsToMap, Set AbstractLocation)
-> Set AbstractLocation -> PointsToMap
go (PointsToMap
newAcc, Set AbstractLocation
newVisited) Set AbstractLocation
newWork

        reachableFacts :: PointsToMap
reachableFacts = (PointsToMap, Set AbstractLocation)
-> Set AbstractLocation -> PointsToMap
go (PointsToMap
forall k a. Map k a
Map.empty, Set AbstractLocation
forall a. Set a
Set.empty) Set AbstractLocation
worklist

        -- 4. Combine parameter bindings with the copied reachable facts.
        initialMap :: PointsToMap
initialMap = (Set AbstractLocation
 -> Set AbstractLocation -> Set AbstractLocation)
-> PointsToMap -> PointsToMap -> PointsToMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set AbstractLocation
-> Set AbstractLocation -> Set AbstractLocation
forall a. Ord a => Set a -> Set a -> Set a
Set.union PointsToMap
paramFacts PointsToMap
reachableFacts
        initialState :: PointsToState
initialState = PointsToMap -> MacroDefinitionMap -> PointsToState
PointsToState PointsToMap
initialMap MacroDefinitionMap
forall k a. Map k a
Map.empty
    in
        FilePath -> PointsToState -> PointsToState
forall a. FilePath -> a -> a
dtrace ([FilePath] -> FilePath
unlines [ FilePath
"computeFactsFromCallSite for " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
calleeName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" called by " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
callerName
                        , FilePath
"  CALL_STMT: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme FunctionName) -> FilePath
forall a. Show a => a -> FilePath
groom Node (Lexeme FunctionName)
callStmt
                        , FilePath
"  CALLER_STATE: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToState -> FilePath
forall a. Show a => a -> FilePath
groom PointsToState
callerState
                        , FilePath
"  INITIAL_FACTS: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToState -> FilePath
forall a. Show a => a -> FilePath
groom PointsToState
initialState
                        ]) PointsToState
initialState

-- | Creates the initial data flow facts for a function analysis.
-- This function is context-aware.
createInitialFacts :: PointsToContext Text -> C.Node (C.Lexeme Text) -> PointsToState
createInitialFacts :: PointsToContext FunctionName
-> Node (Lexeme FunctionName) -> PointsToState
createInitialFacts PointsToContext FunctionName
ctx Node (Lexeme FunctionName)
funcDef =
    let
        funcName :: FunctionName
funcName = Node (Lexeme FunctionName) -> FunctionName
getFuncNameFromDef Node (Lexeme FunctionName)
funcDef
        calleeContext :: Context
calleeContext = PointsToContext FunctionName -> Context
forall l. PointsToContext l -> Context
ptcCurrentContext PointsToContext FunctionName
ctx
        initialMacros :: MacroDefinitionMap
initialMacros = PointsToContext FunctionName -> MacroDefinitionMap
forall l. PointsToContext l -> MacroDefinitionMap
ptcFileMacros PointsToContext FunctionName
ctx
    in
    if Context -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Context
calleeContext then
        -- If there's no context, this is an entry point (like `main`) or a
        -- function that hasn't been called yet. We create a generic initial
        -- state where each pointer parameter `p` points to `*p`.
        let
            toPointerParamFact :: C.Node (C.Lexeme Text) -> Maybe (AbstractLocation, Set AbstractLocation)
            toPointerParamFact :: Node (Lexeme FunctionName)
-> Maybe (AbstractLocation, Set AbstractLocation)
toPointerParamFact (Fix (C.VarDecl (Fix (C.TyPointer Node (Lexeme FunctionName)
_)) (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) =
                (AbstractLocation, Set AbstractLocation)
-> Maybe (AbstractLocation, Set AbstractLocation)
forall a. a -> Maybe a
Just (FunctionName -> AbstractLocation
VarLocation FunctionName
name, AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (AbstractLocation -> AbstractLocation
DerefLocation (FunctionName -> AbstractLocation
VarLocation FunctionName
name)))
            toPointerParamFact (Fix (C.VarDecl (Fix (C.TyStruct Lexeme FunctionName
_)) (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) =
                (AbstractLocation, Set AbstractLocation)
-> Maybe (AbstractLocation, Set AbstractLocation)
forall a. a -> Maybe a
Just (FunctionName -> AbstractLocation
VarLocation FunctionName
name, AbstractLocation -> Set AbstractLocation
forall a. a -> Set a
Set.singleton (AbstractLocation -> AbstractLocation
DerefLocation (FunctionName -> AbstractLocation
VarLocation FunctionName
name)))
            toPointerParamFact Node (Lexeme FunctionName)
_ = Maybe (AbstractLocation, Set AbstractLocation)
forall a. Maybe a
Nothing
            paramFacts :: [(AbstractLocation, Set AbstractLocation)]
paramFacts = (Node (Lexeme FunctionName)
 -> Maybe (AbstractLocation, Set AbstractLocation))
-> [Node (Lexeme FunctionName)]
-> [(AbstractLocation, Set AbstractLocation)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme FunctionName)
-> Maybe (AbstractLocation, Set AbstractLocation)
toPointerParamFact (Node (Lexeme FunctionName) -> [Node (Lexeme FunctionName)]
getParamsFromDef Node (Lexeme FunctionName)
funcDef)
        in PointsToMap -> MacroDefinitionMap -> PointsToState
PointsToState ([(AbstractLocation, Set AbstractLocation)] -> PointsToMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AbstractLocation, Set AbstractLocation)]
paramFacts) MacroDefinitionMap
initialMacros
    else
        -- If there is a context, we find all call sites that could lead to this
        -- function-context pair and join the facts computed from each call site.
        let
            callers :: [(FunctionName, Context, Node (Lexeme FunctionName))]
callers = PointsToContext FunctionName
-> FunctionName
-> Context
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
findCallersOf PointsToContext FunctionName
ctx FunctionName
funcName Context
calleeContext
            factList :: [PointsToState]
factList = ((FunctionName, Context, Node (Lexeme FunctionName))
 -> PointsToState)
-> [(FunctionName, Context, Node (Lexeme FunctionName))]
-> [PointsToState]
forall a b. (a -> b) -> [a] -> [b]
map (PointsToContext FunctionName
-> FunctionName
-> (FunctionName, Context, Node (Lexeme FunctionName))
-> PointsToState
computeFactsFromCallSite PointsToContext FunctionName
ctx FunctionName
funcName) [(FunctionName, Context, Node (Lexeme FunctionName))]
callers
            initialFacts :: PointsToState
initialFacts = (PointsToState -> PointsToState -> PointsToState)
-> PointsToState -> [PointsToState] -> PointsToState
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (PointsToContext FunctionName
-> PointsToState -> PointsToState -> PointsToState
forall (c :: * -> *) l a. DataFlow c l a => c l -> a -> a -> a
join PointsToContext FunctionName
ctx) (PointsToContext FunctionName -> PointsToState
forall (c :: * -> *) l a. DataFlow c l a => c l -> a
emptyFacts PointsToContext FunctionName
ctx) [PointsToState]
factList
        in
            FilePath -> PointsToState -> PointsToState
forall a. FilePath -> a -> a
dtrace ([FilePath] -> FilePath
unlines [ FilePath
"createInitialFacts for " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FunctionName -> FilePath
T.unpack FunctionName
funcName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" in context " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Context -> FilePath
forall a. Show a => a -> FilePath
groom Context
calleeContext
                            , FilePath
"  CALLERS: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(FunctionName, Context, Node (Lexeme FunctionName))] -> FilePath
forall a. Show a => a -> FilePath
groom [(FunctionName, Context, Node (Lexeme FunctionName))]
callers
                            , FilePath
"  FACTS: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PointsToState -> FilePath
forall a. Show a => a -> FilePath
groom PointsToState
initialFacts
                            ]) PointsToState
initialFacts

-- | Traverses a function's body to find all locally declared variables.
findDeclaredVars :: C.Node (C.Lexeme Text) -> Set Text
findDeclaredVars :: Node (Lexeme FunctionName) -> Set FunctionName
findDeclaredVars (Fix (C.FunctionDefn Scope
_ Node (Lexeme FunctionName)
_ Node (Lexeme FunctionName)
body)) = State (Set FunctionName) () -> Set FunctionName -> Set FunctionName
forall s a. State s a -> s -> s
execState (AstActions (StateT (Set FunctionName) Identity) FunctionName
-> [(FilePath, [Node (Lexeme FunctionName)])]
-> State (Set FunctionName) ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT (Set FunctionName) Identity) FunctionName
collector [(FilePath
fakeTestSource, [Node (Lexeme FunctionName)
body])]) Set FunctionName
forall a. Set a
Set.empty
  where
    collector :: AstActions (StateT (Set FunctionName) Identity) FunctionName
collector = AstActions (StateT (Set FunctionName) Identity) FunctionName
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
        { doNode :: FilePath
-> Node (Lexeme FunctionName)
-> State (Set FunctionName) ()
-> State (Set FunctionName) ()
doNode = \FilePath
_ Node (Lexeme FunctionName)
node State (Set FunctionName) ()
act -> do
            case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
node of
                C.VarDecl Node (Lexeme FunctionName)
_ (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_ -> (Set FunctionName -> Set FunctionName)
-> State (Set FunctionName) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName -> Set FunctionName -> Set FunctionName
forall a. Ord a => a -> Set a -> Set a
Set.insert FunctionName
name)
                NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_                            -> () -> State (Set FunctionName) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            State (Set FunctionName) ()
act
        }
findDeclaredVars Node (Lexeme FunctionName)
_ = Set FunctionName
forall a. Set a
Set.empty

-- Helper functions for union type analysis
getBaseVarName :: C.Node (C.Lexeme Text) -> Text
getBaseVarName :: Node (Lexeme FunctionName) -> FunctionName
getBaseVarName (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ FunctionName
name))) = FunctionName
name
getBaseVarName (Fix (C.MemberAccess Node (Lexeme FunctionName)
base Lexeme FunctionName
_))    = Node (Lexeme FunctionName) -> FunctionName
getBaseVarName Node (Lexeme FunctionName)
base
getBaseVarName (Fix (C.PointerAccess Node (Lexeme FunctionName)
base Lexeme FunctionName
_))   = Node (Lexeme FunctionName) -> FunctionName
getBaseVarName Node (Lexeme FunctionName)
base
getBaseVarName Node (Lexeme FunctionName)
_                                = FunctionName
""

getMemberNames :: [C.Node (C.Lexeme Text)] -> [Text]
getMemberNames :: [Node (Lexeme FunctionName)] -> [FunctionName]
getMemberNames = (Node (Lexeme FunctionName) -> Maybe FunctionName)
-> [Node (Lexeme FunctionName)] -> [FunctionName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme FunctionName) -> Maybe FunctionName
forall a. Fix (NodeF (Lexeme a)) -> Maybe a
getMemberName
  where
    getMemberName :: Fix (NodeF (Lexeme a)) -> Maybe a
getMemberName (Fix (C.MemberDecl (Fix (C.VarDecl Fix (NodeF (Lexeme a))
_ (C.L AlexPosn
_ LexemeClass
_ a
name) [Fix (NodeF (Lexeme a))]
_)) Maybe (Lexeme a)
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
name
    getMemberName Fix (NodeF (Lexeme a))
_                                                          = Maybe a
forall a. Maybe a
Nothing

findVarTypes :: C.Node (C.Lexeme Text) -> Map Text (C.Node (C.Lexeme Text))
findVarTypes :: Node (Lexeme FunctionName) -> MacroDefinitionMap
findVarTypes (Fix (C.FunctionDefn Scope
_ Node (Lexeme FunctionName)
_ Node (Lexeme FunctionName)
body)) = State MacroDefinitionMap ()
-> MacroDefinitionMap -> MacroDefinitionMap
forall s a. State s a -> s -> s
execState (AstActions (StateT MacroDefinitionMap Identity) FunctionName
-> [(FilePath, [Node (Lexeme FunctionName)])]
-> State MacroDefinitionMap ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT MacroDefinitionMap Identity) FunctionName
collector [(FilePath
fakeTestSource, [Node (Lexeme FunctionName)
body])]) MacroDefinitionMap
forall k a. Map k a
Map.empty
  where
    collector :: AstActions (StateT MacroDefinitionMap Identity) FunctionName
collector = AstActions (StateT MacroDefinitionMap Identity) FunctionName
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
        { doNode :: FilePath
-> Node (Lexeme FunctionName)
-> State MacroDefinitionMap ()
-> State MacroDefinitionMap ()
doNode = \FilePath
_ Node (Lexeme FunctionName)
node State MacroDefinitionMap ()
act -> do
            case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
node of
                C.VarDecl Node (Lexeme FunctionName)
ty (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_ -> (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
ty)
                NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_                             -> () -> State MacroDefinitionMap ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            State MacroDefinitionMap ()
act
        }
findVarTypes Node (Lexeme FunctionName)
_ = MacroDefinitionMap
forall k a. Map k a
Map.empty

findStructOrUnionDefs :: [C.Node (C.Lexeme Text)] -> Map Text (C.Node (C.Lexeme Text))
findStructOrUnionDefs :: [Node (Lexeme FunctionName)] -> MacroDefinitionMap
findStructOrUnionDefs [Node (Lexeme FunctionName)]
nodes = State MacroDefinitionMap ()
-> MacroDefinitionMap -> MacroDefinitionMap
forall s a. State s a -> s -> s
execState (AstActions (StateT MacroDefinitionMap Identity) FunctionName
-> [(FilePath, [Node (Lexeme FunctionName)])]
-> State MacroDefinitionMap ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT MacroDefinitionMap Identity) FunctionName
collector [(FilePath
fakeTestSource, [Node (Lexeme FunctionName)]
nodes)]) MacroDefinitionMap
forall k a. Map k a
Map.empty
  where
    collector :: AstActions (StateT MacroDefinitionMap Identity) FunctionName
collector = AstActions (StateT MacroDefinitionMap Identity) FunctionName
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
        { doNode :: FilePath
-> Node (Lexeme FunctionName)
-> State MacroDefinitionMap ()
-> State MacroDefinitionMap ()
doNode = \FilePath
_ Node (Lexeme FunctionName)
node State MacroDefinitionMap ()
act -> do
            case Node (Lexeme FunctionName)
-> NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme FunctionName)
node of
                C.Typedef defNode :: Node (Lexeme FunctionName)
defNode@(Fix (C.Struct (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) (C.L AlexPosn
_ LexemeClass
_ FunctionName
tyName) -> do
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
defNode)
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
tyName Node (Lexeme FunctionName)
defNode)
                C.Typedef defNode :: Node (Lexeme FunctionName)
defNode@(Fix (C.Union (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) (C.L AlexPosn
_ LexemeClass
_ FunctionName
tyName) -> do
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
defNode)
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
tyName Node (Lexeme FunctionName)
defNode)
                C.AggregateDecl defNode :: Node (Lexeme FunctionName)
defNode@(Fix (C.Struct (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) ->
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
defNode)
                C.AggregateDecl defNode :: Node (Lexeme FunctionName)
defNode@(Fix (C.Union (C.L AlexPosn
_ LexemeClass
_ FunctionName
name) [Node (Lexeme FunctionName)]
_)) ->
                    (MacroDefinitionMap -> MacroDefinitionMap)
-> State MacroDefinitionMap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FunctionName
-> Node (Lexeme FunctionName)
-> MacroDefinitionMap
-> MacroDefinitionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FunctionName
name Node (Lexeme FunctionName)
defNode)
                NodeF (Lexeme FunctionName) (Node (Lexeme FunctionName))
_ -> () -> State MacroDefinitionMap ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            State MacroDefinitionMap ()
act
        }