{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}

module Tokstyle.Analysis.PointsTo.Fixpoint
    ( CallGraph
    , CFG
    , runGlobalFixpoint
    , findEntryPointsAndFuncMap
    , findVarTypes
    ) where

import           Control.Monad                    (foldM, forM, forM_, when)
import           Control.Monad.State.Strict       (State, StateT, execState,
                                                   execStateT, get, gets, lift,
                                                   modify, runState)
import           Data.Fix                         (Fix (..))
import           Data.IntMap.Strict               (IntMap)
import qualified Data.IntMap.Strict               as IntMap
import           Data.IntSet                      (IntSet)
import qualified Data.IntSet                      as IntSet
import           Data.List                        (find, foldl')
import           Data.Map.Strict                  (Map)
import qualified Data.Map.Strict                  as Map
import           Data.Maybe                       (fromMaybe, listToMaybe,
                                                   mapMaybe)
import           Data.Set                         (Set)
import qualified Data.Set                         as Set
import qualified Data.Text                        as Text
import           Debug.Trace                      (trace, traceM)
import qualified Language.Cimple                  as C
import           Language.Cimple.TraverseAst      (AstActions (..), astActions,
                                                   traverseAst)
import           Tokstyle.Analysis.DataFlow       (CFGNode (..), DataFlow (..),
                                                   buildCFG, fixpoint, join,
                                                   transfer)
import           Tokstyle.Analysis.PointsTo       (evalExpr,
                                                   extractRelevantState)
import           Tokstyle.Analysis.PointsTo.Types
import           Tokstyle.Analysis.Scope          (ScopedId (..))
import           Tokstyle.Common.TypeSystem       (TypeDescr (..), lookupType)
import           Tokstyle.Worklist                (Worklist, fromList, pop,
                                                   push, pushList)

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

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

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

-- | The call graph of the program.
type CallGraph = Map (ScopedId, RelevantInputState) (Set (ScopedId, RelevantInputState))
type CFG id fact = Map Int (CFGNode id fact)
type CFGCache = Map (ScopedId, RelevantInputState) ([CFG ScopedId PointsToFact], Map ScopedId Int)

data FixpointState = FixpointState
    { FixpointState -> GlobalEnv
fsGlobalEnv         :: GlobalEnv
    , FixpointState -> CallGraph
fsCallGraph         :: CallGraph
    , FixpointState -> CallGraph
fsReversedCallGraph :: CallGraph
    , FixpointState
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist          :: Worklist (ScopedId, RelevantInputState, [ScopedId])
    , FixpointState -> Map ScopedId [Node (Lexeme ScopedId)]
fsFuncs             :: Map ScopedId [C.Node (C.Lexeme ScopedId)]
    , FixpointState -> PointsToFact
fsInitialFacts      :: PointsToFact
    , FixpointState -> CFGCache
fsCFGCache          :: CFGCache
    , FixpointState
-> Map ScopedId (Map ScopedId (Node (Lexeme ScopedId)))
fsVarTypes          :: Map ScopedId (Map ScopedId (C.Node (C.Lexeme ScopedId)))
    , FixpointState -> Map ScopedId [ScopedId]
fsParams            :: Map ScopedId [ScopedId]
    , FixpointState -> MemLocPool
fsMemLocPool        :: MemLocPool
    }

-- | The main driver for the global fixpoint analysis.
runGlobalFixpoint :: PointsToContext ScopedId -> [C.Node (C.Lexeme ScopedId)] -> (GlobalEnv, CallGraph, CFGCache, MemLocPool)
runGlobalFixpoint :: PointsToContext ScopedId
-> [Node (Lexeme ScopedId)]
-> (GlobalEnv, CallGraph, CFGCache, MemLocPool)
runGlobalFixpoint PointsToContext ScopedId
ctx [Node (Lexeme ScopedId)]
ast =
    let
        ([ScopedId]
initialFunctions, Map ScopedId [Node (Lexeme ScopedId)]
funcMap) = [Node (Lexeme ScopedId)]
-> ([ScopedId], Map ScopedId [Node (Lexeme ScopedId)])
findEntryPointsAndFuncMap [Node (Lexeme ScopedId)]
ast
        initialEnv :: GlobalEnv
initialEnv = Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
-> GlobalEnv
GlobalEnv Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
forall k a. Map k a
Map.empty
        tmpCtx :: PointsToContext l
tmpCtx = PointsToContext ScopedId
ctx { pcFuncs :: Map ScopedId [Node (Lexeme ScopedId)]
pcFuncs = Map ScopedId [Node (Lexeme ScopedId)]
funcMap, pcGlobalEnv :: GlobalEnv
pcGlobalEnv = GlobalEnv
initialEnv }
        initialPool :: MemLocPool
initialPool = Int
-> Map MemLoc IMemLoc
-> IntMap MemLoc
-> IntMap IntSet
-> MemLocPool
MemLocPool Int
0 Map MemLoc IMemLoc
forall k a. Map k a
Map.empty IntMap MemLoc
forall a. IntMap a
IntMap.empty IntMap IntSet
forall a. IntMap a
IntMap.empty
        (PointsToFact
initialGlobalFacts, MemLocPool
poolAfterInit) = State MemLocPool PointsToFact
-> MemLocPool -> (PointsToFact, MemLocPool)
forall s a. State s a -> s -> (a, s)
runState (PointsToContext ScopedId
-> [Node (Lexeme ScopedId)] -> State MemLocPool PointsToFact
initializeGlobalFacts PointsToContext ScopedId
forall l. PointsToContext l
tmpCtx [Node (Lexeme ScopedId)]
ast) MemLocPool
initialPool
        tracedInitialFacts :: PointsToFact
tracedInitialFacts = String -> PointsToFact -> PointsToFact
forall a. String -> a -> a
dtrace (String
"initialGlobalFacts: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PointsToFact -> String
forall a. Show a => a -> String
show PointsToFact
initialGlobalFacts) PointsToFact
initialGlobalFacts

        -- Precompute static function properties
        precomputedVarTypes :: Map ScopedId (Map ScopedId (Node (Lexeme ScopedId)))
precomputedVarTypes = ([Node (Lexeme ScopedId)] -> Map ScopedId (Node (Lexeme ScopedId)))
-> Map ScopedId [Node (Lexeme ScopedId)]
-> Map ScopedId (Map ScopedId (Node (Lexeme ScopedId)))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Node (Lexeme ScopedId) -> Map ScopedId (Node (Lexeme ScopedId))
findVarTypes (Node (Lexeme ScopedId) -> Map ScopedId (Node (Lexeme ScopedId)))
-> ([Node (Lexeme ScopedId)] -> Node (Lexeme ScopedId))
-> [Node (Lexeme ScopedId)]
-> Map ScopedId (Node (Lexeme ScopedId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node (Lexeme ScopedId)] -> Node (Lexeme ScopedId)
forall a. [a] -> a
head) Map ScopedId [Node (Lexeme ScopedId)]
funcMap
        precomputedParams :: Map ScopedId [ScopedId]
precomputedParams = ([Node (Lexeme ScopedId)] -> [ScopedId])
-> Map ScopedId [Node (Lexeme ScopedId)] -> Map ScopedId [ScopedId]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Node (Lexeme ScopedId) -> [ScopedId]
getParams (Node (Lexeme ScopedId) -> [ScopedId])
-> ([Node (Lexeme ScopedId)] -> Node (Lexeme ScopedId))
-> [Node (Lexeme ScopedId)]
-> [ScopedId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node (Lexeme ScopedId)] -> Node (Lexeme ScopedId)
forall a. [a] -> a
head) Map ScopedId [Node (Lexeme ScopedId)]
funcMap

        (Worklist (ScopedId, RelevantInputState, [a])
initialWorklist, MemLocPool
poolAfterRIS) = State MemLocPool (Worklist (ScopedId, RelevantInputState, [a]))
-> MemLocPool
-> (Worklist (ScopedId, RelevantInputState, [a]), MemLocPool)
forall s a. State s a -> s -> (a, s)
runState (do
            [(ScopedId, RelevantInputState, [a])]
list <- [ScopedId]
-> (ScopedId
    -> StateT MemLocPool Identity (ScopedId, RelevantInputState, [a]))
-> StateT MemLocPool Identity [(ScopedId, RelevantInputState, [a])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ScopedId]
initialFunctions ((ScopedId
  -> StateT MemLocPool Identity (ScopedId, RelevantInputState, [a]))
 -> StateT
      MemLocPool Identity [(ScopedId, RelevantInputState, [a])])
-> (ScopedId
    -> StateT MemLocPool Identity (ScopedId, RelevantInputState, [a]))
-> StateT MemLocPool Identity [(ScopedId, RelevantInputState, [a])]
forall a b. (a -> b) -> a -> b
$ \ScopedId
funcId -> do
                let params :: [ScopedId]
params = [ScopedId] -> Maybe [ScopedId] -> [ScopedId]
forall a. a -> Maybe a -> a
fromMaybe [] (ScopedId -> Map ScopedId [ScopedId] -> Maybe [ScopedId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
funcId Map ScopedId [ScopedId]
precomputedParams)
                [(ScopedId, IntSet)]
kvs <- [ScopedId]
-> (ScopedId -> StateT MemLocPool Identity (ScopedId, IntSet))
-> StateT MemLocPool Identity [(ScopedId, IntSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ScopedId]
params ((ScopedId -> StateT MemLocPool Identity (ScopedId, IntSet))
 -> StateT MemLocPool Identity [(ScopedId, IntSet)])
-> (ScopedId -> StateT MemLocPool Identity (ScopedId, IntSet))
-> StateT MemLocPool Identity [(ScopedId, IntSet)]
forall a b. (a -> b) -> a -> b
$ \ScopedId
p -> do
                    IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern (Text -> Text -> MemLoc
ExternalParamLoc (ScopedId -> Text
sidName ScopedId
funcId) (ScopedId -> Text
sidName ScopedId
p))
                    (ScopedId, IntSet) -> StateT MemLocPool Identity (ScopedId, IntSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopedId
p, Int -> IntSet
IntSet.singleton (IMemLoc -> Int
unIMemLoc IMemLoc
iloc))
                let initialVarMap :: Map ScopedId IntSet
initialVarMap = [(ScopedId, IntSet)] -> Map ScopedId IntSet
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ScopedId, IntSet)]
kvs
                RelevantInputState
ris <- PointsToFact
-> Map ScopedId IntSet -> PointsToAnalysis RelevantInputState
extractRelevantState PointsToFact
tracedInitialFacts Map ScopedId IntSet
initialVarMap
                (ScopedId, RelevantInputState, [a])
-> StateT MemLocPool Identity (ScopedId, RelevantInputState, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopedId
funcId, RelevantInputState
ris, [])
            Worklist (ScopedId, RelevantInputState, [a])
-> State MemLocPool (Worklist (ScopedId, RelevantInputState, [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Worklist (ScopedId, RelevantInputState, [a])
 -> State MemLocPool (Worklist (ScopedId, RelevantInputState, [a])))
-> Worklist (ScopedId, RelevantInputState, [a])
-> State MemLocPool (Worklist (ScopedId, RelevantInputState, [a]))
forall a b. (a -> b) -> a -> b
$ [(ScopedId, RelevantInputState, [a])]
-> Worklist (ScopedId, RelevantInputState, [a])
forall a. [a] -> Worklist a
fromList [(ScopedId, RelevantInputState, [a])]
list
            ) MemLocPool
poolAfterInit

        initialState :: FixpointState
initialState = FixpointState :: GlobalEnv
-> CallGraph
-> CallGraph
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
-> Map ScopedId [Node (Lexeme ScopedId)]
-> PointsToFact
-> CFGCache
-> Map ScopedId (Map ScopedId (Node (Lexeme ScopedId)))
-> Map ScopedId [ScopedId]
-> MemLocPool
-> FixpointState
FixpointState
            { fsGlobalEnv :: GlobalEnv
fsGlobalEnv = GlobalEnv
initialEnv
            , fsCallGraph :: CallGraph
fsCallGraph = CallGraph
forall k a. Map k a
Map.empty
            , fsReversedCallGraph :: CallGraph
fsReversedCallGraph = CallGraph
forall k a. Map k a
Map.empty
            , fsWorklist :: Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist = Worklist (ScopedId, RelevantInputState, [ScopedId])
forall a. Worklist (ScopedId, RelevantInputState, [a])
initialWorklist
            , fsFuncs :: Map ScopedId [Node (Lexeme ScopedId)]
fsFuncs = Map ScopedId [Node (Lexeme ScopedId)]
funcMap
            , fsInitialFacts :: PointsToFact
fsInitialFacts = PointsToFact
tracedInitialFacts
            , fsCFGCache :: CFGCache
fsCFGCache = CFGCache
forall k a. Map k a
Map.empty
            , fsVarTypes :: Map ScopedId (Map ScopedId (Node (Lexeme ScopedId)))
fsVarTypes = Map ScopedId (Map ScopedId (Node (Lexeme ScopedId)))
precomputedVarTypes
            , fsParams :: Map ScopedId [ScopedId]
fsParams = Map ScopedId [ScopedId]
precomputedParams
            , fsMemLocPool :: MemLocPool
fsMemLocPool = MemLocPool
poolAfterRIS
            }

        finalState :: FixpointState
finalState = State FixpointState () -> FixpointState -> FixpointState
forall s a. State s a -> s -> s
execState (PointsToContext ScopedId -> State FixpointState ()
iterateFixpoint PointsToContext ScopedId
ctx) FixpointState
initialState
    in
        (FixpointState -> GlobalEnv
fsGlobalEnv FixpointState
finalState, FixpointState -> CallGraph
fsCallGraph FixpointState
finalState, FixpointState -> CFGCache
fsCFGCache FixpointState
finalState, FixpointState -> MemLocPool
fsMemLocPool FixpointState
finalState)

liftPointsToAnalysis :: PointsToAnalysis a -> State FixpointState a
liftPointsToAnalysis :: PointsToAnalysis a -> State FixpointState a
liftPointsToAnalysis PointsToAnalysis a
ma = do
    MemLocPool
pool <- (FixpointState -> MemLocPool)
-> StateT FixpointState Identity MemLocPool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FixpointState -> MemLocPool
fsMemLocPool
    let (a
result, MemLocPool
newPool) = PointsToAnalysis a -> MemLocPool -> (a, MemLocPool)
forall s a. State s a -> s -> (a, s)
runState PointsToAnalysis a
ma MemLocPool
pool
    (FixpointState -> FixpointState) -> State FixpointState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FixpointState -> FixpointState) -> State FixpointState ())
-> (FixpointState -> FixpointState) -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ \FixpointState
s -> FixpointState
s { fsMemLocPool :: MemLocPool
fsMemLocPool = MemLocPool
newPool }
    a -> State FixpointState a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

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

initializeGlobalFacts :: PointsToContext ScopedId -> [C.Node (C.Lexeme ScopedId)] -> PointsToAnalysis PointsToFact
initializeGlobalFacts :: PointsToContext ScopedId
-> [Node (Lexeme ScopedId)] -> State MemLocPool PointsToFact
initializeGlobalFacts PointsToContext ScopedId
ctx [Node (Lexeme ScopedId)]
ast =
    let
        initialFacts :: PointsToFact
initialFacts = Map ScopedId IntSet -> IntMap IntSet -> IntSet -> PointsToFact
PointsToFact Map ScopedId IntSet
forall k a. Map k a
Map.empty IntMap IntSet
forall a. IntMap a
IntMap.empty IntSet
IntSet.empty

        finder :: C.Node (C.Lexeme ScopedId) -> StateT PointsToFact PointsToAnalysis ()
        finder :: Node (Lexeme ScopedId) -> StateT PointsToFact PointsToAnalysis ()
finder (Fix (C.ConstDefn Scope
_ Node (Lexeme ScopedId)
ty (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid) Node (Lexeme ScopedId)
initializer)) =
            case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
initializer of
                C.InitialiserList [Node (Lexeme ScopedId)]
initializers -> do
                    PointsToFact
facts <- StateT PointsToFact PointsToAnalysis PointsToFact
forall s (m :: * -> *). MonadState s m => m s
get
                    let mTypeName :: Maybe Text
mTypeName = Node (Lexeme ScopedId) -> Maybe Text
getTypeName Node (Lexeme ScopedId)
ty
                    case Maybe Text
mTypeName of
                        Just Text
typeName ->
                            case Text -> TypeSystem -> Maybe TypeDescr
lookupType Text
typeName (PointsToContext ScopedId -> TypeSystem
forall l. PointsToContext l -> TypeSystem
pcTypeSystem PointsToContext ScopedId
ctx) of
                                Just (StructDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)]
fields) -> do
                                    let fieldNames :: [Text]
fieldNames = ((Lexeme Text, TypeInfo) -> Text)
-> [(Lexeme Text, TypeInfo)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Lexeme Text -> Text
forall text. Lexeme text -> text
C.lexemeText (Lexeme Text -> Text)
-> ((Lexeme Text, TypeInfo) -> Lexeme Text)
-> (Lexeme Text, TypeInfo)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> Lexeme Text
forall a b. (a, b) -> a
fst) [(Lexeme Text, TypeInfo)]
fields
                                    [IntSet]
evaledInits <- StateT MemLocPool Identity [IntSet]
-> StateT PointsToFact PointsToAnalysis [IntSet]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT MemLocPool Identity [IntSet]
 -> StateT PointsToFact PointsToAnalysis [IntSet])
-> StateT MemLocPool Identity [IntSet]
-> StateT PointsToFact PointsToAnalysis [IntSet]
forall a b. (a -> b) -> a -> b
$ (Node (Lexeme ScopedId) -> StateT MemLocPool Identity IntSet)
-> [Node (Lexeme ScopedId)] -> StateT MemLocPool Identity [IntSet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PointsToFact
-> PointsToContext ScopedId
-> Int
-> Node (Lexeme ScopedId)
-> StateT MemLocPool Identity IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Int
0) [Node (Lexeme ScopedId)]
initializers
                                    IMemLoc
globalLoc <- PointsToAnalysis IMemLoc
-> StateT PointsToFact PointsToAnalysis IMemLoc
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PointsToAnalysis IMemLoc
 -> StateT PointsToFact PointsToAnalysis IMemLoc)
-> PointsToAnalysis IMemLoc
-> StateT PointsToFact PointsToAnalysis IMemLoc
forall a b. (a -> b) -> a -> b
$ MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
GlobalVarLoc ScopedId
sid)
                                    [IMemLoc]
fieldLocs <- StateT MemLocPool Identity [IMemLoc]
-> StateT PointsToFact PointsToAnalysis [IMemLoc]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT MemLocPool Identity [IMemLoc]
 -> StateT PointsToFact PointsToAnalysis [IMemLoc])
-> StateT MemLocPool Identity [IMemLoc]
-> StateT PointsToFact PointsToAnalysis [IMemLoc]
forall a b. (a -> b) -> a -> b
$ (Text -> PointsToAnalysis IMemLoc)
-> [Text] -> StateT MemLocPool Identity [IMemLoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Text
fName -> MemLoc -> PointsToAnalysis IMemLoc
intern (MemLoc -> Text -> MemLoc
FieldLoc (ScopedId -> MemLoc
GlobalVarLoc ScopedId
sid) Text
fName)) [Text]
fieldNames
                                    let newEntries :: IntMap IntSet
newEntries = [(Int, IntSet)] -> IntMap IntSet
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, IntSet)] -> IntMap IntSet)
-> [(Int, IntSet)] -> IntMap IntSet
forall a b. (a -> b) -> a -> b
$ [Int] -> [IntSet] -> [(Int, IntSet)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((IMemLoc -> Int) -> [IMemLoc] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map IMemLoc -> Int
unIMemLoc [IMemLoc]
fieldLocs) [IntSet]
evaledInits
                                    (PointsToFact -> PointsToFact)
-> StateT PointsToFact PointsToAnalysis ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((PointsToFact -> PointsToFact)
 -> StateT PointsToFact PointsToAnalysis ())
-> (PointsToFact -> PointsToFact)
-> StateT PointsToFact PointsToAnalysis ()
forall a b. (a -> b) -> a -> b
$ \PointsToFact
f -> PointsToFact
f { memMap :: IntMap IntSet
memMap = IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. IntMap a -> IntMap a -> IntMap a
IntMap.union (PointsToFact -> IntMap IntSet
memMap PointsToFact
f) IntMap IntSet
newEntries }
                                Maybe TypeDescr
_ -> () -> StateT PointsToFact PointsToAnalysis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Maybe Text
_ -> () -> StateT PointsToFact PointsToAnalysis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> do
                    PointsToFact
facts <- StateT PointsToFact PointsToAnalysis PointsToFact
forall s (m :: * -> *). MonadState s m => m s
get
                    IntSet
initLocs <- StateT MemLocPool Identity IntSet
-> StateT PointsToFact PointsToAnalysis IntSet
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT MemLocPool Identity IntSet
 -> StateT PointsToFact PointsToAnalysis IntSet)
-> StateT MemLocPool Identity IntSet
-> StateT PointsToFact PointsToAnalysis IntSet
forall a b. (a -> b) -> a -> b
$ PointsToFact
-> PointsToContext ScopedId
-> Int
-> Node (Lexeme ScopedId)
-> StateT MemLocPool Identity IntSet
evalExpr PointsToFact
facts PointsToContext ScopedId
ctx Int
0 Node (Lexeme ScopedId)
initializer
                    Bool
-> StateT PointsToFact PointsToAnalysis ()
-> StateT PointsToFact PointsToAnalysis ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (IntSet -> Bool
IntSet.null IntSet
initLocs)) (StateT PointsToFact PointsToAnalysis ()
 -> StateT PointsToFact PointsToAnalysis ())
-> StateT PointsToFact PointsToAnalysis ()
-> StateT PointsToFact PointsToAnalysis ()
forall a b. (a -> b) -> a -> b
$ do
                        IMemLoc
globalLoc <- PointsToAnalysis IMemLoc
-> StateT PointsToFact PointsToAnalysis IMemLoc
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PointsToAnalysis IMemLoc
 -> StateT PointsToFact PointsToAnalysis IMemLoc)
-> PointsToAnalysis IMemLoc
-> StateT PointsToFact PointsToAnalysis IMemLoc
forall a b. (a -> b) -> a -> b
$ MemLoc -> PointsToAnalysis IMemLoc
intern (ScopedId -> MemLoc
GlobalVarLoc ScopedId
sid)
                        (PointsToFact -> PointsToFact)
-> StateT PointsToFact PointsToAnalysis ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((PointsToFact -> PointsToFact)
 -> StateT PointsToFact PointsToAnalysis ())
-> (PointsToFact -> PointsToFact)
-> StateT PointsToFact PointsToAnalysis ()
forall a b. (a -> b) -> a -> b
$ \PointsToFact
f -> PointsToFact
f { memMap :: IntMap IntSet
memMap = Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert (IMemLoc -> Int
unIMemLoc IMemLoc
globalLoc) IntSet
initLocs (PointsToFact -> IntMap IntSet
memMap PointsToFact
f) }
        finder Node (Lexeme ScopedId)
_ = () -> StateT PointsToFact PointsToAnalysis ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        actions :: AstActions (StateT PointsToFact PointsToAnalysis) ScopedId
actions = AstActions (StateT PointsToFact PointsToAnalysis) ScopedId
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions { doNode :: String
-> Node (Lexeme ScopedId)
-> StateT PointsToFact PointsToAnalysis ()
-> StateT PointsToFact PointsToAnalysis ()
doNode = \String
_ Node (Lexeme ScopedId)
n StateT PointsToFact PointsToAnalysis ()
act -> Node (Lexeme ScopedId) -> StateT PointsToFact PointsToAnalysis ()
finder Node (Lexeme ScopedId)
n StateT PointsToFact PointsToAnalysis ()
-> StateT PointsToFact PointsToAnalysis ()
-> StateT PointsToFact PointsToAnalysis ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT PointsToFact PointsToAnalysis ()
act }
    in
        StateT PointsToFact PointsToAnalysis ()
-> PointsToFact -> State MemLocPool PointsToFact
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (AstActions (StateT PointsToFact PointsToAnalysis) ScopedId
-> [Node (Lexeme ScopedId)]
-> StateT PointsToFact PointsToAnalysis ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT PointsToFact PointsToAnalysis) ScopedId
actions [Node (Lexeme ScopedId)]
ast) PointsToFact
initialFacts

mergeSummaries :: [FunctionSummary] -> FunctionSummary
mergeSummaries :: [FunctionSummary] -> FunctionSummary
mergeSummaries [FunctionSummary]
summaries =
    let allReturnValues :: IntSet
allReturnValues = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions ((FunctionSummary -> IntSet) -> [FunctionSummary] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map FunctionSummary -> IntSet
fsReturnValue [FunctionSummary]
summaries)
        allParamEffects :: Map Int IntSet
allParamEffects = (IntSet -> IntSet -> IntSet) -> [Map Int IntSet] -> Map Int IntSet
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith IntSet -> IntSet -> IntSet
IntSet.union ((FunctionSummary -> Map Int IntSet)
-> [FunctionSummary] -> [Map Int IntSet]
forall a b. (a -> b) -> [a] -> [b]
map FunctionSummary -> Map Int IntSet
fsParamEffects [FunctionSummary]
summaries)
        allMemEffects :: IntMap IntSet
allMemEffects = (IntSet -> IntSet -> IntSet) -> [IntMap IntSet] -> IntMap IntSet
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IntMap.unionsWith IntSet -> IntSet -> IntSet
IntSet.union ((FunctionSummary -> IntMap IntSet)
-> [FunctionSummary] -> [IntMap IntSet]
forall a b. (a -> b) -> [a] -> [b]
map FunctionSummary -> IntMap IntSet
fsMemEffects [FunctionSummary]
summaries)
    in IntSet -> Map Int IntSet -> IntMap IntSet -> FunctionSummary
FunctionSummary IntSet
allReturnValues Map Int IntSet
allParamEffects IntMap IntSet
allMemEffects

iterateFixpoint :: PointsToContext ScopedId -> State FixpointState ()
iterateFixpoint :: PointsToContext ScopedId -> State FixpointState ()
iterateFixpoint PointsToContext ScopedId
ctx = do
    Worklist (ScopedId, RelevantInputState, [ScopedId])
worklist <- (FixpointState
 -> Worklist (ScopedId, RelevantInputState, [ScopedId]))
-> StateT
     FixpointState
     Identity
     (Worklist (ScopedId, RelevantInputState, [ScopedId]))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FixpointState
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist
    case Worklist (ScopedId, RelevantInputState, [ScopedId])
-> Maybe
     ((ScopedId, RelevantInputState, [ScopedId]),
      Worklist (ScopedId, RelevantInputState, [ScopedId]))
forall a. Worklist a -> Maybe (a, Worklist a)
pop Worklist (ScopedId, RelevantInputState, [ScopedId])
worklist of
        Maybe
  ((ScopedId, RelevantInputState, [ScopedId]),
   Worklist (ScopedId, RelevantInputState, [ScopedId]))
Nothing -> () -> State FixpointState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Fixpoint reached
        Just ((ScopedId
funcId, RelevantInputState
ris, [ScopedId]
callStack), Worklist (ScopedId, RelevantInputState, [ScopedId])
worklist') -> do
            String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> State FixpointState ())
-> String -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ String
"Analyzing func: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (ScopedId -> Text
sidName ScopedId
funcId) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with RIS"
            (FixpointState -> FixpointState) -> State FixpointState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FixpointState -> FixpointState) -> State FixpointState ())
-> (FixpointState -> FixpointState) -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ \FixpointState
s -> FixpointState
s { fsWorklist :: Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist = Worklist (ScopedId, RelevantInputState, [ScopedId])
worklist' }

            -- Recursion Check
            Bool -> State FixpointState () -> State FixpointState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScopedId
funcId ScopedId -> [ScopedId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ScopedId]
callStack) (State FixpointState () -> State FixpointState ())
-> State FixpointState () -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$
                String -> State FixpointState ()
forall a. HasCallStack => String -> a
error (String -> State FixpointState ())
-> String -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ String
"Recursion detected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show ((ScopedId -> Text) -> [ScopedId] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ScopedId -> Text
sidName ([ScopedId] -> [ScopedId]
forall a. [a] -> [a]
reverse (ScopedId
funcId ScopedId -> [ScopedId] -> [ScopedId]
forall a. a -> [a] -> [a]
: [ScopedId]
callStack)))

            FixpointState
st <- StateT FixpointState Identity FixpointState
forall s (m :: * -> *). MonadState s m => m s
get
            let currentGlobalEnv :: GlobalEnv
currentGlobalEnv = FixpointState -> GlobalEnv
fsGlobalEnv FixpointState
st
            let funcNodes :: [Node (Lexeme ScopedId)]
funcNodes = [Node (Lexeme ScopedId)]
-> Maybe [Node (Lexeme ScopedId)] -> [Node (Lexeme ScopedId)]
forall a. a -> Maybe a -> a
fromMaybe (String -> [Node (Lexeme ScopedId)]
forall a. HasCallStack => String -> a
error (String -> [Node (Lexeme ScopedId)])
-> String -> [Node (Lexeme ScopedId)]
forall a b. (a -> b) -> a -> b
$ String
"Function AST not found for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScopedId -> String
forall a. Show a => a -> String
show ScopedId
funcId) (ScopedId
-> Map ScopedId [Node (Lexeme ScopedId)]
-> Maybe [Node (Lexeme ScopedId)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
funcId (FixpointState -> Map ScopedId [Node (Lexeme ScopedId)]
fsFuncs FixpointState
st))
            let varTypes :: Map ScopedId (Node (Lexeme ScopedId))
varTypes = Map ScopedId (Node (Lexeme ScopedId))
-> Maybe (Map ScopedId (Node (Lexeme ScopedId)))
-> Map ScopedId (Node (Lexeme ScopedId))
forall a. a -> Maybe a -> a
fromMaybe Map ScopedId (Node (Lexeme ScopedId))
forall k a. Map k a
Map.empty (ScopedId
-> Map ScopedId (Map ScopedId (Node (Lexeme ScopedId)))
-> Maybe (Map ScopedId (Node (Lexeme ScopedId)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
funcId (FixpointState
-> Map ScopedId (Map ScopedId (Node (Lexeme ScopedId)))
fsVarTypes FixpointState
st))
            let updatedCtx :: PointsToContext ScopedId
updatedCtx = PointsToContext ScopedId
ctx { pcGlobalEnv :: GlobalEnv
pcGlobalEnv = GlobalEnv
currentGlobalEnv, pcFuncs :: Map ScopedId [Node (Lexeme ScopedId)]
pcFuncs = FixpointState -> Map ScopedId [Node (Lexeme ScopedId)]
fsFuncs FixpointState
st, pcCurrentFunc :: ScopedId
pcCurrentFunc = ScopedId
funcId, pcVarTypes :: Map ScopedId (Node (Lexeme ScopedId))
pcVarTypes = Map ScopedId (Node (Lexeme ScopedId))
varTypes } :: PointsToContext ScopedId

            let params :: [ScopedId]
params = [ScopedId] -> Maybe [ScopedId] -> [ScopedId]
forall a. a -> Maybe a -> a
fromMaybe [] (ScopedId -> Map ScopedId [ScopedId] -> Maybe [ScopedId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
funcId (FixpointState -> Map ScopedId [ScopedId]
fsParams FixpointState
st))
            PointsToFact
initialGlobalFacts <- (FixpointState -> PointsToFact)
-> StateT FixpointState Identity PointsToFact
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FixpointState -> PointsToFact
fsInitialFacts

            -- Use RIS as initial facts
            let (RelevantInputState PointsToFact
initialFactsForFunc) = RelevantInputState
ris
            String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> State FixpointState ())
-> String -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ String
"    initialFactsForFunc: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PointsToFact -> String
forall a. Show a => a -> String
show PointsToFact
initialFactsForFunc

            -- Analyze each definition and collect results
            [(FunctionSummary, Set (ScopedId, RelevantInputState),
  CFG ScopedId PointsToFact)]
results <- [Node (Lexeme ScopedId)]
-> (Node (Lexeme ScopedId)
    -> StateT
         FixpointState
         Identity
         (FunctionSummary, Set (ScopedId, RelevantInputState),
          CFG ScopedId PointsToFact))
-> StateT
     FixpointState
     Identity
     [(FunctionSummary, Set (ScopedId, RelevantInputState),
       CFG ScopedId PointsToFact)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Node (Lexeme ScopedId)]
funcNodes ((Node (Lexeme ScopedId)
  -> StateT
       FixpointState
       Identity
       (FunctionSummary, Set (ScopedId, RelevantInputState),
        CFG ScopedId PointsToFact))
 -> StateT
      FixpointState
      Identity
      [(FunctionSummary, Set (ScopedId, RelevantInputState),
        CFG ScopedId PointsToFact)])
-> (Node (Lexeme ScopedId)
    -> StateT
         FixpointState
         Identity
         (FunctionSummary, Set (ScopedId, RelevantInputState),
          CFG ScopedId PointsToFact))
-> StateT
     FixpointState
     Identity
     [(FunctionSummary, Set (ScopedId, RelevantInputState),
       CFG ScopedId PointsToFact)]
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme ScopedId)
funcNode -> do
                CFG ScopedId PointsToFact
cfg <- PointsToAnalysis (CFG ScopedId PointsToFact)
-> State FixpointState (CFG ScopedId PointsToFact)
forall a. PointsToAnalysis a -> State FixpointState a
liftPointsToAnalysis (PointsToAnalysis (CFG ScopedId PointsToFact)
 -> State FixpointState (CFG ScopedId PointsToFact))
-> PointsToAnalysis (CFG ScopedId PointsToFact)
-> State FixpointState (CFG ScopedId PointsToFact)
forall a b. (a -> b) -> a -> b
$ PointsToContext ScopedId
-> Node (Lexeme ScopedId)
-> PointsToFact
-> PointsToAnalysis (CFG ScopedId PointsToFact)
forall (m :: * -> *) (c :: * -> *) l a callCtx.
(DataFlow m c l a callCtx, Pretty l, Ord l, Show l, IsString l) =>
c l -> Node (Lexeme l) -> a -> m (CFG l a)
buildCFG PointsToContext ScopedId
updatedCtx Node (Lexeme ScopedId)
funcNode PointsToFact
initialFactsForFunc
                (CFG ScopedId PointsToFact
finalCfg, Set (ScopedId, RelevantInputState)
newWork) <- PointsToAnalysis
  (CFG ScopedId PointsToFact, Set (ScopedId, RelevantInputState))
-> State
     FixpointState
     (CFG ScopedId PointsToFact, Set (ScopedId, RelevantInputState))
forall a. PointsToAnalysis a -> State FixpointState a
liftPointsToAnalysis (PointsToAnalysis
   (CFG ScopedId PointsToFact, Set (ScopedId, RelevantInputState))
 -> State
      FixpointState
      (CFG ScopedId PointsToFact, Set (ScopedId, RelevantInputState)))
-> PointsToAnalysis
     (CFG ScopedId PointsToFact, Set (ScopedId, RelevantInputState))
-> State
     FixpointState
     (CFG ScopedId PointsToFact, Set (ScopedId, RelevantInputState))
forall a b. (a -> b) -> a -> b
$ PointsToContext ScopedId
-> ScopedId
-> CFG ScopedId PointsToFact
-> PointsToAnalysis
     (CFG ScopedId PointsToFact, Set (ScopedId, RelevantInputState))
forall (m :: * -> *) (c :: * -> *) l a callCtx.
(DataFlow m c l a callCtx, Show l, Ord l) =>
c l -> l -> CFG l a -> m (CFG l a, Set (l, callCtx))
fixpoint PointsToContext ScopedId
updatedCtx ScopedId
funcId CFG ScopedId PointsToFact
cfg

                let exitNodeFacts :: PointsToFact
exitNodeFacts = CFGNode ScopedId PointsToFact -> PointsToFact
forall l a. CFGNode l a -> a
cfgOutFacts (CFGNode ScopedId PointsToFact -> PointsToFact)
-> CFGNode ScopedId PointsToFact -> PointsToFact
forall a b. (a -> b) -> a -> b
$ [CFGNode ScopedId PointsToFact] -> CFGNode ScopedId PointsToFact
forall a. [a] -> a
last (CFG ScopedId PointsToFact -> [CFGNode ScopedId PointsToFact]
forall k a. Map k a -> [a]
Map.elems CFG ScopedId PointsToFact
finalCfg)
                String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> State FixpointState ())
-> String -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ String
"  exitNodeFacts: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PointsToFact -> String
forall a. Show a => a -> String
show PointsToFact
exitNodeFacts
                MemLocPool
pool <- (FixpointState -> MemLocPool)
-> StateT FixpointState Identity MemLocPool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FixpointState -> MemLocPool
fsMemLocPool
                let paramEffects :: Map Int IntSet
paramEffects = [(Int, IntSet)] -> Map Int IntSet
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, IntSet)] -> Map Int IntSet)
-> [(Int, IntSet)] -> Map Int IntSet
forall a b. (a -> b) -> a -> b
$ ((ScopedId, Int) -> (Int, IntSet))
-> [(ScopedId, Int)] -> [(Int, IntSet)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScopedId
paramId, Int
idx) ->
                                let getPointedToLocs :: PointsToFact -> ScopedId -> IntSet
getPointedToLocs PointsToFact
facts ScopedId
param =
                                        let paramLocs :: IntSet
paramLocs = IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe IntSet
IntSet.empty (ScopedId -> Map ScopedId IntSet -> Maybe IntSet
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
param (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
facts))
                                        in [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions ([IntSet] -> IntSet) -> [IntSet] -> IntSet
forall a b. (a -> b) -> a -> b
$ (Int -> IntSet) -> [Int] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
ilocInt -> case MemLoc -> Int -> IntMap MemLoc -> MemLoc
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault MemLoc
UnknownLoc Int
ilocInt (MemLocPool -> IntMap MemLoc
idToMemLoc MemLocPool
pool) of
                                            StackLoc ScopedId
sid -> case ScopedId -> Map ScopedId IntSet -> Maybe IntSet
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScopedId
sid (PointsToFact -> Map ScopedId IntSet
varMap PointsToFact
facts) of
                                                Just IntSet
v  -> IntSet
v
                                                Maybe IntSet
Nothing -> IntSet -> Int -> IntMap IntSet -> IntSet
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty Int
ilocInt (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts)
                                            MemLoc
_            -> IntSet -> Int -> IntMap IntSet -> IntSet
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault IntSet
IntSet.empty Int
ilocInt (PointsToFact -> IntMap IntSet
memMap PointsToFact
facts)
                                        ) (IntSet -> [Int]
IntSet.toList IntSet
paramLocs)
                                    finalPointedTo :: IntSet
finalPointedTo = PointsToFact -> ScopedId -> IntSet
getPointedToLocs PointsToFact
exitNodeFacts ScopedId
paramId
                                in (Int
idx, IntSet
finalPointedTo)
                        ) ([ScopedId] -> [Int] -> [(ScopedId, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ScopedId]
params [Int
0..])

                let returns :: [Node (Lexeme ScopedId)]
returns = Node (Lexeme ScopedId) -> [Node (Lexeme ScopedId)]
findReturnStmts Node (Lexeme ScopedId)
funcNode
                let stmtToNodeId :: Map (Node (Lexeme ScopedId)) Int
stmtToNodeId = [Map (Node (Lexeme ScopedId)) Int]
-> Map (Node (Lexeme ScopedId)) Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map (Node (Lexeme ScopedId)) Int]
 -> Map (Node (Lexeme ScopedId)) Int)
-> [Map (Node (Lexeme ScopedId)) Int]
-> Map (Node (Lexeme ScopedId)) Int
forall a b. (a -> b) -> a -> b
$ (CFGNode ScopedId PointsToFact -> Map (Node (Lexeme ScopedId)) Int)
-> [CFGNode ScopedId PointsToFact]
-> [Map (Node (Lexeme ScopedId)) Int]
forall a b. (a -> b) -> [a] -> [b]
map (\CFGNode ScopedId PointsToFact
node -> [(Node (Lexeme ScopedId), Int)] -> Map (Node (Lexeme ScopedId)) Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Node (Lexeme ScopedId), Int)]
 -> Map (Node (Lexeme ScopedId)) Int)
-> [(Node (Lexeme ScopedId), Int)]
-> Map (Node (Lexeme ScopedId)) Int
forall a b. (a -> b) -> a -> b
$ (Node (Lexeme ScopedId) -> (Node (Lexeme ScopedId), Int))
-> [Node (Lexeme ScopedId)] -> [(Node (Lexeme ScopedId), Int)]
forall a b. (a -> b) -> [a] -> [b]
map (, CFGNode ScopedId PointsToFact -> Int
forall l a. CFGNode l a -> Int
cfgNodeId CFGNode ScopedId PointsToFact
node) (CFGNode ScopedId PointsToFact -> [Node (Lexeme ScopedId)]
forall l a. CFGNode l a -> [Node (Lexeme l)]
cfgStmts CFGNode ScopedId PointsToFact
node)) (CFG ScopedId PointsToFact -> [CFGNode ScopedId PointsToFact]
forall k a. Map k a -> [a]
Map.elems CFG ScopedId PointsToFact
finalCfg)
                IntSet
returnLocs <- StateT MemLocPool Identity IntSet -> State FixpointState IntSet
forall a. PointsToAnalysis a -> State FixpointState a
liftPointsToAnalysis (StateT MemLocPool Identity IntSet -> State FixpointState IntSet)
-> StateT MemLocPool Identity IntSet -> State FixpointState IntSet
forall a b. (a -> b) -> a -> b
$ (IntSet
 -> Node (Lexeme ScopedId) -> StateT MemLocPool Identity IntSet)
-> IntSet
-> [Node (Lexeme ScopedId)]
-> StateT MemLocPool Identity IntSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\IntSet
acc Node (Lexeme ScopedId)
ret ->
                            case Node (Lexeme ScopedId)
-> Map (Node (Lexeme ScopedId)) Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node (Lexeme ScopedId)
ret Map (Node (Lexeme ScopedId)) Int
stmtToNodeId of
                                Maybe Int
Nothing ->
                                    case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
ret of
                                        C.Return (Just Node (Lexeme ScopedId)
_) -> do
                                            IMemLoc
iloc <- MemLoc -> PointsToAnalysis IMemLoc
intern MemLoc
UnknownLoc
                                            IntSet -> StateT MemLocPool Identity IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> StateT MemLocPool Identity IntSet)
-> IntSet -> StateT MemLocPool Identity IntSet
forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
IntSet.insert (IMemLoc -> Int
unIMemLoc IMemLoc
iloc) IntSet
acc
                                        NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_                 -> IntSet -> StateT MemLocPool Identity IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
acc
                                Just Int
nodeId ->
                                    let nodeFacts :: PointsToFact
nodeFacts = CFGNode ScopedId PointsToFact -> PointsToFact
forall l a. CFGNode l a -> a
cfgOutFacts (CFGNode ScopedId PointsToFact -> PointsToFact)
-> CFGNode ScopedId PointsToFact -> PointsToFact
forall a b. (a -> b) -> a -> b
$ CFGNode ScopedId PointsToFact
-> Maybe (CFGNode ScopedId PointsToFact)
-> CFGNode ScopedId PointsToFact
forall a. a -> Maybe a -> a
fromMaybe (String -> CFGNode ScopedId PointsToFact
forall a. HasCallStack => String -> a
error String
"CFG node not found") (Int
-> CFG ScopedId PointsToFact
-> Maybe (CFGNode ScopedId PointsToFact)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
nodeId CFG ScopedId PointsToFact
finalCfg)
                                    in case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
ret of
                                        C.Return (Just Node (Lexeme ScopedId)
expr) ->
                                            case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
expr of
                                                C.LiteralExpr {} -> IntSet -> StateT MemLocPool Identity IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
acc
                                                NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_                -> do
                                                    IntSet
locs <- PointsToFact
-> PointsToContext ScopedId
-> Int
-> Node (Lexeme ScopedId)
-> StateT MemLocPool Identity IntSet
evalExpr PointsToFact
nodeFacts PointsToContext ScopedId
updatedCtx Int
nodeId Node (Lexeme ScopedId)
expr
                                                    IntSet -> StateT MemLocPool Identity IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> StateT MemLocPool Identity IntSet)
-> IntSet -> StateT MemLocPool Identity IntSet
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IntSet.union IntSet
locs IntSet
acc
                                        NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> IntSet -> StateT MemLocPool Identity IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
acc
                        ) IntSet
IntSet.empty [Node (Lexeme ScopedId)]
returns
                let memEffects :: IntMap IntSet
memEffects = (IntSet -> IntSet -> Maybe IntSet)
-> IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a b. (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
IntMap.differenceWith (\IntSet
n IntSet
o -> if IntSet
n IntSet -> IntSet -> Bool
forall a. Eq a => a -> a -> Bool
== IntSet
o then Maybe IntSet
forall a. Maybe a
Nothing else IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
n) (PointsToFact -> IntMap IntSet
memMap PointsToFact
exitNodeFacts) (PointsToFact -> IntMap IntSet
memMap PointsToFact
initialFactsForFunc)
                String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> State FixpointState ())
-> String -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ String
"    memEffects for one def: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IntMap IntSet -> String
forall a. Show a => a -> String
show IntMap IntSet
memEffects
                let summary :: FunctionSummary
summary = IntSet -> Map Int IntSet -> IntMap IntSet -> FunctionSummary
FunctionSummary IntSet
returnLocs Map Int IntSet
paramEffects IntMap IntSet
memEffects
                String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> State FixpointState ())
-> String -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ String
"    summary for one def: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionSummary -> String
forall a. Show a => a -> String
show FunctionSummary
summary
                (FunctionSummary, Set (ScopedId, RelevantInputState),
 CFG ScopedId PointsToFact)
-> StateT
     FixpointState
     Identity
     (FunctionSummary, Set (ScopedId, RelevantInputState),
      CFG ScopedId PointsToFact)
forall (m :: * -> *) a. Monad m => a -> m a
return (FunctionSummary
summary, Set (ScopedId, RelevantInputState)
newWork, CFG ScopedId PointsToFact
finalCfg)

            let ([FunctionSummary]
summaries, [Set (ScopedId, RelevantInputState)]
workSets, [CFG ScopedId PointsToFact]
cfgs) = [(FunctionSummary, Set (ScopedId, RelevantInputState),
  CFG ScopedId PointsToFact)]
-> ([FunctionSummary], [Set (ScopedId, RelevantInputState)],
    [CFG ScopedId PointsToFact])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(FunctionSummary, Set (ScopedId, RelevantInputState),
  CFG ScopedId PointsToFact)]
results
            let newSummary :: FunctionSummary
newSummary = [FunctionSummary] -> FunctionSummary
mergeSummaries [FunctionSummary]
summaries
            let newWork :: Set (ScopedId, RelevantInputState)
newWork = [Set (ScopedId, RelevantInputState)]
-> Set (ScopedId, RelevantInputState)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set (ScopedId, RelevantInputState)]
workSets
            String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> State FixpointState ())
-> String -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ String
"  merged newSummary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FunctionSummary -> String
forall a. Show a => a -> String
show FunctionSummary
newSummary

            (FixpointState -> FixpointState) -> State FixpointState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FixpointState -> FixpointState) -> State FixpointState ())
-> (FixpointState -> FixpointState) -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ \FixpointState
s -> FixpointState
s { fsCFGCache :: CFGCache
fsCFGCache = (ScopedId, RelevantInputState)
-> ([CFG ScopedId PointsToFact], Map ScopedId Int)
-> CFGCache
-> CFGCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ScopedId
funcId, RelevantInputState
ris) ([CFG ScopedId PointsToFact]
cfgs, Map ScopedId Int
forall k a. Map k a
Map.empty) (FixpointState -> CFGCache
fsCFGCache FixpointState
s) }

            -- Handle new call targets by adding them to the worklist
            [(ScopedId, RelevantInputState)]
-> ((ScopedId, RelevantInputState) -> State FixpointState ())
-> State FixpointState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set (ScopedId, RelevantInputState)
-> [(ScopedId, RelevantInputState)]
forall a. Set a -> [a]
Set.toList Set (ScopedId, RelevantInputState)
newWork) (((ScopedId, RelevantInputState) -> State FixpointState ())
 -> State FixpointState ())
-> ((ScopedId, RelevantInputState) -> State FixpointState ())
-> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ \(ScopedId
callee, RelevantInputState
calleeRIS) -> do
                let newCallStack :: [ScopedId]
newCallStack = ScopedId
funcId ScopedId -> [ScopedId] -> [ScopedId]
forall a. a -> [a] -> [a]
: [ScopedId]
callStack
                let newWorkItem :: (ScopedId, RelevantInputState, [ScopedId])
newWorkItem = (ScopedId
callee, RelevantInputState
calleeRIS, [ScopedId]
newCallStack)
                String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM (String -> State FixpointState ())
-> String -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ String
"  adding to worklist: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show (ScopedId -> Text
sidName ScopedId
callee) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with RIS"
                (FixpointState -> FixpointState) -> State FixpointState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FixpointState -> FixpointState) -> State FixpointState ())
-> (FixpointState -> FixpointState) -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ \FixpointState
s -> FixpointState
s { fsWorklist :: Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist = (ScopedId, RelevantInputState, [ScopedId])
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
forall a. a -> Worklist a -> Worklist a
push (ScopedId, RelevantInputState, [ScopedId])
newWorkItem (FixpointState
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist FixpointState
s) }
                let callerKey :: (ScopedId, RelevantInputState)
callerKey = (ScopedId
funcId, RelevantInputState
ris)
                let calleeKey :: (ScopedId, RelevantInputState)
calleeKey = (ScopedId
callee, RelevantInputState
calleeRIS)
                let newEdge :: CallGraph
newEdge = (ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState) -> CallGraph
forall k a. k -> a -> Map k a
Map.singleton (ScopedId, RelevantInputState)
callerKey ((ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState)
forall a. a -> Set a
Set.singleton (ScopedId, RelevantInputState)
calleeKey)
                let newRevEdge :: CallGraph
newRevEdge = (ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState) -> CallGraph
forall k a. k -> a -> Map k a
Map.singleton (ScopedId, RelevantInputState)
calleeKey ((ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState)
forall a. a -> Set a
Set.singleton (ScopedId, RelevantInputState)
callerKey)
                (FixpointState -> FixpointState) -> State FixpointState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FixpointState -> FixpointState) -> State FixpointState ())
-> (FixpointState -> FixpointState) -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ \FixpointState
s -> FixpointState
s { fsCallGraph :: CallGraph
fsCallGraph = (Set (ScopedId, RelevantInputState)
 -> Set (ScopedId, RelevantInputState)
 -> Set (ScopedId, RelevantInputState))
-> CallGraph -> CallGraph -> CallGraph
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set (ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState)
forall a. Ord a => Set a -> Set a -> Set a
Set.union (FixpointState -> CallGraph
fsCallGraph FixpointState
s) CallGraph
newEdge
                                 , fsReversedCallGraph :: CallGraph
fsReversedCallGraph = (Set (ScopedId, RelevantInputState)
 -> Set (ScopedId, RelevantInputState)
 -> Set (ScopedId, RelevantInputState))
-> CallGraph -> CallGraph -> CallGraph
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set (ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState)
-> Set (ScopedId, RelevantInputState)
forall a. Ord a => Set a -> Set a -> Set a
Set.union (FixpointState -> CallGraph
fsReversedCallGraph FixpointState
s) CallGraph
newRevEdge
                                 }

            let GlobalEnv Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
gEnv = GlobalEnv
currentGlobalEnv
            let oldSummaryTuple :: Maybe (FunctionSummary, PointsToFact)
oldSummaryTuple = (ScopedId, RelevantInputState)
-> Map
     (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
-> Maybe (FunctionSummary, PointsToFact)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopedId
funcId, RelevantInputState
ris) Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
gEnv

            case Maybe (FunctionSummary, PointsToFact)
oldSummaryTuple of
                Maybe (FunctionSummary, PointsToFact)
Nothing -> do -- First time analyzing this function/context
                    String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM String
"  first analysis, storing summary and propagating to callers"
                    let newGlobalEnv :: GlobalEnv
newGlobalEnv = Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
-> GlobalEnv
GlobalEnv ((ScopedId, RelevantInputState)
-> (FunctionSummary, PointsToFact)
-> Map
     (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
-> Map
     (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ScopedId
funcId, RelevantInputState
ris) (FunctionSummary
newSummary, PointsToFact
initialFactsForFunc) Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
gEnv)
                    let callers :: Set (ScopedId, RelevantInputState)
callers = Set (ScopedId, RelevantInputState)
-> Maybe (Set (ScopedId, RelevantInputState))
-> Set (ScopedId, RelevantInputState)
forall a. a -> Maybe a -> a
fromMaybe Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty ((ScopedId, RelevantInputState)
-> CallGraph -> Maybe (Set (ScopedId, RelevantInputState))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopedId
funcId, RelevantInputState
ris) (FixpointState -> CallGraph
fsReversedCallGraph FixpointState
st))
                    let callerWorkItems :: [(ScopedId, RelevantInputState, [a])]
callerWorkItems = ((ScopedId, RelevantInputState)
 -> (ScopedId, RelevantInputState, [a]))
-> [(ScopedId, RelevantInputState)]
-> [(ScopedId, RelevantInputState, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScopedId
c, RelevantInputState
cRis) -> (ScopedId
c, RelevantInputState
cRis, [])) (Set (ScopedId, RelevantInputState)
-> [(ScopedId, RelevantInputState)]
forall a. Set a -> [a]
Set.toList Set (ScopedId, RelevantInputState)
callers)
                    (FixpointState -> FixpointState) -> State FixpointState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FixpointState -> FixpointState) -> State FixpointState ())
-> (FixpointState -> FixpointState) -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ \FixpointState
s -> FixpointState
s { fsGlobalEnv :: GlobalEnv
fsGlobalEnv = GlobalEnv
newGlobalEnv, fsWorklist :: Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist = [(ScopedId, RelevantInputState, [ScopedId])]
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
forall a. [a] -> Worklist a -> Worklist a
pushList [(ScopedId, RelevantInputState, [ScopedId])]
forall a. [(ScopedId, RelevantInputState, [a])]
callerWorkItems (FixpointState
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist FixpointState
s) }

                Just (FunctionSummary
oldSummary, PointsToFact
_) -> do -- Re-analyzing
                    if FunctionSummary
newSummary FunctionSummary -> FunctionSummary -> Bool
forall a. Eq a => a -> a -> Bool
/= FunctionSummary
oldSummary
                    then do
                        String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM String
"  summary changed, propagating to callers"
                        let newGlobalEnv :: GlobalEnv
newGlobalEnv = Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
-> GlobalEnv
GlobalEnv ((ScopedId, RelevantInputState)
-> (FunctionSummary, PointsToFact)
-> Map
     (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
-> Map
     (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ScopedId
funcId, RelevantInputState
ris) (FunctionSummary
newSummary, PointsToFact
initialFactsForFunc) Map (ScopedId, RelevantInputState) (FunctionSummary, PointsToFact)
gEnv)
                        let callers :: Set (ScopedId, RelevantInputState)
callers = Set (ScopedId, RelevantInputState)
-> Maybe (Set (ScopedId, RelevantInputState))
-> Set (ScopedId, RelevantInputState)
forall a. a -> Maybe a -> a
fromMaybe Set (ScopedId, RelevantInputState)
forall a. Set a
Set.empty ((ScopedId, RelevantInputState)
-> CallGraph -> Maybe (Set (ScopedId, RelevantInputState))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopedId
funcId, RelevantInputState
ris) (FixpointState -> CallGraph
fsReversedCallGraph FixpointState
st))
                        let callerWorkItems :: [(ScopedId, RelevantInputState, [a])]
callerWorkItems = ((ScopedId, RelevantInputState)
 -> (ScopedId, RelevantInputState, [a]))
-> [(ScopedId, RelevantInputState)]
-> [(ScopedId, RelevantInputState, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\(ScopedId
c, RelevantInputState
cRis) -> (ScopedId
c, RelevantInputState
cRis, [])) (Set (ScopedId, RelevantInputState)
-> [(ScopedId, RelevantInputState)]
forall a. Set a -> [a]
Set.toList Set (ScopedId, RelevantInputState)
callers)
                        (FixpointState -> FixpointState) -> State FixpointState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FixpointState -> FixpointState) -> State FixpointState ())
-> (FixpointState -> FixpointState) -> State FixpointState ()
forall a b. (a -> b) -> a -> b
$ \FixpointState
s -> FixpointState
s { fsGlobalEnv :: GlobalEnv
fsGlobalEnv = GlobalEnv
newGlobalEnv, fsWorklist :: Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist = [(ScopedId, RelevantInputState, [ScopedId])]
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
forall a. [a] -> Worklist a -> Worklist a
pushList [(ScopedId, RelevantInputState, [ScopedId])]
forall a. [(ScopedId, RelevantInputState, [a])]
callerWorkItems (FixpointState
-> Worklist (ScopedId, RelevantInputState, [ScopedId])
fsWorklist FixpointState
s) }
                    else do
                        String -> State FixpointState ()
forall (m :: * -> *). Monad m => String -> m ()
dtraceM String
"  summary unchanged"

            PointsToContext ScopedId -> State FixpointState ()
iterateFixpoint PointsToContext ScopedId
ctx -- Recurse

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

findReturnStmts :: C.Node (C.Lexeme ScopedId) -> [C.Node (C.Lexeme ScopedId)]
findReturnStmts :: Node (Lexeme ScopedId) -> [Node (Lexeme ScopedId)]
findReturnStmts Node (Lexeme ScopedId)
funcNode =
    let
        finder :: Fix (NodeF lexeme) -> m ()
finder (node :: Fix (NodeF lexeme)
node@(Fix (C.Return Maybe (Fix (NodeF lexeme))
_))) = ([Fix (NodeF lexeme)] -> [Fix (NodeF lexeme)]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Fix (NodeF lexeme)
node Fix (NodeF lexeme) -> [Fix (NodeF lexeme)] -> [Fix (NodeF lexeme)]
forall a. a -> [a] -> [a]
:)
        finder Fix (NodeF lexeme)
_                         = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        actions :: AstActions (StateT [Node (Lexeme ScopedId)] Identity) ScopedId
actions = AstActions (StateT [Node (Lexeme ScopedId)] Identity) ScopedId
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions { doNode :: String
-> Node (Lexeme ScopedId)
-> StateT [Node (Lexeme ScopedId)] Identity ()
-> StateT [Node (Lexeme ScopedId)] Identity ()
doNode = \String
_ Node (Lexeme ScopedId)
n StateT [Node (Lexeme ScopedId)] Identity ()
act -> Node (Lexeme ScopedId)
-> StateT [Node (Lexeme ScopedId)] Identity ()
forall lexeme (m :: * -> *).
MonadState [Fix (NodeF lexeme)] m =>
Fix (NodeF lexeme) -> m ()
finder Node (Lexeme ScopedId)
n StateT [Node (Lexeme ScopedId)] Identity ()
-> StateT [Node (Lexeme ScopedId)] Identity ()
-> StateT [Node (Lexeme ScopedId)] Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT [Node (Lexeme ScopedId)] Identity ()
act }
    in
        StateT [Node (Lexeme ScopedId)] Identity ()
-> [Node (Lexeme ScopedId)] -> [Node (Lexeme ScopedId)]
forall s a. State s a -> s -> s
execState (AstActions (StateT [Node (Lexeme ScopedId)] Identity) ScopedId
-> Node (Lexeme ScopedId)
-> StateT [Node (Lexeme ScopedId)] Identity ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT [Node (Lexeme ScopedId)] Identity) ScopedId
actions Node (Lexeme ScopedId)
funcNode) []

findEntryPointsAndFuncMap :: [C.Node (C.Lexeme ScopedId)] -> ([ScopedId], Map ScopedId [C.Node (C.Lexeme ScopedId)])
findEntryPointsAndFuncMap :: [Node (Lexeme ScopedId)]
-> ([ScopedId], Map ScopedId [Node (Lexeme ScopedId)])
findEntryPointsAndFuncMap [Node (Lexeme ScopedId)]
ast =
    let
        finder :: EntryPointFinder
finder = Map ScopedId [Node (Lexeme ScopedId)]
-> Set ScopedId -> EntryPointFinder
EntryPointFinder Map ScopedId [Node (Lexeme ScopedId)]
forall k a. Map k a
Map.empty Set ScopedId
forall a. Set a
Set.empty
        finalState :: EntryPointFinder
finalState = State EntryPointFinder () -> EntryPointFinder -> EntryPointFinder
forall s a. State s a -> s -> s
execState (AstActions (State EntryPointFinder) ScopedId
-> [Node (Lexeme ScopedId)] -> State EntryPointFinder ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State EntryPointFinder) ScopedId
entryPointActions [Node (Lexeme ScopedId)]
ast) EntryPointFinder
finder
        allFuncs :: Set ScopedId
allFuncs = Map ScopedId [Node (Lexeme ScopedId)] -> Set ScopedId
forall k a. Map k a -> Set k
Map.keysSet (EntryPointFinder -> Map ScopedId [Node (Lexeme ScopedId)]
epFunctions EntryPointFinder
finalState)
        referencedFuncs :: Set ScopedId
referencedFuncs = EntryPointFinder -> Set ScopedId
epReferencedIds EntryPointFinder
finalState Set ScopedId -> Set ScopedId -> Set ScopedId
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set ScopedId
allFuncs
        entryPoints :: [ScopedId]
entryPoints = Set ScopedId -> [ScopedId]
forall a. Set a -> [a]
Set.toList (Set ScopedId -> [ScopedId]) -> Set ScopedId -> [ScopedId]
forall a b. (a -> b) -> a -> b
$ Set ScopedId
allFuncs Set ScopedId -> Set ScopedId -> Set ScopedId
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ScopedId
referencedFuncs
    in
        ([ScopedId]
entryPoints, EntryPointFinder -> Map ScopedId [Node (Lexeme ScopedId)]
epFunctions EntryPointFinder
finalState)

data EntryPointFinder = EntryPointFinder
    { EntryPointFinder -> Map ScopedId [Node (Lexeme ScopedId)]
epFunctions     :: Map ScopedId [C.Node (C.Lexeme ScopedId)]
    , EntryPointFinder -> Set ScopedId
epReferencedIds :: Set ScopedId
    }

entryPointActions :: AstActions (State EntryPointFinder) ScopedId
entryPointActions :: AstActions (State EntryPointFinder) ScopedId
entryPointActions = AstActions (State EntryPointFinder) ScopedId
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: String
-> Node (Lexeme ScopedId)
-> State EntryPointFinder ()
-> State EntryPointFinder ()
doNode = \String
_ Node (Lexeme ScopedId)
node State EntryPointFinder ()
act -> do
        case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
node of
            C.FunctionDefn Scope
_ (Fix (C.FunctionPrototype Node (Lexeme ScopedId)
_ (C.L AlexPosn
_ LexemeClass
_ ScopedId
funcId) [Node (Lexeme ScopedId)]
_)) Node (Lexeme ScopedId)
_ -> do
                (EntryPointFinder -> EntryPointFinder) -> State EntryPointFinder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((EntryPointFinder -> EntryPointFinder)
 -> State EntryPointFinder ())
-> (EntryPointFinder -> EntryPointFinder)
-> State EntryPointFinder ()
forall a b. (a -> b) -> a -> b
$ \EntryPointFinder
s -> EntryPointFinder
s { epFunctions :: Map ScopedId [Node (Lexeme ScopedId)]
epFunctions = ([Node (Lexeme ScopedId)]
 -> [Node (Lexeme ScopedId)] -> [Node (Lexeme ScopedId)])
-> ScopedId
-> [Node (Lexeme ScopedId)]
-> Map ScopedId [Node (Lexeme ScopedId)]
-> Map ScopedId [Node (Lexeme ScopedId)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Node (Lexeme ScopedId)]
-> [Node (Lexeme ScopedId)] -> [Node (Lexeme ScopedId)]
forall a. [a] -> [a] -> [a]
(++) ScopedId
funcId [Node (Lexeme ScopedId)
node] (EntryPointFinder -> Map ScopedId [Node (Lexeme ScopedId)]
epFunctions EntryPointFinder
s) }
                State EntryPointFinder ()
act
            C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid) -> do
                (EntryPointFinder -> EntryPointFinder) -> State EntryPointFinder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((EntryPointFinder -> EntryPointFinder)
 -> State EntryPointFinder ())
-> (EntryPointFinder -> EntryPointFinder)
-> State EntryPointFinder ()
forall a b. (a -> b) -> a -> b
$ \EntryPointFinder
s -> EntryPointFinder
s { epReferencedIds :: Set ScopedId
epReferencedIds = ScopedId -> Set ScopedId -> Set ScopedId
forall a. Ord a => a -> Set a -> Set a
Set.insert ScopedId
sid (EntryPointFinder -> Set ScopedId
epReferencedIds EntryPointFinder
s) }
                State EntryPointFinder ()
act
            C.FunctionCall Node (Lexeme ScopedId)
callee [Node (Lexeme ScopedId)]
_ -> do
                case Node (Lexeme ScopedId)
-> NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme ScopedId)
callee of
                    C.VarExpr (C.L AlexPosn
_ LexemeClass
_ ScopedId
sid) -> (EntryPointFinder -> EntryPointFinder) -> State EntryPointFinder ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((EntryPointFinder -> EntryPointFinder)
 -> State EntryPointFinder ())
-> (EntryPointFinder -> EntryPointFinder)
-> State EntryPointFinder ()
forall a b. (a -> b) -> a -> b
$ \EntryPointFinder
s -> EntryPointFinder
s { epReferencedIds :: Set ScopedId
epReferencedIds = ScopedId -> Set ScopedId -> Set ScopedId
forall a. Ord a => a -> Set a -> Set a
Set.insert ScopedId
sid (EntryPointFinder -> Set ScopedId
epReferencedIds EntryPointFinder
s) }
                    NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_                       -> () -> State EntryPointFinder ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                State EntryPointFinder ()
act
            NodeF (Lexeme ScopedId) (Node (Lexeme ScopedId))
_ -> State EntryPointFinder ()
act
    }

findVarTypes :: C.Node (C.Lexeme ScopedId) -> Map ScopedId (C.Node (C.Lexeme ScopedId))
findVarTypes :: Node (Lexeme ScopedId) -> Map ScopedId (Node (Lexeme ScopedId))
findVarTypes Node (Lexeme ScopedId)
funcNode =
    let
        finder :: Fix (NodeF (Lexeme k)) -> m ()
finder (Fix (C.VarDecl Fix (NodeF (Lexeme k))
ty (C.L AlexPosn
_ LexemeClass
_ k
sid) [Fix (NodeF (Lexeme k))]
_)) = (Map k (Fix (NodeF (Lexeme k))) -> Map k (Fix (NodeF (Lexeme k))))
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (k
-> Fix (NodeF (Lexeme k))
-> Map k (Fix (NodeF (Lexeme k)))
-> Map k (Fix (NodeF (Lexeme k)))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
sid Fix (NodeF (Lexeme k))
ty)
        finder Fix (NodeF (Lexeme k))
_                                    = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        actions :: AstActions
  (StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity) ScopedId
actions = AstActions
  (StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity) ScopedId
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions { doNode :: String
-> Node (Lexeme ScopedId)
-> StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
-> StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
doNode = \String
_ Node (Lexeme ScopedId)
n StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
act -> Node (Lexeme ScopedId)
-> StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
forall k (m :: * -> *).
(MonadState (Map k (Fix (NodeF (Lexeme k)))) m, Ord k) =>
Fix (NodeF (Lexeme k)) -> m ()
finder Node (Lexeme ScopedId)
n StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
-> StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
-> StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
act }
    in
        StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
-> Map ScopedId (Node (Lexeme ScopedId))
-> Map ScopedId (Node (Lexeme ScopedId))
forall s a. State s a -> s -> s
execState (AstActions
  (StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity) ScopedId
-> Node (Lexeme ScopedId)
-> StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions
  (StateT (Map ScopedId (Node (Lexeme ScopedId))) Identity) ScopedId
actions Node (Lexeme ScopedId)
funcNode) Map ScopedId (Node (Lexeme ScopedId))
forall k a. Map k a
Map.empty