From 010f4fdd0b8e92511c7d7e4679560b95514ab84c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 15:04:16 -0500 Subject: [PATCH 01/66] Dedent. --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 874deb506..8120eb47c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -17,7 +17,7 @@ import Prelude hiding (fail) -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. class (MonadEvaluator t v m) => MonadValue t v m where - -- | Construct an abstract unit value. + -- | Construct an abstract unit value. unit :: m v -- | Construct an abstract integral value. From 711aa0529ad70a4048c79bea986234601a656cb1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 15:06:49 -0500 Subject: [PATCH 02/66] Stub in a call graph analysis module. --- semantic.cabal | 3 ++- src/Analysis/Abstract/CallGraph.hs | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 src/Analysis/Abstract/CallGraph.hs diff --git a/semantic.cabal b/semantic.cabal index 4f63a5871..159a5f483 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -16,8 +16,9 @@ library exposed-modules: -- Analyses & term annotations -- Analysis.Abstract.Caching + Analysis.Abstract.CallGraph -- , Analysis.Abstract.Collecting - Analysis.Abstract.Dead + , Analysis.Abstract.Dead , Analysis.Abstract.Evaluating -- , Analysis.Abstract.Tracing , Analysis.ConstructorName diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs new file mode 100644 index 000000000..5aeb8f5e9 --- /dev/null +++ b/src/Analysis/Abstract/CallGraph.hs @@ -0,0 +1 @@ +module Analysis.Abstract.CallGraph where From 1773a39e3f669ba512b2a3becf6aac04d04533a3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 15:10:22 -0500 Subject: [PATCH 03/66] =?UTF-8?q?Define=20a=20synonym=20for=20the=20call?= =?UTF-8?q?=20graph=20analysis=E2=80=99=20effects.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/CallGraph.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 5aeb8f5e9..a4ff26c74 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -1 +1,19 @@ +{-# LANGUAGE DataKinds #-} module Analysis.Abstract.CallGraph where + +import Control.Monad.Effect.Fail +import Control.Monad.Effect.NonDetEff +import Control.Monad.Effect.Reader +import Control.Monad.Effect.State +import Data.Abstract.Linker +import Data.Abstract.Value + +type CallGraphEffects term value + = '[ Fail + , NonDetEff + , State (StoreFor value) + , State (EnvironmentFor value) + , Reader (EnvironmentFor value) + , Reader (Linker term) + , State (Linker value) + ] From a7c3741c3089269083c70c984f034f1060669f60 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 15:10:32 -0500 Subject: [PATCH 04/66] Define a newtype for call graph analysis. --- src/Analysis/Abstract/CallGraph.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index a4ff26c74..1f4fe27be 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-} module Analysis.Abstract.CallGraph where +import Control.Abstract.Evaluator import Control.Monad.Effect.Fail import Control.Monad.Effect.NonDetEff import Control.Monad.Effect.Reader @@ -17,3 +18,6 @@ type CallGraphEffects term value , Reader (Linker term) , State (Linker value) ] + +newtype CallGraphAnalysis term value a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term value) term value a } + deriving (Applicative, Functor, Monad) From c855677c2c47e9156ff436877ddc287dd017d783 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 15:11:50 -0500 Subject: [PATCH 05/66] Derive MonadFail & MonadEvaluator instances for CallGraphAnalysis. --- src/Analysis/Abstract/CallGraph.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 1f4fe27be..8623d96e6 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving #-} module Analysis.Abstract.CallGraph where import Control.Abstract.Evaluator @@ -20,4 +20,6 @@ type CallGraphEffects term value ] newtype CallGraphAnalysis term value a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term value) term value a } - deriving (Applicative, Functor, Monad) + deriving (Applicative, Functor, Monad, MonadFail) + +deriving instance MonadEvaluator term value (CallGraphAnalysis term value) From b9c6795ca0f8ab95ddd3df93b517954058d718d8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 15:17:34 -0500 Subject: [PATCH 06/66] Define a CallGraph synonym. --- src/Analysis/Abstract/CallGraph.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 8623d96e6..391418642 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -1,25 +1,29 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving #-} module Analysis.Abstract.CallGraph where +import Algebra.Graph import Control.Abstract.Evaluator import Control.Monad.Effect.Fail import Control.Monad.Effect.NonDetEff import Control.Monad.Effect.Reader import Control.Monad.Effect.State +import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value -type CallGraphEffects term value +type CallGraphEffects term = '[ Fail , NonDetEff - , State (StoreFor value) - , State (EnvironmentFor value) - , Reader (EnvironmentFor value) + , State (StoreFor CallGraph) + , State (EnvironmentFor CallGraph) + , Reader (EnvironmentFor CallGraph) , Reader (Linker term) - , State (Linker value) + , State (Linker CallGraph) ] -newtype CallGraphAnalysis term value a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term value) term value a } +type CallGraph = Graph Name + +newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } deriving (Applicative, Functor, Monad, MonadFail) -deriving instance MonadEvaluator term value (CallGraphAnalysis term value) +deriving instance MonadEvaluator term CallGraph (CallGraphAnalysis term) From 11b600ddf4485cb01f0938ba72845c6540da98b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 16:30:59 -0500 Subject: [PATCH 07/66] Add a method looking up a name in the local environment. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Evaluator.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 5ed3ae46f..f27154de3 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -8,6 +8,9 @@ import Control.Monad.Effect.Fresh import Control.Monad.Effect.NonDetEff import Control.Monad.Effect.Reader import Control.Monad.Effect.State +import Data.Abstract.Address +import Data.Abstract.Environment +import Data.Abstract.FreeVariables import Data.Abstract.Linker import Data.Abstract.Value import Prelude hiding (fail) @@ -29,6 +32,10 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where -- | Run an action with a locally-modified environment. localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a + -- | Look a 'Name' up in the local environment. + lookupLocalEnv :: Name -> m (Maybe (Address (LocationFor value) value)) + lookupLocalEnv name = envLookup name <$> askLocalEnv + -- | Retrieve the heap. getStore :: m (StoreFor value) -- | Update the heap. From 243ae2b5be162842f646acc86a8941e4f7d6143d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 16:33:37 -0500 Subject: [PATCH 08/66] Evaluate Identifier using lookupLocalEnv. Co-Authored-By: Patrick Thomson --- src/Data/Syntax.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index e3275b7d5..38f4b52d0 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -108,9 +108,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = do - env <- askLocalEnv - maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env) + eval (Identifier name) = lookupLocalEnv name >>= maybe (fail ("free variable: " <> unpack name)) deref instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = point x From 1e65e6cef3f99b713b8660dd9acb67b1b4f352ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 16:35:22 -0500 Subject: [PATCH 09/66] CallGraphAnalysis produces a function from CallGraphs to CallGraphs. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 391418642..be0962005 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -10,20 +10,35 @@ import Control.Monad.Effect.State import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value +import Prologue hiding (empty) type CallGraphEffects term = '[ Fail , NonDetEff - , State (StoreFor CallGraph) - , State (EnvironmentFor CallGraph) - , Reader (EnvironmentFor CallGraph) + , State (StoreFor CallGraphS) + , State (EnvironmentFor CallGraphS) + , Reader (EnvironmentFor CallGraphS) , Reader (Linker term) - , State (Linker CallGraph) + , State (Linker CallGraphS) ] type CallGraph = Graph Name +type CallGraphS = CallGraph -> CallGraph -newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } +newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraphS a } deriving (Applicative, Functor, Monad, MonadFail) -deriving instance MonadEvaluator term CallGraph (CallGraphAnalysis term) +deriving instance MonadEvaluator term CallGraphS (CallGraphAnalysis term) + + +instance MonadValue term CallGraphS (CallGraphAnalysis term) where + unit = pure id + integer _ = pure id + boolean _ = pure id + string _ = pure id + + ifthenelse _ then' else' = liftA2 overlay <$> then' <*> else' + + abstract _ = subtermValue + + apply operator arguments = foldr (liftA2 overlay) operator <$> traverse subtermValue arguments From 38427a6b4c35aa91f260b8d9b7aaf6d16c3cae0b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 16:45:40 -0500 Subject: [PATCH 10/66] lookupOrAlloc gets the environment itself. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Addressable.hs | 7 ++----- src/Data/Syntax/Declaration.hs | 6 ++---- src/Data/Syntax/Statement.hs | 2 +- 3 files changed, 5 insertions(+), 10 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index a4eb4b832..f4067b7ac 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -6,7 +6,6 @@ import Control.Applicative import Control.Monad ((<=<)) import Control.Monad.Effect.Fail import Data.Abstract.Address -import Data.Abstract.Environment import Data.Abstract.FreeVariables import Data.Abstract.Store import Data.Abstract.Value @@ -33,7 +32,6 @@ lookupOrAlloc :: ( FreeVariables t ) => t -> a - -> Environment (LocationFor a) a -> m (Name, Address (LocationFor a) a) lookupOrAlloc term = let [name] = toList (freeVariables term) in lookupOrAlloc' name @@ -45,10 +43,9 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in ) => Name -> a - -> Environment (LocationFor a) a -> m (Name, Address (LocationFor a) a) - lookupOrAlloc' name v env = do - a <- maybe (alloc name) pure (envLookup name env) + lookupOrAlloc' name v = do + a <- lookupLocalEnv name >>= maybe (alloc name) pure assign a v pure (name, a) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index bdf639ef7..6ded757db 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -22,10 +22,9 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Function where eval Function{..} = do - env <- askLocalEnv let params = toList (liftFreeVariables (freeVariables . subterm) functionParameters) v <- abstract params functionBody - (name, addr) <- lookupOrAlloc (subterm functionName) v env + (name, addr) <- lookupOrAlloc (subterm functionName) v modifyGlobalEnv (envInsert name addr) pure v @@ -44,11 +43,10 @@ instance Show1 Method where liftShowsPrec = genericLiftShowsPrec -- local environment. instance Evaluatable Method where eval Method{..} = do - env <- askLocalEnv let params = toList (liftFreeVariables (freeVariables . subterm) methodParameters) v <- abstract params methodBody - (name, addr) <- lookupOrAlloc (subterm methodName) v env + (name, addr) <- lookupOrAlloc (subterm methodName) v modifyGlobalEnv (envInsert name addr) pure v diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 7ff984dcf..207478b56 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -94,7 +94,7 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Assignment where eval Assignment{..} = do v <- subtermValue assignmentValue - (var, a) <- askLocalEnv >>= lookupOrAlloc (subterm assignmentTarget) v + (var, a) <- lookupOrAlloc (subterm assignmentTarget) v modifyGlobalEnv (envInsert var a) pure v From 57833e2623e7db95561f8838fc2a16a4d2bceb5a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 16:52:15 -0500 Subject: [PATCH 11/66] Add a lookupWith method to MonadEvaluator. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Evaluator.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index f27154de3..a162a73b9 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -36,6 +36,11 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where lookupLocalEnv :: Name -> m (Maybe (Address (LocationFor value) value)) lookupLocalEnv name = envLookup name <$> askLocalEnv + lookupWith :: (Address (LocationFor value) value -> m value) -> Name -> m (Maybe value) + lookupWith with name = do + addr <- lookupLocalEnv name + maybe (pure Nothing) (fmap Just . with) addr + -- | Retrieve the heap. getStore :: m (StoreFor value) -- | Update the heap. From a7509127a6da1ba04e55db310e63a78ce0aca272 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 17:02:05 -0500 Subject: [PATCH 12/66] Evaluate Identifiers using lookupWith. Co-Authored-By: Patrick Thomson --- src/Data/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 38f4b52d0..14a3907c5 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -108,7 +108,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = lookupLocalEnv name >>= maybe (fail ("free variable: " <> unpack name)) deref + eval (Identifier name) = lookupWith deref name >>= maybe (fail ("free variable: " <> unpack name)) pure instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = point x From 794878dbdbb8ec3125dab90233f92ad9f4bfdbb3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 17:02:18 -0500 Subject: [PATCH 13/66] Specialize lookupWith for CallGraphAnalysis. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index be0962005..1564638f1 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -28,7 +28,28 @@ type CallGraphS = CallGraph -> CallGraph newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraphS a } deriving (Applicative, Functor, Monad, MonadFail) -deriving instance MonadEvaluator term CallGraphS (CallGraphAnalysis term) +instance MonadEvaluator term CallGraphS (CallGraphAnalysis term) where + getGlobalEnv = CallGraphAnalysis getGlobalEnv + modifyGlobalEnv f = CallGraphAnalysis (modifyGlobalEnv f) + + askLocalEnv = CallGraphAnalysis askLocalEnv + localEnv f a = CallGraphAnalysis (localEnv f (runCallGraphAnalysis a)) + + lookupWith with name = do + addr <- lookupLocalEnv name + maybe (pure Nothing) connectWith addr + where connectWith addr = do + v <- with addr + pure (Just (connect <*> v)) + + getStore = CallGraphAnalysis getStore + modifyStore f = CallGraphAnalysis (modifyStore f) + + getModuleTable = CallGraphAnalysis getModuleTable + modifyModuleTable f = CallGraphAnalysis (modifyModuleTable f) + + askModuleTable = CallGraphAnalysis askModuleTable + localModuleTable f a = CallGraphAnalysis (localModuleTable f (runCallGraphAnalysis a)) instance MonadValue term CallGraphS (CallGraphAnalysis term) where From 5bc38a5ded27acaea074ca255fe6fe793097503c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 17:58:43 -0500 Subject: [PATCH 14/66] Connect call graphs using advanced overlap. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 143 +++++++++++++++++++++-------- 1 file changed, 105 insertions(+), 38 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 1564638f1..a005f3338 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -1,65 +1,132 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.CallGraph where -import Algebra.Graph +import qualified Algebra.Graph as G +import Algebra.Graph.Class import Control.Abstract.Evaluator +import Control.Effect import Control.Monad.Effect.Fail import Control.Monad.Effect.NonDetEff import Control.Monad.Effect.Reader import Control.Monad.Effect.State +import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value +import Data.Proxy +import qualified Data.Syntax.Declaration as Declaration +import Data.Term import Prologue hiding (empty) type CallGraphEffects term = '[ Fail , NonDetEff - , State (StoreFor CallGraphS) - , State (EnvironmentFor CallGraphS) - , Reader (EnvironmentFor CallGraphS) + , State (StoreFor CallGraph) + , State (EnvironmentFor CallGraph) + , Reader (EnvironmentFor CallGraph) , Reader (Linker term) - , State (Linker CallGraphS) + , State (Linker CallGraph) ] -type CallGraph = Graph Name -type CallGraphS = CallGraph -> CallGraph +newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } + deriving (Eq, Graph, Show) -newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraphS a } +instance Ord CallGraph where + compare (CallGraph G.Empty) (CallGraph G.Empty) = EQ + compare (CallGraph G.Empty) _ = LT + compare _ (CallGraph G.Empty) = GT + compare (CallGraph (G.Vertex a)) (CallGraph (G.Vertex b)) = compare a b + compare (CallGraph (G.Vertex _)) _ = LT + compare _ (CallGraph (G.Vertex _)) = GT + compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 + compare (CallGraph (G.Overlay _ _)) _ = LT + compare _ (CallGraph (G.Overlay _ _)) = GT + compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 + + +newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } deriving (Applicative, Functor, Monad, MonadFail) -instance MonadEvaluator term CallGraphS (CallGraphAnalysis term) where - getGlobalEnv = CallGraphAnalysis getGlobalEnv - modifyGlobalEnv f = CallGraphAnalysis (modifyGlobalEnv f) +deriving instance MonadEvaluator term CallGraph (CallGraphAnalysis term) - askLocalEnv = CallGraphAnalysis askLocalEnv - localEnv f a = CallGraphAnalysis (localEnv f (runCallGraphAnalysis a)) +evaluateCallGraph :: forall term + . ( Evaluatable (Base term) + , Foldable (Base term) + , FreeVariables term + , IsDeclaration (Base term) + , MonadAddressable (LocationFor CallGraph) CallGraph (CallGraphAnalysis term) + , MonadValue term CallGraph (CallGraphAnalysis term) + , Ord (LocationFor CallGraph) + , Ord term + , Recursive term + , Semigroup (Cell (LocationFor CallGraph) CallGraph) + ) + => term + -> Final (CallGraphEffects term) CallGraph +evaluateCallGraph = run @(CallGraphEffects term) . runEvaluator . runCallGraphAnalysis . evaluateTerm - lookupWith with name = do - addr <- lookupLocalEnv name - maybe (pure Nothing) connectWith addr - where connectWith addr = do - v <- with addr - pure (Just (connect <*> v)) +instance MonadValue term CallGraph (CallGraphAnalysis term) where + unit = pure empty + integer _ = pure empty + boolean _ = pure empty + string _ = pure empty - getStore = CallGraphAnalysis getStore - modifyStore f = CallGraphAnalysis (modifyStore f) - - getModuleTable = CallGraphAnalysis getModuleTable - modifyModuleTable f = CallGraphAnalysis (modifyModuleTable f) - - askModuleTable = CallGraphAnalysis askModuleTable - localModuleTable f a = CallGraphAnalysis (localModuleTable f (runCallGraphAnalysis a)) - - -instance MonadValue term CallGraphS (CallGraphAnalysis term) where - unit = pure id - integer _ = pure id - boolean _ = pure id - string _ = pure id - - ifthenelse _ then' else' = liftA2 overlay <$> then' <*> else' + ifthenelse _ then' else' = overlay <$> then' <*> else' abstract _ = subtermValue - apply operator arguments = foldr (liftA2 overlay) operator <$> traverse subtermValue arguments + apply operator arguments = foldr overlay operator <$> traverse subtermValue arguments + + +instance ( Evaluatable (Base term) + , FreeVariables term + , IsDeclaration (Base term) + , MonadAddressable (LocationFor CallGraph) CallGraph (CallGraphAnalysis term) + , MonadValue term CallGraph (CallGraphAnalysis term) + , Ord term + , Recursive term + , Semigroup (Cell (LocationFor CallGraph) CallGraph) + ) + => MonadAnalysis term CallGraph (CallGraphAnalysis term) where + evaluateTerm = foldSubterms (\ term -> do + connectDeclaration (subterm <$> term) <$> eval term) + + +class IsDeclaration syntax where + connectDeclaration :: FreeVariables term => syntax term -> CallGraph -> CallGraph + +instance (IsDeclarationStrategy syntax ~ strategy, IsDeclarationWithStrategy strategy syntax) => IsDeclaration syntax where + connectDeclaration graph = connectDeclarationWithStrategy (Proxy :: Proxy strategy) graph + +class CustomIsDeclaration syntax where + customConnectDeclaration :: FreeVariables term => syntax term -> CallGraph -> CallGraph + +instance CustomIsDeclaration Declaration.Function where + customConnectDeclaration Declaration.Function{..} = flip (foldr (connect . vertex)) (freeVariables functionName) + +instance CustomIsDeclaration Declaration.Method where + customConnectDeclaration Declaration.Method{..} = flip (foldr (connect . vertex)) (freeVariables methodName) + +instance Apply IsDeclaration syntaxes => CustomIsDeclaration (Union syntaxes) where + customConnectDeclaration = Prologue.apply (Proxy :: Proxy IsDeclaration) connectDeclaration + +instance IsDeclaration syntax => CustomIsDeclaration (TermF syntax a) where + customConnectDeclaration = connectDeclaration . termFOut + +class IsDeclarationWithStrategy (strategy :: Strategy) syntax where + connectDeclarationWithStrategy :: FreeVariables term => proxy strategy -> syntax term -> CallGraph -> CallGraph + +instance IsDeclarationWithStrategy 'Default syntax where + connectDeclarationWithStrategy _ _ = id + +instance CustomIsDeclaration syntax => IsDeclarationWithStrategy 'Custom syntax where + connectDeclarationWithStrategy _ = customConnectDeclaration + +data Strategy = Default | Custom + +type family IsDeclarationStrategy syntax where + IsDeclarationStrategy Declaration.Function = 'Custom + IsDeclarationStrategy Declaration.Method = 'Custom + IsDeclarationStrategy (Union fs) = 'Custom + IsDeclarationStrategy (TermF f a) = 'Custom + IsDeclarationStrategy a = 'Default From 9d0c26c8cccc9a577ad4c25bee5596d9cdbb934c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 17:59:08 -0500 Subject: [PATCH 15/66] :fire: a redundant do. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index a005f3338..9504a08b4 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -88,7 +88,7 @@ instance ( Evaluatable (Base term) , Semigroup (Cell (LocationFor CallGraph) CallGraph) ) => MonadAnalysis term CallGraph (CallGraphAnalysis term) where - evaluateTerm = foldSubterms (\ term -> do + evaluateTerm = foldSubterms (\ term -> connectDeclaration (subterm <$> term) <$> eval term) From 7eabb0d7874285709a7ea4247f1b1a998fed0432 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 18:24:47 -0500 Subject: [PATCH 16/66] Define LocationFor as an open type family. Co-Authored-By: Patrick Thomson --- src/Data/Abstract/Value.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 9f798baf2..9ade61a76 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -82,9 +82,9 @@ type EnvironmentFor v = Environment (LocationFor v) v type StoreFor v = Store (LocationFor v) v -- | The location type (the body of 'Address'es) which should be used for an abstract value type. -type family LocationFor value :: * where - LocationFor (Value location term) = location - LocationFor Type.Type = Monovariant +type family LocationFor value :: * +type instance LocationFor (Value location term) = location +type instance LocationFor Type.Type = Monovariant -- | Value types, e.g. closures, which can root a set of addresses. From 83198a451cca5331636ab99c1dd8bbcc8c9195a6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 18:24:58 -0500 Subject: [PATCH 17/66] Sort some imports. Co-Authored-By: Patrick Thomson --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8120eb47c..f6105d174 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -8,8 +8,8 @@ import Control.Monad.Effect.Fresh import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.FreeVariables -import Data.Abstract.Value as Value import Data.Abstract.Type as Type +import Data.Abstract.Value as Value import Prologue import Prelude hiding (fail) From a66547bd098b7bebad450f8bd9d2cbfce5490353 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 18:25:13 -0500 Subject: [PATCH 18/66] Define a Monoid instance for CallGraph. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 9504a08b4..2abd1bb6d 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -31,6 +31,10 @@ type CallGraphEffects term newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } deriving (Eq, Graph, Show) +instance Monoid CallGraph where + mempty = empty + mappend = overlay + instance Ord CallGraph where compare (CallGraph G.Empty) (CallGraph G.Empty) = EQ compare (CallGraph G.Empty) _ = LT From d25749acb2650d07cc6a666f780b4a51ad986d84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 18:25:24 -0500 Subject: [PATCH 19/66] Define a LocationFor instance for CallGraph. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 2abd1bb6d..d81d9566f 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -81,6 +81,8 @@ instance MonadValue term CallGraph (CallGraphAnalysis term) where apply operator arguments = foldr overlay operator <$> traverse subtermValue arguments +type instance LocationFor CallGraph = Monovariant + instance ( Evaluatable (Base term) , FreeVariables term From 0c4eeb77b7a43f767790428445d8c06f5a955206 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 18:25:33 -0500 Subject: [PATCH 20/66] Derive an Alternative instance for CallGraphAnalysis. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index d81d9566f..9dcf85041 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -49,7 +49,7 @@ instance Ord CallGraph where newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } - deriving (Applicative, Functor, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Monad, MonadFail) deriving instance MonadEvaluator term CallGraph (CallGraphAnalysis term) From 04737c584f0b52c8262f5816ccd8090674a9b559 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 18:25:47 -0500 Subject: [PATCH 21/66] Define a CallGraph -> DOT renderer. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 9dcf85041..cd0128fb5 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -3,6 +3,7 @@ module Analysis.Abstract.CallGraph where import qualified Algebra.Graph as G import Algebra.Graph.Class +import Algebra.Graph.Export.Dot import Control.Abstract.Evaluator import Control.Effect import Control.Monad.Effect.Fail @@ -35,6 +36,9 @@ instance Monoid CallGraph where mempty = empty mappend = overlay +renderCallGraph :: CallGraph -> ByteString +renderCallGraph = export (defaultStyle id) . unCallGraph + instance Ord CallGraph where compare (CallGraph G.Empty) (CallGraph G.Empty) = EQ compare (CallGraph G.Empty) _ = LT From 2dc957eb0ef24bea0a441b77533d7f21a084cc0b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 18:25:57 -0500 Subject: [PATCH 22/66] Define an entry point evaluating Python to a call graph. Co-Authored-By: Patrick Thomson --- src/Semantic/Util.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index aae481164..07c2e10b9 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -3,6 +3,7 @@ module Semantic.Util where import Prologue +import Analysis.Abstract.CallGraph import Analysis.Abstract.Evaluating import Analysis.Declaration import Control.Monad.IO.Class @@ -42,6 +43,8 @@ evaluateRubyFiles paths = do -- Python +evaluatePythonCallGraph path = evaluateCallGraph <$> (file path >>= runTask . parse pythonParser) + evaluatePythonFile path = evaluate @PythonValue <$> (file path >>= runTask . parse pythonParser) From 00c190a985d0a73f5f87857a948fb475361c95ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 09:51:09 -0500 Subject: [PATCH 23/66] Move the CallGraph instances down. --- src/Analysis/Abstract/CallGraph.hs | 33 +++++++++++++++--------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index cd0128fb5..f78f5e914 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -32,25 +32,9 @@ type CallGraphEffects term newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } deriving (Eq, Graph, Show) -instance Monoid CallGraph where - mempty = empty - mappend = overlay - renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph -instance Ord CallGraph where - compare (CallGraph G.Empty) (CallGraph G.Empty) = EQ - compare (CallGraph G.Empty) _ = LT - compare _ (CallGraph G.Empty) = GT - compare (CallGraph (G.Vertex a)) (CallGraph (G.Vertex b)) = compare a b - compare (CallGraph (G.Vertex _)) _ = LT - compare _ (CallGraph (G.Vertex _)) = GT - compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 - compare (CallGraph (G.Overlay _ _)) _ = LT - compare _ (CallGraph (G.Overlay _ _)) = GT - compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 - newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } deriving (Alternative, Applicative, Functor, Monad, MonadFail) @@ -140,3 +124,20 @@ type family IsDeclarationStrategy syntax where IsDeclarationStrategy (Union fs) = 'Custom IsDeclarationStrategy (TermF f a) = 'Custom IsDeclarationStrategy a = 'Default + + +instance Monoid CallGraph where + mempty = empty + mappend = overlay + +instance Ord CallGraph where + compare (CallGraph G.Empty) (CallGraph G.Empty) = EQ + compare (CallGraph G.Empty) _ = LT + compare _ (CallGraph G.Empty) = GT + compare (CallGraph (G.Vertex a)) (CallGraph (G.Vertex b)) = compare a b + compare (CallGraph (G.Vertex _)) _ = LT + compare _ (CallGraph (G.Vertex _)) = GT + compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 + compare (CallGraph (G.Overlay _ _)) _ = LT + compare _ (CallGraph (G.Overlay _ _)) = GT + compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 From f6188206d24a8556cd6dfe940af5ab32b2a75cc6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 10:59:35 -0500 Subject: [PATCH 24/66] Generate vertices for variable references. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index f78f5e914..b7f6b840a 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -39,7 +39,23 @@ renderCallGraph = export (defaultStyle id) . unCallGraph newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } deriving (Alternative, Applicative, Functor, Monad, MonadFail) -deriving instance MonadEvaluator term CallGraph (CallGraphAnalysis term) +instance MonadEvaluator term CallGraph (CallGraphAnalysis term) where + getGlobalEnv = CallGraphAnalysis getGlobalEnv + modifyGlobalEnv f = CallGraphAnalysis (modifyGlobalEnv f) + + askLocalEnv = CallGraphAnalysis askLocalEnv + localEnv f a = CallGraphAnalysis (localEnv f (runCallGraphAnalysis a)) + + lookupWith with name = fmap (overlay (vertex name)) <$> CallGraphAnalysis (lookupWith (runCallGraphAnalysis . with) name) + + getStore = CallGraphAnalysis getStore + modifyStore f = CallGraphAnalysis (modifyStore f) + + getModuleTable = CallGraphAnalysis getModuleTable + modifyModuleTable f = CallGraphAnalysis (modifyModuleTable f) + + askModuleTable = CallGraphAnalysis askModuleTable + localModuleTable f a = CallGraphAnalysis (localModuleTable f (runCallGraphAnalysis a)) evaluateCallGraph :: forall term . ( Evaluatable (Base term) From 1f62a782a93482d0c379fdfb1a230a876f7fb682 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 11:12:38 -0500 Subject: [PATCH 25/66] Define a helper for building a graph from the bindings in the Store. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index b7f6b840a..dc85e78a5 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -13,8 +13,11 @@ import Control.Monad.Effect.State import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Linker +import Data.Abstract.Store import Data.Abstract.Value +import qualified Data.Map as Map import Data.Proxy +import qualified Data.Set as Set import qualified Data.Syntax.Declaration as Declaration import Data.Term import Prologue hiding (empty) @@ -36,6 +39,11 @@ renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph +buildStoreGraph :: StoreFor CallGraph -> CallGraph +buildStoreGraph = foldMap (uncurry connectBinding) . Map.toList . unStore + where connectBinding (Monovariant name) body = foldMap (connect (vertex name)) (Set.toList body) + + newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } deriving (Alternative, Applicative, Functor, Monad, MonadFail) From 1710e67e38f6c5acf5770b2a30d69183312d8be2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 12:09:50 -0500 Subject: [PATCH 26/66] Add an effect to hold the call graph. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index dc85e78a5..67e7c3a80 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -25,6 +25,7 @@ import Prologue hiding (empty) type CallGraphEffects term = '[ Fail , NonDetEff + , State CallGraph , State (StoreFor CallGraph) , State (EnvironmentFor CallGraph) , Reader (EnvironmentFor CallGraph) @@ -44,6 +45,13 @@ buildStoreGraph = foldMap (uncurry connectBinding) . Map.toList . unStore where connectBinding (Monovariant name) body = foldMap (connect (vertex name)) (Set.toList body) +getCallGraph :: CallGraphAnalysis term CallGraph +getCallGraph = CallGraphAnalysis (Evaluator get) + +modifyCallGraph :: (CallGraph -> CallGraph) -> CallGraphAnalysis term () +modifyCallGraph f = CallGraphAnalysis (Evaluator (modify f)) + + newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } deriving (Alternative, Applicative, Functor, Monad, MonadFail) From d6e7429b2228d28f40cf8dfb40d4d76f7d558f15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 12:12:28 -0500 Subject: [PATCH 27/66] Revert "Define a helper for building a graph from the bindings in the Store." This reverts commit e89526ca64702f09bcb8c79b949b257643e9c6dc. Co-Authored-By: Patrick Thomson --- src/Analysis/Abstract/CallGraph.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 67e7c3a80..a98f91a0c 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -13,11 +13,8 @@ import Control.Monad.Effect.State import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Linker -import Data.Abstract.Store import Data.Abstract.Value -import qualified Data.Map as Map import Data.Proxy -import qualified Data.Set as Set import qualified Data.Syntax.Declaration as Declaration import Data.Term import Prologue hiding (empty) @@ -40,11 +37,6 @@ renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph -buildStoreGraph :: StoreFor CallGraph -> CallGraph -buildStoreGraph = foldMap (uncurry connectBinding) . Map.toList . unStore - where connectBinding (Monovariant name) body = foldMap (connect (vertex name)) (Set.toList body) - - getCallGraph :: CallGraphAnalysis term CallGraph getCallGraph = CallGraphAnalysis (Evaluator get) From 5752d79e6a2250cfc5ea0c08a0177067523d54a5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 15:19:52 -0500 Subject: [PATCH 28/66] Bind variables locally. --- src/Analysis/Abstract/CallGraph.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index a98f91a0c..742c3ea12 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -11,6 +11,7 @@ import Control.Monad.Effect.NonDetEff import Control.Monad.Effect.Reader import Control.Monad.Effect.State import Data.Abstract.Address +import Data.Abstract.Environment import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value @@ -89,7 +90,11 @@ instance MonadValue term CallGraph (CallGraphAnalysis term) where ifthenelse _ then' else' = overlay <$> then' <*> else' - abstract _ = subtermValue + abstract names body = foldr bindLocally (subtermValue body) names + where bindLocally name rest = do + addr <- alloc name + assign addr empty + localEnv (envInsert name addr) rest apply operator arguments = foldr overlay operator <$> traverse subtermValue arguments From 420b5a5828a79b1af770a654af00583e263da4c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 15:26:21 -0500 Subject: [PATCH 29/66] Extend the local environment instead of replacing it. --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 8ab2a6103..0254d26d2 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -72,7 +72,7 @@ instance Evaluatable [] where -- Finally, evaluate the rest of the terms, but do so by calculating a new -- environment each time where the free variables in those terms are bound -- to the global environment. - localEnv (const (bindEnv (liftFreeVariables (freeVariables . subterm) xs) env)) (eval xs) + localEnv (mappend (bindEnv (liftFreeVariables (freeVariables . subterm) xs) env)) (eval xs) -- | Require/import another term/file and return an Effect. From 82fa75dfdda1fd7f799f7c09922882a18eaffc8c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 15:26:40 -0500 Subject: [PATCH 30/66] Simplify envRoots using foldMap. :tophat: @patrickt for the observation that led to this. --- src/Data/Abstract/Environment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 483f9fae6..99d9cfa87 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -31,7 +31,7 @@ bindEnv names env = Environment (Map.fromList pairs) -- -- Unbound names are silently dropped. envRoots :: (Ord l, Foldable t) => Environment l a -> t Name -> Live l a -envRoots env = foldr ((<>) . maybe mempty liveSingleton . flip envLookup env) mempty +envRoots env = foldMap (maybe mempty liveSingleton . flip envLookup env) envAll :: (Ord l) => Environment l a -> Live l a envAll (Environment env) = Live $ Set.fromList (Map.elems env) From 8c966c7a982916699a19dfdb0eb77312ecf737e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 16:24:06 -0500 Subject: [PATCH 31/66] Go back to deriving MonadEvaluator. --- src/Analysis/Abstract/CallGraph.hs | 18 +----------------- 1 file changed, 1 insertion(+), 17 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 742c3ea12..d49565f59 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -48,23 +48,7 @@ modifyCallGraph f = CallGraphAnalysis (Evaluator (modify f)) newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } deriving (Alternative, Applicative, Functor, Monad, MonadFail) -instance MonadEvaluator term CallGraph (CallGraphAnalysis term) where - getGlobalEnv = CallGraphAnalysis getGlobalEnv - modifyGlobalEnv f = CallGraphAnalysis (modifyGlobalEnv f) - - askLocalEnv = CallGraphAnalysis askLocalEnv - localEnv f a = CallGraphAnalysis (localEnv f (runCallGraphAnalysis a)) - - lookupWith with name = fmap (overlay (vertex name)) <$> CallGraphAnalysis (lookupWith (runCallGraphAnalysis . with) name) - - getStore = CallGraphAnalysis getStore - modifyStore f = CallGraphAnalysis (modifyStore f) - - getModuleTable = CallGraphAnalysis getModuleTable - modifyModuleTable f = CallGraphAnalysis (modifyModuleTable f) - - askModuleTable = CallGraphAnalysis askModuleTable - localModuleTable f a = CallGraphAnalysis (localModuleTable f (runCallGraphAnalysis a)) +deriving instance MonadEvaluator term CallGraph (CallGraphAnalysis term) evaluateCallGraph :: forall term . ( Evaluatable (Base term) From 9fc5ad1dba7d5f4ef71bcfa4aa72c302e9eb73a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 16:25:44 -0500 Subject: [PATCH 32/66] Define a CustomIsDeclaration instance for identifiers. --- src/Analysis/Abstract/CallGraph.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index d49565f59..ac5858ac0 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -16,6 +16,7 @@ import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value import Data.Proxy +import qualified Data.Syntax as Syntax import qualified Data.Syntax.Declaration as Declaration import Data.Term import Prologue hiding (empty) @@ -114,6 +115,9 @@ instance CustomIsDeclaration Declaration.Function where instance CustomIsDeclaration Declaration.Method where customConnectDeclaration Declaration.Method{..} = flip (foldr (connect . vertex)) (freeVariables methodName) +instance CustomIsDeclaration Syntax.Identifier where + customConnectDeclaration (Syntax.Identifier name) = overlay (vertex name) + instance Apply IsDeclaration syntaxes => CustomIsDeclaration (Union syntaxes) where customConnectDeclaration = Prologue.apply (Proxy :: Proxy IsDeclaration) connectDeclaration @@ -134,6 +138,7 @@ data Strategy = Default | Custom type family IsDeclarationStrategy syntax where IsDeclarationStrategy Declaration.Function = 'Custom IsDeclarationStrategy Declaration.Method = 'Custom + IsDeclarationStrategy Syntax.Identifier = 'Custom IsDeclarationStrategy (Union fs) = 'Custom IsDeclarationStrategy (TermF f a) = 'Custom IsDeclarationStrategy a = 'Default From c73115e939c6a1bccce77f1ef50f76120f87d31f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Mar 2018 17:05:22 -0500 Subject: [PATCH 33/66] Build static call graphs with a paramorphism. --- src/Analysis/Abstract/CallGraph.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index ac5858ac0..356f0ffa5 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -39,6 +39,10 @@ renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph +buildCallGraph :: (IsDeclaration syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> CallGraph +buildCallGraph = para (\ (In _ syntax) -> connectDeclaration (fst <$> syntax) (foldMap snd syntax)) + + getCallGraph :: CallGraphAnalysis term CallGraph getCallGraph = CallGraphAnalysis (Evaluator get) From 732b3fb5bcd9e9a5f11bc5159019dab618c43c9c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:16:40 -0500 Subject: [PATCH 34/66] Just evaluate terms. --- src/Analysis/Abstract/CallGraph.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 356f0ffa5..862d3ee02 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -100,8 +100,7 @@ instance ( Evaluatable (Base term) , Semigroup (Cell (LocationFor CallGraph) CallGraph) ) => MonadAnalysis term CallGraph (CallGraphAnalysis term) where - evaluateTerm = foldSubterms (\ term -> - connectDeclaration (subterm <$> term) <$> eval term) + evaluateTerm = foldSubterms eval class IsDeclaration syntax where From ec2e3b51dff6373731c613043ec6a1f5251334aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:17:27 -0500 Subject: [PATCH 35/66] Phrase the typeclasses as a subterm algebra. --- src/Analysis/Abstract/CallGraph.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index 862d3ee02..b1a287e94 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -40,7 +40,7 @@ renderCallGraph = export (defaultStyle id) . unCallGraph buildCallGraph :: (IsDeclaration syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> CallGraph -buildCallGraph = para (\ (In _ syntax) -> connectDeclaration (fst <$> syntax) (foldMap snd syntax)) +buildCallGraph = foldSubterms buildCallGraphAlgebra getCallGraph :: CallGraphAnalysis term CallGraph @@ -104,37 +104,37 @@ instance ( Evaluatable (Base term) class IsDeclaration syntax where - connectDeclaration :: FreeVariables term => syntax term -> CallGraph -> CallGraph + buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term CallGraph) -> CallGraph instance (IsDeclarationStrategy syntax ~ strategy, IsDeclarationWithStrategy strategy syntax) => IsDeclaration syntax where - connectDeclaration graph = connectDeclarationWithStrategy (Proxy :: Proxy strategy) graph + buildCallGraphAlgebra = buildCallGraphAlgebraWithStrategy (Proxy :: Proxy strategy) class CustomIsDeclaration syntax where - customConnectDeclaration :: FreeVariables term => syntax term -> CallGraph -> CallGraph + customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term CallGraph) -> CallGraph instance CustomIsDeclaration Declaration.Function where - customConnectDeclaration Declaration.Function{..} = flip (foldr (connect . vertex)) (freeVariables functionName) + customBuildCallGraphAlgebra Declaration.Function{..} = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody instance CustomIsDeclaration Declaration.Method where - customConnectDeclaration Declaration.Method{..} = flip (foldr (connect . vertex)) (freeVariables methodName) + customBuildCallGraphAlgebra Declaration.Method{..} = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody instance CustomIsDeclaration Syntax.Identifier where - customConnectDeclaration (Syntax.Identifier name) = overlay (vertex name) + customBuildCallGraphAlgebra (Syntax.Identifier name) = vertex name instance Apply IsDeclaration syntaxes => CustomIsDeclaration (Union syntaxes) where - customConnectDeclaration = Prologue.apply (Proxy :: Proxy IsDeclaration) connectDeclaration + customBuildCallGraphAlgebra = Prologue.apply (Proxy :: Proxy IsDeclaration) buildCallGraphAlgebra instance IsDeclaration syntax => CustomIsDeclaration (TermF syntax a) where - customConnectDeclaration = connectDeclaration . termFOut + customBuildCallGraphAlgebra = buildCallGraphAlgebra . termFOut class IsDeclarationWithStrategy (strategy :: Strategy) syntax where - connectDeclarationWithStrategy :: FreeVariables term => proxy strategy -> syntax term -> CallGraph -> CallGraph + buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term CallGraph) -> CallGraph -instance IsDeclarationWithStrategy 'Default syntax where - connectDeclarationWithStrategy _ _ = id +instance Foldable syntax => IsDeclarationWithStrategy 'Default syntax where + buildCallGraphAlgebraWithStrategy _ = foldMap subtermValue instance CustomIsDeclaration syntax => IsDeclarationWithStrategy 'Custom syntax where - connectDeclarationWithStrategy _ = customConnectDeclaration + buildCallGraphAlgebraWithStrategy _ = customBuildCallGraphAlgebra data Strategy = Default | Custom From 870a4d0d24aa649812cbc209081ce667e375556d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:27:21 -0500 Subject: [PATCH 36/66] Take a set of bound variables when building call graphs. --- src/Analysis/Abstract/CallGraph.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index b1a287e94..f83634083 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -16,6 +16,7 @@ import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value import Data.Proxy +import Data.Set (member) import qualified Data.Syntax as Syntax import qualified Data.Syntax.Declaration as Declaration import Data.Term @@ -39,7 +40,7 @@ renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph -buildCallGraph :: (IsDeclaration syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> CallGraph +buildCallGraph :: (IsDeclaration syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph buildCallGraph = foldSubterms buildCallGraphAlgebra @@ -104,13 +105,13 @@ instance ( Evaluatable (Base term) class IsDeclaration syntax where - buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term CallGraph) -> CallGraph + buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph instance (IsDeclarationStrategy syntax ~ strategy, IsDeclarationWithStrategy strategy syntax) => IsDeclaration syntax where buildCallGraphAlgebra = buildCallGraphAlgebraWithStrategy (Proxy :: Proxy strategy) class CustomIsDeclaration syntax where - customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term CallGraph) -> CallGraph + customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph instance CustomIsDeclaration Declaration.Function where customBuildCallGraphAlgebra Declaration.Function{..} = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody @@ -128,7 +129,7 @@ instance IsDeclaration syntax => CustomIsDeclaration (TermF syntax a) where customBuildCallGraphAlgebra = buildCallGraphAlgebra . termFOut class IsDeclarationWithStrategy (strategy :: Strategy) syntax where - buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term CallGraph) -> CallGraph + buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph instance Foldable syntax => IsDeclarationWithStrategy 'Default syntax where buildCallGraphAlgebraWithStrategy _ = foldMap subtermValue From 0559c79bff6e94f38162ecd8bb38560b9d782294 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:28:45 -0500 Subject: [PATCH 37/66] =?UTF-8?q?Don=E2=80=99t=20generate=20vertices=20for?= =?UTF-8?q?=20bound=20identifiers.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/CallGraph.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index f83634083..b19a2292f 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -120,7 +120,9 @@ instance CustomIsDeclaration Declaration.Method where customBuildCallGraphAlgebra Declaration.Method{..} = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody instance CustomIsDeclaration Syntax.Identifier where - customBuildCallGraphAlgebra (Syntax.Identifier name) = vertex name + customBuildCallGraphAlgebra (Syntax.Identifier name) bound + | name `member` bound = empty + | otherwise = vertex name instance Apply IsDeclaration syntaxes => CustomIsDeclaration (Union syntaxes) where customBuildCallGraphAlgebra = Prologue.apply (Proxy :: Proxy IsDeclaration) buildCallGraphAlgebra From b0572124a1d442a6eb1e62aae2be2edcded2b239 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:29:47 -0500 Subject: [PATCH 38/66] Extend the set of bound variables for function and method bodies. --- src/Analysis/Abstract/CallGraph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index b19a2292f..e377c5580 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -114,10 +114,10 @@ class CustomIsDeclaration syntax where customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph instance CustomIsDeclaration Declaration.Function where - customBuildCallGraphAlgebra Declaration.Function{..} = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody + customBuildCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) instance CustomIsDeclaration Declaration.Method where - customBuildCallGraphAlgebra Declaration.Method{..} = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody + customBuildCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) instance CustomIsDeclaration Syntax.Identifier where customBuildCallGraphAlgebra (Syntax.Identifier name) bound From 91d502b55367f95d7658b488bcc2ff7a605d2a50 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:36:02 -0500 Subject: [PATCH 39/66] Stub in a module for a non-abstract call graph analysis. --- semantic.cabal | 1 + src/Analysis/CallGraph.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Analysis/CallGraph.hs diff --git a/semantic.cabal b/semantic.cabal index 159a5f483..27c8b8cf9 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -21,6 +21,7 @@ library , Analysis.Abstract.Dead , Analysis.Abstract.Evaluating -- , Analysis.Abstract.Tracing + , Analysis.CallGraph , Analysis.ConstructorName , Analysis.CyclomaticComplexity , Analysis.Decorator diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs new file mode 100644 index 000000000..e3512bdb5 --- /dev/null +++ b/src/Analysis/CallGraph.hs @@ -0,0 +1 @@ +module Analysis.CallGraph where From 533a349ea976cfce6d6d5e0e6e05e6c1fa5e29ec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:47:10 -0500 Subject: [PATCH 40/66] Move CallGraph &c into the new module. --- src/Analysis/Abstract/CallGraph.hs | 82 +---------------------------- src/Analysis/CallGraph.hs | 84 ++++++++++++++++++++++++++++++ 2 files changed, 85 insertions(+), 81 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index e377c5580..c71d5cde0 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -1,9 +1,8 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.CallGraph where -import qualified Algebra.Graph as G import Algebra.Graph.Class -import Algebra.Graph.Export.Dot +import Analysis.CallGraph import Control.Abstract.Evaluator import Control.Effect import Control.Monad.Effect.Fail @@ -15,11 +14,6 @@ import Data.Abstract.Environment import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value -import Data.Proxy -import Data.Set (member) -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Declaration as Declaration -import Data.Term import Prologue hiding (empty) type CallGraphEffects term @@ -33,17 +27,6 @@ type CallGraphEffects term , State (Linker CallGraph) ] -newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } - deriving (Eq, Graph, Show) - -renderCallGraph :: CallGraph -> ByteString -renderCallGraph = export (defaultStyle id) . unCallGraph - - -buildCallGraph :: (IsDeclaration syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph -buildCallGraph = foldSubterms buildCallGraphAlgebra - - getCallGraph :: CallGraphAnalysis term CallGraph getCallGraph = CallGraphAnalysis (Evaluator get) @@ -102,66 +85,3 @@ instance ( Evaluatable (Base term) ) => MonadAnalysis term CallGraph (CallGraphAnalysis term) where evaluateTerm = foldSubterms eval - - -class IsDeclaration syntax where - buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph - -instance (IsDeclarationStrategy syntax ~ strategy, IsDeclarationWithStrategy strategy syntax) => IsDeclaration syntax where - buildCallGraphAlgebra = buildCallGraphAlgebraWithStrategy (Proxy :: Proxy strategy) - -class CustomIsDeclaration syntax where - customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph - -instance CustomIsDeclaration Declaration.Function where - customBuildCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) - -instance CustomIsDeclaration Declaration.Method where - customBuildCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) - -instance CustomIsDeclaration Syntax.Identifier where - customBuildCallGraphAlgebra (Syntax.Identifier name) bound - | name `member` bound = empty - | otherwise = vertex name - -instance Apply IsDeclaration syntaxes => CustomIsDeclaration (Union syntaxes) where - customBuildCallGraphAlgebra = Prologue.apply (Proxy :: Proxy IsDeclaration) buildCallGraphAlgebra - -instance IsDeclaration syntax => CustomIsDeclaration (TermF syntax a) where - customBuildCallGraphAlgebra = buildCallGraphAlgebra . termFOut - -class IsDeclarationWithStrategy (strategy :: Strategy) syntax where - buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph - -instance Foldable syntax => IsDeclarationWithStrategy 'Default syntax where - buildCallGraphAlgebraWithStrategy _ = foldMap subtermValue - -instance CustomIsDeclaration syntax => IsDeclarationWithStrategy 'Custom syntax where - buildCallGraphAlgebraWithStrategy _ = customBuildCallGraphAlgebra - -data Strategy = Default | Custom - -type family IsDeclarationStrategy syntax where - IsDeclarationStrategy Declaration.Function = 'Custom - IsDeclarationStrategy Declaration.Method = 'Custom - IsDeclarationStrategy Syntax.Identifier = 'Custom - IsDeclarationStrategy (Union fs) = 'Custom - IsDeclarationStrategy (TermF f a) = 'Custom - IsDeclarationStrategy a = 'Default - - -instance Monoid CallGraph where - mempty = empty - mappend = overlay - -instance Ord CallGraph where - compare (CallGraph G.Empty) (CallGraph G.Empty) = EQ - compare (CallGraph G.Empty) _ = LT - compare _ (CallGraph G.Empty) = GT - compare (CallGraph (G.Vertex a)) (CallGraph (G.Vertex b)) = compare a b - compare (CallGraph (G.Vertex _)) _ = LT - compare _ (CallGraph (G.Vertex _)) = GT - compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 - compare (CallGraph (G.Overlay _ _)) _ = LT - compare _ (CallGraph (G.Overlay _ _)) = GT - compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index e3512bdb5..4b7ad7276 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -1 +1,85 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Analysis.CallGraph where + +import qualified Algebra.Graph as G +import Algebra.Graph.Class +import Algebra.Graph.Export.Dot +import Data.Abstract.FreeVariables +import Data.Set (member) +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Declaration as Declaration +import Data.Term +import Prologue hiding (empty) + +newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } + deriving (Eq, Graph, Show) + +renderCallGraph :: CallGraph -> ByteString +renderCallGraph = export (defaultStyle id) . unCallGraph + + +buildCallGraph :: (IsDeclaration syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph +buildCallGraph = foldSubterms buildCallGraphAlgebra + + +class IsDeclaration syntax where + buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph + +instance (IsDeclarationStrategy syntax ~ strategy, IsDeclarationWithStrategy strategy syntax) => IsDeclaration syntax where + buildCallGraphAlgebra = buildCallGraphAlgebraWithStrategy (Proxy :: Proxy strategy) + +class CustomIsDeclaration syntax where + customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph + +instance CustomIsDeclaration Declaration.Function where + customBuildCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) + +instance CustomIsDeclaration Declaration.Method where + customBuildCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) + +instance CustomIsDeclaration Syntax.Identifier where + customBuildCallGraphAlgebra (Syntax.Identifier name) bound + | name `member` bound = empty + | otherwise = vertex name + +instance Apply IsDeclaration syntaxes => CustomIsDeclaration (Union syntaxes) where + customBuildCallGraphAlgebra = Prologue.apply (Proxy :: Proxy IsDeclaration) buildCallGraphAlgebra + +instance IsDeclaration syntax => CustomIsDeclaration (TermF syntax a) where + customBuildCallGraphAlgebra = buildCallGraphAlgebra . termFOut + +class IsDeclarationWithStrategy (strategy :: Strategy) syntax where + buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph + +instance Foldable syntax => IsDeclarationWithStrategy 'Default syntax where + buildCallGraphAlgebraWithStrategy _ = foldMap subtermValue + +instance CustomIsDeclaration syntax => IsDeclarationWithStrategy 'Custom syntax where + buildCallGraphAlgebraWithStrategy _ = customBuildCallGraphAlgebra + +data Strategy = Default | Custom + +type family IsDeclarationStrategy syntax where + IsDeclarationStrategy Declaration.Function = 'Custom + IsDeclarationStrategy Declaration.Method = 'Custom + IsDeclarationStrategy Syntax.Identifier = 'Custom + IsDeclarationStrategy (Union fs) = 'Custom + IsDeclarationStrategy (TermF f a) = 'Custom + IsDeclarationStrategy a = 'Default + + +instance Monoid CallGraph where + mempty = empty + mappend = overlay + +instance Ord CallGraph where + compare (CallGraph G.Empty) (CallGraph G.Empty) = EQ + compare (CallGraph G.Empty) _ = LT + compare _ (CallGraph G.Empty) = GT + compare (CallGraph (G.Vertex a)) (CallGraph (G.Vertex b)) = compare a b + compare (CallGraph (G.Vertex _)) _ = LT + compare _ (CallGraph (G.Vertex _)) = GT + compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 + compare (CallGraph (G.Overlay _ _)) _ = LT + compare _ (CallGraph (G.Overlay _ _)) = GT + compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2 From c257de792edc73c071cec7f00e19bf83fc7699ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:49:13 -0500 Subject: [PATCH 41/66] Explicitly list the exports. --- src/Analysis/CallGraph.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 4b7ad7276..774e5e933 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -1,5 +1,10 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -module Analysis.CallGraph where +module Analysis.CallGraph +( CallGraph(..) +, renderCallGraph +, buildCallGraph +, IsDeclaration(..) +) where import qualified Algebra.Graph as G import Algebra.Graph.Class From 0d5371a2d50daab5e6451378fb4f2349a63c46d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:49:58 -0500 Subject: [PATCH 42/66] Rename all the advanced overlap machinery. --- src/Analysis/Abstract/CallGraph.hs | 4 +-- src/Analysis/CallGraph.hs | 42 +++++++++++++++--------------- 2 files changed, 23 insertions(+), 23 deletions(-) diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs index c71d5cde0..6295a5d62 100644 --- a/src/Analysis/Abstract/CallGraph.hs +++ b/src/Analysis/Abstract/CallGraph.hs @@ -43,7 +43,7 @@ evaluateCallGraph :: forall term . ( Evaluatable (Base term) , Foldable (Base term) , FreeVariables term - , IsDeclaration (Base term) + , BuildCallGraphAlgebra (Base term) , MonadAddressable (LocationFor CallGraph) CallGraph (CallGraphAnalysis term) , MonadValue term CallGraph (CallGraphAnalysis term) , Ord (LocationFor CallGraph) @@ -76,7 +76,7 @@ type instance LocationFor CallGraph = Monovariant instance ( Evaluatable (Base term) , FreeVariables term - , IsDeclaration (Base term) + , BuildCallGraphAlgebra (Base term) , MonadAddressable (LocationFor CallGraph) CallGraph (CallGraphAnalysis term) , MonadValue term CallGraph (CallGraphAnalysis term) , Ord term diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 774e5e933..f4c41446a 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -3,7 +3,7 @@ module Analysis.CallGraph ( CallGraph(..) , renderCallGraph , buildCallGraph -, IsDeclaration(..) +, BuildCallGraphAlgebra(..) ) where import qualified Algebra.Graph as G @@ -23,54 +23,54 @@ renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph -buildCallGraph :: (IsDeclaration syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph +buildCallGraph :: (BuildCallGraphAlgebra syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph buildCallGraph = foldSubterms buildCallGraphAlgebra -class IsDeclaration syntax where +class BuildCallGraphAlgebra syntax where buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph -instance (IsDeclarationStrategy syntax ~ strategy, IsDeclarationWithStrategy strategy syntax) => IsDeclaration syntax where +instance (BuildCallGraphAlgebraStrategy syntax ~ strategy, BuildCallGraphAlgebraWithStrategy strategy syntax) => BuildCallGraphAlgebra syntax where buildCallGraphAlgebra = buildCallGraphAlgebraWithStrategy (Proxy :: Proxy strategy) -class CustomIsDeclaration syntax where +class CustomBuildCallGraphAlgebra syntax where customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph -instance CustomIsDeclaration Declaration.Function where +instance CustomBuildCallGraphAlgebra Declaration.Function where customBuildCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) -instance CustomIsDeclaration Declaration.Method where +instance CustomBuildCallGraphAlgebra Declaration.Method where customBuildCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) -instance CustomIsDeclaration Syntax.Identifier where +instance CustomBuildCallGraphAlgebra Syntax.Identifier where customBuildCallGraphAlgebra (Syntax.Identifier name) bound | name `member` bound = empty | otherwise = vertex name -instance Apply IsDeclaration syntaxes => CustomIsDeclaration (Union syntaxes) where - customBuildCallGraphAlgebra = Prologue.apply (Proxy :: Proxy IsDeclaration) buildCallGraphAlgebra +instance Apply BuildCallGraphAlgebra syntaxes => CustomBuildCallGraphAlgebra (Union syntaxes) where + customBuildCallGraphAlgebra = Prologue.apply (Proxy :: Proxy BuildCallGraphAlgebra) buildCallGraphAlgebra -instance IsDeclaration syntax => CustomIsDeclaration (TermF syntax a) where +instance BuildCallGraphAlgebra syntax => CustomBuildCallGraphAlgebra (TermF syntax a) where customBuildCallGraphAlgebra = buildCallGraphAlgebra . termFOut -class IsDeclarationWithStrategy (strategy :: Strategy) syntax where +class BuildCallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph -instance Foldable syntax => IsDeclarationWithStrategy 'Default syntax where +instance Foldable syntax => BuildCallGraphAlgebraWithStrategy 'Default syntax where buildCallGraphAlgebraWithStrategy _ = foldMap subtermValue -instance CustomIsDeclaration syntax => IsDeclarationWithStrategy 'Custom syntax where +instance CustomBuildCallGraphAlgebra syntax => BuildCallGraphAlgebraWithStrategy 'Custom syntax where buildCallGraphAlgebraWithStrategy _ = customBuildCallGraphAlgebra data Strategy = Default | Custom -type family IsDeclarationStrategy syntax where - IsDeclarationStrategy Declaration.Function = 'Custom - IsDeclarationStrategy Declaration.Method = 'Custom - IsDeclarationStrategy Syntax.Identifier = 'Custom - IsDeclarationStrategy (Union fs) = 'Custom - IsDeclarationStrategy (TermF f a) = 'Custom - IsDeclarationStrategy a = 'Default +type family BuildCallGraphAlgebraStrategy syntax where + BuildCallGraphAlgebraStrategy Declaration.Function = 'Custom + BuildCallGraphAlgebraStrategy Declaration.Method = 'Custom + BuildCallGraphAlgebraStrategy Syntax.Identifier = 'Custom + BuildCallGraphAlgebraStrategy (Union fs) = 'Custom + BuildCallGraphAlgebraStrategy (TermF f a) = 'Custom + BuildCallGraphAlgebraStrategy a = 'Default instance Monoid CallGraph where From 5e579df53fc521d1dd24db61980ab7fc7687bf27 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 10:53:57 -0500 Subject: [PATCH 43/66] :fire: Analysis.Abstract.CallGraph. --- semantic.cabal | 3 +- src/Analysis/Abstract/CallGraph.hs | 87 ------------------------------ src/Semantic/Util.hs | 3 -- 3 files changed, 1 insertion(+), 92 deletions(-) delete mode 100644 src/Analysis/Abstract/CallGraph.hs diff --git a/semantic.cabal b/semantic.cabal index 27c8b8cf9..2c7807aed 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -16,9 +16,8 @@ library exposed-modules: -- Analyses & term annotations -- Analysis.Abstract.Caching - Analysis.Abstract.CallGraph -- , Analysis.Abstract.Collecting - , Analysis.Abstract.Dead + Analysis.Abstract.Dead , Analysis.Abstract.Evaluating -- , Analysis.Abstract.Tracing , Analysis.CallGraph diff --git a/src/Analysis/Abstract/CallGraph.hs b/src/Analysis/Abstract/CallGraph.hs deleted file mode 100644 index 6295a5d62..000000000 --- a/src/Analysis/Abstract/CallGraph.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, UndecidableInstances #-} -module Analysis.Abstract.CallGraph where - -import Algebra.Graph.Class -import Analysis.CallGraph -import Control.Abstract.Evaluator -import Control.Effect -import Control.Monad.Effect.Fail -import Control.Monad.Effect.NonDetEff -import Control.Monad.Effect.Reader -import Control.Monad.Effect.State -import Data.Abstract.Address -import Data.Abstract.Environment -import Data.Abstract.Evaluatable -import Data.Abstract.Linker -import Data.Abstract.Value -import Prologue hiding (empty) - -type CallGraphEffects term - = '[ Fail - , NonDetEff - , State CallGraph - , State (StoreFor CallGraph) - , State (EnvironmentFor CallGraph) - , Reader (EnvironmentFor CallGraph) - , Reader (Linker term) - , State (Linker CallGraph) - ] - -getCallGraph :: CallGraphAnalysis term CallGraph -getCallGraph = CallGraphAnalysis (Evaluator get) - -modifyCallGraph :: (CallGraph -> CallGraph) -> CallGraphAnalysis term () -modifyCallGraph f = CallGraphAnalysis (Evaluator (modify f)) - - -newtype CallGraphAnalysis term a = CallGraphAnalysis { runCallGraphAnalysis :: Evaluator (CallGraphEffects term) term CallGraph a } - deriving (Alternative, Applicative, Functor, Monad, MonadFail) - -deriving instance MonadEvaluator term CallGraph (CallGraphAnalysis term) - -evaluateCallGraph :: forall term - . ( Evaluatable (Base term) - , Foldable (Base term) - , FreeVariables term - , BuildCallGraphAlgebra (Base term) - , MonadAddressable (LocationFor CallGraph) CallGraph (CallGraphAnalysis term) - , MonadValue term CallGraph (CallGraphAnalysis term) - , Ord (LocationFor CallGraph) - , Ord term - , Recursive term - , Semigroup (Cell (LocationFor CallGraph) CallGraph) - ) - => term - -> Final (CallGraphEffects term) CallGraph -evaluateCallGraph = run @(CallGraphEffects term) . runEvaluator . runCallGraphAnalysis . evaluateTerm - -instance MonadValue term CallGraph (CallGraphAnalysis term) where - unit = pure empty - integer _ = pure empty - boolean _ = pure empty - string _ = pure empty - - ifthenelse _ then' else' = overlay <$> then' <*> else' - - abstract names body = foldr bindLocally (subtermValue body) names - where bindLocally name rest = do - addr <- alloc name - assign addr empty - localEnv (envInsert name addr) rest - - apply operator arguments = foldr overlay operator <$> traverse subtermValue arguments - -type instance LocationFor CallGraph = Monovariant - - -instance ( Evaluatable (Base term) - , FreeVariables term - , BuildCallGraphAlgebra (Base term) - , MonadAddressable (LocationFor CallGraph) CallGraph (CallGraphAnalysis term) - , MonadValue term CallGraph (CallGraphAnalysis term) - , Ord term - , Recursive term - , Semigroup (Cell (LocationFor CallGraph) CallGraph) - ) - => MonadAnalysis term CallGraph (CallGraphAnalysis term) where - evaluateTerm = foldSubterms eval diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 07c2e10b9..aae481164 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -3,7 +3,6 @@ module Semantic.Util where import Prologue -import Analysis.Abstract.CallGraph import Analysis.Abstract.Evaluating import Analysis.Declaration import Control.Monad.IO.Class @@ -43,8 +42,6 @@ evaluateRubyFiles paths = do -- Python -evaluatePythonCallGraph path = evaluateCallGraph <$> (file path >>= runTask . parse pythonParser) - evaluatePythonFile path = evaluate @PythonValue <$> (file path >>= runTask . parse pythonParser) From d67b442d74686c1fe0654ed9017a82bf206dfdd5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 13:22:50 -0500 Subject: [PATCH 44/66] Move renderCallGraph down. --- src/Analysis/CallGraph.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index f4c41446a..80ef1a866 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -19,14 +19,14 @@ import Prologue hiding (empty) newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } deriving (Eq, Graph, Show) -renderCallGraph :: CallGraph -> ByteString -renderCallGraph = export (defaultStyle id) . unCallGraph - - buildCallGraph :: (BuildCallGraphAlgebra syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph buildCallGraph = foldSubterms buildCallGraphAlgebra +renderCallGraph :: CallGraph -> ByteString +renderCallGraph = export (defaultStyle id) . unCallGraph + + class BuildCallGraphAlgebra syntax where buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph From 8c15c0d2496bed7850ea77d4e3fdb61065a4d51b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 13:23:57 -0500 Subject: [PATCH 45/66] :memo: BuildCallGraphAlgebra. --- src/Analysis/CallGraph.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 80ef1a866..53ca73460 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -27,6 +27,7 @@ renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph +-- | Types which contribute to a 'CallGraph'. class BuildCallGraphAlgebra syntax where buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph From 40ff572d3f25f006421f1dddc8f2ff3a8fc16be8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 13:27:05 -0500 Subject: [PATCH 46/66] :memo: buildCallGraphAlgebra. --- src/Analysis/CallGraph.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 53ca73460..01d0dd1c0 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -29,6 +29,7 @@ renderCallGraph = export (defaultStyle id) . unCallGraph -- | Types which contribute to a 'CallGraph'. class BuildCallGraphAlgebra syntax where + -- | A 'SubtermAlgebra' computing the 'CallGraph' for a piece of @syntax@. buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph instance (BuildCallGraphAlgebraStrategy syntax ~ strategy, BuildCallGraphAlgebraWithStrategy strategy syntax) => BuildCallGraphAlgebra syntax where From 2aba67b7c9dd0aa5063bd253c6633a746fae4ab7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 13:30:15 -0500 Subject: [PATCH 47/66] Mention advanced overlap. --- src/Analysis/CallGraph.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 01d0dd1c0..657169453 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -27,7 +27,9 @@ renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph --- | Types which contribute to a 'CallGraph'. +-- | Types which contribute to a 'CallGraph'. There is exactly one instance of this typeclass; customizing the 'CallGraph's for a new type is done by defining an instance of 'CustomBuildCallGraphAlgebra' instead. +-- +-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. class BuildCallGraphAlgebra syntax where -- | A 'SubtermAlgebra' computing the 'CallGraph' for a piece of @syntax@. buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph From 52adbf2679ba381f43d85aaa14a87b043f0b2984 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 13:31:55 -0500 Subject: [PATCH 48/66] :memo: CustomBuildCallGraphAlgebra. --- src/Analysis/CallGraph.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 657169453..b649a4b64 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -37,6 +37,8 @@ class BuildCallGraphAlgebra syntax where instance (BuildCallGraphAlgebraStrategy syntax ~ strategy, BuildCallGraphAlgebraWithStrategy strategy syntax) => BuildCallGraphAlgebra syntax where buildCallGraphAlgebra = buildCallGraphAlgebraWithStrategy (Proxy :: Proxy strategy) + +-- | Types whose contribution to a 'CallGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'BuildCallGraphAlgebraStrategy'. class CustomBuildCallGraphAlgebra syntax where customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph From cb9bcefa6d1f57e18ea7639fb85ce775296785ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 13:34:45 -0500 Subject: [PATCH 49/66] :memo: the CustomBuildCallGraphAlgebra instances. --- src/Analysis/CallGraph.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index b649a4b64..82387884a 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -42,12 +42,15 @@ instance (BuildCallGraphAlgebraStrategy syntax ~ strategy, BuildCallGraphAlgebra class CustomBuildCallGraphAlgebra syntax where customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph +-- | 'Declaration.Function's produce a vertex for their name, with edges to any free variables in their body. instance CustomBuildCallGraphAlgebra Declaration.Function where customBuildCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) +-- | 'Declaration.Method's produce a vertex for their name, with edges to any free variables in their body. instance CustomBuildCallGraphAlgebra Declaration.Method where customBuildCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) +-- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'. instance CustomBuildCallGraphAlgebra Syntax.Identifier where customBuildCallGraphAlgebra (Syntax.Identifier name) bound | name `member` bound = empty From 35602d0b6c2ecbbf76419fa47c64adae71806771 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:16:21 -0500 Subject: [PATCH 50/66] :memo: BuildCallGraphAlgebraWithStrategy. --- src/Analysis/CallGraph.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 82387884a..41e00238f 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -62,6 +62,8 @@ instance Apply BuildCallGraphAlgebra syntaxes => CustomBuildCallGraphAlgebra (Un instance BuildCallGraphAlgebra syntax => CustomBuildCallGraphAlgebra (TermF syntax a) where customBuildCallGraphAlgebra = buildCallGraphAlgebra . termFOut + +-- | The mechanism selecting 'Default'/'Custom' implementations for 'buildCallGraphAlgebra' depending on the @syntax@ type. class BuildCallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph From bd2e8c4db24929169edd290d3ce29b022ccf1880 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:18:06 -0500 Subject: [PATCH 51/66] :memo: the BuildCallGraphWithStrategy instances. --- src/Analysis/CallGraph.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 41e00238f..0a88718a5 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -67,9 +67,11 @@ instance BuildCallGraphAlgebra syntax => CustomBuildCallGraphAlgebra (TermF synt class BuildCallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph +-- | The 'Default' definition of 'buildCallGraphAlgebra' combines all of the 'CallGraph's within the @syntax@ 'Monoid'ally. instance Foldable syntax => BuildCallGraphAlgebraWithStrategy 'Default syntax where buildCallGraphAlgebraWithStrategy _ = foldMap subtermValue +-- | The 'Custom' strategy calls out to the 'customBuildCallGraphAlgebra' method. instance CustomBuildCallGraphAlgebra syntax => BuildCallGraphAlgebraWithStrategy 'Custom syntax where buildCallGraphAlgebraWithStrategy _ = customBuildCallGraphAlgebra From 286c3f7ef242273ad323a10fc9d4f992a26935d8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:18:57 -0500 Subject: [PATCH 52/66] :memo: Strategy. --- src/Analysis/CallGraph.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 0a88718a5..53b00682b 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -75,6 +75,8 @@ instance Foldable syntax => BuildCallGraphAlgebraWithStrategy 'Default syntax wh instance CustomBuildCallGraphAlgebra syntax => BuildCallGraphAlgebraWithStrategy 'Custom syntax where buildCallGraphAlgebraWithStrategy _ = customBuildCallGraphAlgebra + +-- | Which instance of 'CustomBuildCallGraphAlgebra' to use for a given @syntax@ type. data Strategy = Default | Custom type family BuildCallGraphAlgebraStrategy syntax where From 4f617c5c1cf3c3b04f26853d10f95f388e10ad1d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:19:09 -0500 Subject: [PATCH 53/66] :memo: BuildCallGraphAlgebraStrategy. --- src/Analysis/CallGraph.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 53b00682b..74a537000 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -79,6 +79,7 @@ instance CustomBuildCallGraphAlgebra syntax => BuildCallGraphAlgebraWithStrategy -- | Which instance of 'CustomBuildCallGraphAlgebra' to use for a given @syntax@ type. data Strategy = Default | Custom +-- | A mapping of @syntax@ types onto 'Strategy's. type family BuildCallGraphAlgebraStrategy syntax where BuildCallGraphAlgebraStrategy Declaration.Function = 'Custom BuildCallGraphAlgebraStrategy Declaration.Method = 'Custom From f56457e79175be45a2fc617e0e2f1345b85d8598 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:19:51 -0500 Subject: [PATCH 54/66] Rename Build* to *. --- src/Analysis/CallGraph.hs | 62 +++++++++++++++++++-------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 74a537000..0cc36c028 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -3,7 +3,7 @@ module Analysis.CallGraph ( CallGraph(..) , renderCallGraph , buildCallGraph -, BuildCallGraphAlgebra(..) +, CallGraphAlgebra(..) ) where import qualified Algebra.Graph as G @@ -19,7 +19,7 @@ import Prologue hiding (empty) newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } deriving (Eq, Graph, Show) -buildCallGraph :: (BuildCallGraphAlgebra syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph +buildCallGraph :: (CallGraphAlgebra syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph buildCallGraph = foldSubterms buildCallGraphAlgebra @@ -27,66 +27,66 @@ renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph --- | Types which contribute to a 'CallGraph'. There is exactly one instance of this typeclass; customizing the 'CallGraph's for a new type is done by defining an instance of 'CustomBuildCallGraphAlgebra' instead. +-- | Types which contribute to a 'CallGraph'. There is exactly one instance of this typeclass; customizing the 'CallGraph's for a new type is done by defining an instance of 'CustomCallGraphAlgebra' instead. -- -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. -class BuildCallGraphAlgebra syntax where +class CallGraphAlgebra syntax where -- | A 'SubtermAlgebra' computing the 'CallGraph' for a piece of @syntax@. buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph -instance (BuildCallGraphAlgebraStrategy syntax ~ strategy, BuildCallGraphAlgebraWithStrategy strategy syntax) => BuildCallGraphAlgebra syntax where +instance (CallGraphAlgebraStrategy syntax ~ strategy, CallGraphAlgebraWithStrategy strategy syntax) => CallGraphAlgebra syntax where buildCallGraphAlgebra = buildCallGraphAlgebraWithStrategy (Proxy :: Proxy strategy) --- | Types whose contribution to a 'CallGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'BuildCallGraphAlgebraStrategy'. -class CustomBuildCallGraphAlgebra syntax where - customBuildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph +-- | Types whose contribution to a 'CallGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'CallGraphAlgebraStrategy'. +class CustomCallGraphAlgebra syntax where + customCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph -- | 'Declaration.Function's produce a vertex for their name, with edges to any free variables in their body. -instance CustomBuildCallGraphAlgebra Declaration.Function where - customBuildCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) +instance CustomCallGraphAlgebra Declaration.Function where + customCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound) -- | 'Declaration.Method's produce a vertex for their name, with edges to any free variables in their body. -instance CustomBuildCallGraphAlgebra Declaration.Method where - customBuildCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) +instance CustomCallGraphAlgebra Declaration.Method where + customCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound) -- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'. -instance CustomBuildCallGraphAlgebra Syntax.Identifier where - customBuildCallGraphAlgebra (Syntax.Identifier name) bound +instance CustomCallGraphAlgebra Syntax.Identifier where + customCallGraphAlgebra (Syntax.Identifier name) bound | name `member` bound = empty | otherwise = vertex name -instance Apply BuildCallGraphAlgebra syntaxes => CustomBuildCallGraphAlgebra (Union syntaxes) where - customBuildCallGraphAlgebra = Prologue.apply (Proxy :: Proxy BuildCallGraphAlgebra) buildCallGraphAlgebra +instance Apply CallGraphAlgebra syntaxes => CustomCallGraphAlgebra (Union syntaxes) where + customCallGraphAlgebra = Prologue.apply (Proxy :: Proxy CallGraphAlgebra) buildCallGraphAlgebra -instance BuildCallGraphAlgebra syntax => CustomBuildCallGraphAlgebra (TermF syntax a) where - customBuildCallGraphAlgebra = buildCallGraphAlgebra . termFOut +instance CallGraphAlgebra syntax => CustomCallGraphAlgebra (TermF syntax a) where + customCallGraphAlgebra = buildCallGraphAlgebra . termFOut -- | The mechanism selecting 'Default'/'Custom' implementations for 'buildCallGraphAlgebra' depending on the @syntax@ type. -class BuildCallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where +class CallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph -- | The 'Default' definition of 'buildCallGraphAlgebra' combines all of the 'CallGraph's within the @syntax@ 'Monoid'ally. -instance Foldable syntax => BuildCallGraphAlgebraWithStrategy 'Default syntax where +instance Foldable syntax => CallGraphAlgebraWithStrategy 'Default syntax where buildCallGraphAlgebraWithStrategy _ = foldMap subtermValue --- | The 'Custom' strategy calls out to the 'customBuildCallGraphAlgebra' method. -instance CustomBuildCallGraphAlgebra syntax => BuildCallGraphAlgebraWithStrategy 'Custom syntax where - buildCallGraphAlgebraWithStrategy _ = customBuildCallGraphAlgebra +-- | The 'Custom' strategy calls out to the 'customCallGraphAlgebra' method. +instance CustomCallGraphAlgebra syntax => CallGraphAlgebraWithStrategy 'Custom syntax where + buildCallGraphAlgebraWithStrategy _ = customCallGraphAlgebra --- | Which instance of 'CustomBuildCallGraphAlgebra' to use for a given @syntax@ type. +-- | Which instance of 'CustomCallGraphAlgebra' to use for a given @syntax@ type. data Strategy = Default | Custom -- | A mapping of @syntax@ types onto 'Strategy's. -type family BuildCallGraphAlgebraStrategy syntax where - BuildCallGraphAlgebraStrategy Declaration.Function = 'Custom - BuildCallGraphAlgebraStrategy Declaration.Method = 'Custom - BuildCallGraphAlgebraStrategy Syntax.Identifier = 'Custom - BuildCallGraphAlgebraStrategy (Union fs) = 'Custom - BuildCallGraphAlgebraStrategy (TermF f a) = 'Custom - BuildCallGraphAlgebraStrategy a = 'Default +type family CallGraphAlgebraStrategy syntax where + CallGraphAlgebraStrategy Declaration.Function = 'Custom + CallGraphAlgebraStrategy Declaration.Method = 'Custom + CallGraphAlgebraStrategy Syntax.Identifier = 'Custom + CallGraphAlgebraStrategy (Union fs) = 'Custom + CallGraphAlgebraStrategy (TermF f a) = 'Custom + CallGraphAlgebraStrategy a = 'Default instance Monoid CallGraph where From 58007ca5e06f433115d5ca9bbf543cd9d097e58b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:20:32 -0500 Subject: [PATCH 55/66] Rename buildCallGraphAlgebra* to callGraphAlgebra*. --- src/Analysis/CallGraph.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 0cc36c028..2302b3219 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -20,7 +20,7 @@ newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } deriving (Eq, Graph, Show) buildCallGraph :: (CallGraphAlgebra syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph -buildCallGraph = foldSubterms buildCallGraphAlgebra +buildCallGraph = foldSubterms callGraphAlgebra renderCallGraph :: CallGraph -> ByteString @@ -32,10 +32,10 @@ renderCallGraph = export (defaultStyle id) . unCallGraph -- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap. class CallGraphAlgebra syntax where -- | A 'SubtermAlgebra' computing the 'CallGraph' for a piece of @syntax@. - buildCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph + callGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph instance (CallGraphAlgebraStrategy syntax ~ strategy, CallGraphAlgebraWithStrategy strategy syntax) => CallGraphAlgebra syntax where - buildCallGraphAlgebra = buildCallGraphAlgebraWithStrategy (Proxy :: Proxy strategy) + callGraphAlgebra = callGraphAlgebraWithStrategy (Proxy :: Proxy strategy) -- | Types whose contribution to a 'CallGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'CallGraphAlgebraStrategy'. @@ -57,23 +57,23 @@ instance CustomCallGraphAlgebra Syntax.Identifier where | otherwise = vertex name instance Apply CallGraphAlgebra syntaxes => CustomCallGraphAlgebra (Union syntaxes) where - customCallGraphAlgebra = Prologue.apply (Proxy :: Proxy CallGraphAlgebra) buildCallGraphAlgebra + customCallGraphAlgebra = Prologue.apply (Proxy :: Proxy CallGraphAlgebra) callGraphAlgebra instance CallGraphAlgebra syntax => CustomCallGraphAlgebra (TermF syntax a) where - customCallGraphAlgebra = buildCallGraphAlgebra . termFOut + customCallGraphAlgebra = callGraphAlgebra . termFOut --- | The mechanism selecting 'Default'/'Custom' implementations for 'buildCallGraphAlgebra' depending on the @syntax@ type. +-- | The mechanism selecting 'Default'/'Custom' implementations for 'callGraphAlgebra' depending on the @syntax@ type. class CallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where - buildCallGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph + callGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph --- | The 'Default' definition of 'buildCallGraphAlgebra' combines all of the 'CallGraph's within the @syntax@ 'Monoid'ally. +-- | The 'Default' definition of 'callGraphAlgebra' combines all of the 'CallGraph's within the @syntax@ 'Monoid'ally. instance Foldable syntax => CallGraphAlgebraWithStrategy 'Default syntax where - buildCallGraphAlgebraWithStrategy _ = foldMap subtermValue + callGraphAlgebraWithStrategy _ = foldMap subtermValue -- | The 'Custom' strategy calls out to the 'customCallGraphAlgebra' method. instance CustomCallGraphAlgebra syntax => CallGraphAlgebraWithStrategy 'Custom syntax where - buildCallGraphAlgebraWithStrategy _ = customCallGraphAlgebra + callGraphAlgebraWithStrategy _ = customCallGraphAlgebra -- | Which instance of 'CustomCallGraphAlgebra' to use for a given @syntax@ type. From 0f8746aa830818b60521d12ee9e8be95a3da1bbb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:21:43 -0500 Subject: [PATCH 56/66] :memo: CallGraph. --- src/Analysis/CallGraph.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 2302b3219..cfbf9b667 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -16,6 +16,7 @@ import qualified Data.Syntax.Declaration as Declaration import Data.Term import Prologue hiding (empty) +-- | The graph of function definitions to symbols used in a given program. newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } deriving (Eq, Graph, Show) From 816218b9003fc0df655de2a55764856c202d5c0a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:22:05 -0500 Subject: [PATCH 57/66] :memo: buildCallGraph. --- src/Analysis/CallGraph.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index cfbf9b667..339a4a78a 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -20,6 +20,7 @@ import Prologue hiding (empty) newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } deriving (Eq, Graph, Show) +-- | Build the 'CallGraph' for a 'Term' recursively. buildCallGraph :: (CallGraphAlgebra syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph buildCallGraph = foldSubterms callGraphAlgebra From 8557bfc09b39bb8dc25a197b37d4af98e7142408 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 14:22:31 -0500 Subject: [PATCH 58/66] :memo: renderCallGraph. --- src/Analysis/CallGraph.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 339a4a78a..2fa982d2f 100644 --- a/src/Analysis/CallGraph.hs +++ b/src/Analysis/CallGraph.hs @@ -25,6 +25,7 @@ buildCallGraph :: (CallGraphAlgebra syntax, Foldable syntax, FreeVariables1 synt buildCallGraph = foldSubterms callGraphAlgebra +-- | Render a 'CallGraph' to a 'ByteString' in DOT notation. renderCallGraph :: CallGraph -> ByteString renderCallGraph = export (defaultStyle id) . unCallGraph From af21fa48fe060d546650efd4ee530128de4af229 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:36:21 -0400 Subject: [PATCH 59/66] :fire: a redundant import. --- src/Data/Syntax.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 3ad09190f..5264cd286 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -2,7 +2,6 @@ module Data.Syntax where import Control.Monad.Fail -import Data.Abstract.Environment import Data.Abstract.Evaluatable import Data.AST import Data.Range From 3e77eb92ce62d4bbd1a3a308c8438d0864bc5ab2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:36:46 -0400 Subject: [PATCH 60/66] Pass the name in manually. --- src/Data/Syntax/Statement.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 16e04182f..a50953c34 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -94,7 +94,7 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Assignment where eval Assignment{..} = do v <- subtermValue assignmentValue - (var, a) <- lookupOrAlloc (subterm assignmentTarget) v + (var, a) <- lookupOrAlloc' (freeVariable (subterm assignmentTarget)) v modifyGlobalEnv (envInsert var a) pure v From 031d67a20954581be71984917bca468311e33bfc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:37:00 -0400 Subject: [PATCH 61/66] Replace lookupOrAlloc with lookupOrAlloc'. --- src/Control/Abstract/Addressable.hs | 23 ++++------------------- src/Data/Syntax/Statement.hs | 2 +- 2 files changed, 5 insertions(+), 20 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 952267421..04fa3b6b8 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -20,31 +20,16 @@ class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => M alloc :: Name -> m (Address l value) --- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. --- --- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. -lookupOrAlloc :: ( FreeVariables term +-- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. +lookupOrAlloc :: ( Semigroup (CellFor value) , MonadAddressable (LocationFor value) value m , MonadEnvironment value m , MonadStore value m - , Semigroup (CellFor value) ) - => term + => Name -> value -> m (Name, Address (LocationFor value) value) -lookupOrAlloc term = let [name] = toList (freeVariables term) in - lookupOrAlloc' name - --- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. -lookupOrAlloc' :: ( Semigroup (CellFor value) - , MonadAddressable (LocationFor value) value m - , MonadEnvironment value m - , MonadStore value m - ) - => Name - -> value - -> m (Name, Address (LocationFor value) value) -lookupOrAlloc' name v = do +lookupOrAlloc name v = do a <- lookupLocalEnv name >>= maybe (alloc name) pure assign a v pure (name, a) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index a50953c34..604c8af89 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -94,7 +94,7 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Assignment where eval Assignment{..} = do v <- subtermValue assignmentValue - (var, a) <- lookupOrAlloc' (freeVariable (subterm assignmentTarget)) v + (var, a) <- lookupOrAlloc (freeVariable (subterm assignmentTarget)) v modifyGlobalEnv (envInsert var a) pure v From 9aa76f05c8dc4588fe5dbc7bc2bd2db6d2cbd699 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:37:52 -0400 Subject: [PATCH 62/66] :fire: a redundant Semigroup constraint. --- src/Control/Abstract/Addressable.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 04fa3b6b8..c611c8910 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -10,7 +10,6 @@ import Data.Abstract.FreeVariables import Data.Abstract.Store import Data.Abstract.Value import Data.Foldable (asum, toList) -import Data.Semigroup import Data.Semigroup.Reducer import Prelude hiding (fail) @@ -21,8 +20,7 @@ class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => M alloc :: Name -> m (Address l value) -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. -lookupOrAlloc :: ( Semigroup (CellFor value) - , MonadAddressable (LocationFor value) value m +lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m , MonadEnvironment value m , MonadStore value m ) From f8bfadf48fc0a6881e693e417bff232743383a80 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:39:36 -0400 Subject: [PATCH 63/66] lookupOrAlloc no longer returns the Name. --- src/Control/Abstract/Addressable.hs | 4 ++-- src/Data/Syntax/Statement.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index c611c8910..6e579f694 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -26,11 +26,11 @@ lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m ) => Name -> value - -> m (Name, Address (LocationFor value) value) + -> m (Address (LocationFor value) value) lookupOrAlloc name v = do a <- lookupLocalEnv name >>= maybe (alloc name) pure assign a v - pure (name, a) + pure a letrec :: ( MonadAddressable (LocationFor value) value m diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 604c8af89..1ae3a3070 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -94,10 +94,10 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Assignment where eval Assignment{..} = do v <- subtermValue assignmentValue - (var, a) <- lookupOrAlloc (freeVariable (subterm assignmentTarget)) v - - modifyGlobalEnv (envInsert var a) + addr <- lookupOrAlloc name v + modifyGlobalEnv (envInsert name addr) pure v + where name = freeVariable (subterm assignmentTarget) -- | Post increment operator (e.g. 1++ in Go, or i++ in C). newtype PostIncrement a = PostIncrement a From a42af3cee50cedf4f77db8fe2271923d4301f5cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:40:51 -0400 Subject: [PATCH 64/66] =?UTF-8?q?lookupOrAlloc=20doesn=E2=80=99t=20assign.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Addressable.hs | 9 ++------- src/Data/Syntax/Statement.hs | 3 ++- 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 6e579f694..eb3328d95 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -19,18 +19,13 @@ class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => M alloc :: Name -> m (Address l value) --- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. +-- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m , MonadEnvironment value m - , MonadStore value m ) => Name - -> value -> m (Address (LocationFor value) value) -lookupOrAlloc name v = do - a <- lookupLocalEnv name >>= maybe (alloc name) pure - assign a v - pure a +lookupOrAlloc name = lookupLocalEnv name >>= maybe (alloc name) pure letrec :: ( MonadAddressable (LocationFor value) value m diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 1ae3a3070..c143c45f7 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -94,7 +94,8 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Assignment where eval Assignment{..} = do v <- subtermValue assignmentValue - addr <- lookupOrAlloc name v + addr <- lookupOrAlloc name + assign addr v modifyGlobalEnv (envInsert name addr) pure v where name = freeVariable (subterm assignmentTarget) From ae3b26c2a7594844dfc1f0609e495310250de8a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:41:29 -0400 Subject: [PATCH 65/66] letrec uses lookupOrAlloc. --- src/Control/Abstract/Addressable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index eb3328d95..d12cac5ba 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -36,7 +36,7 @@ letrec :: ( MonadAddressable (LocationFor value) value m -> m value -> m (value, Address (LocationFor value) value) letrec name body = do - addr <- alloc name + addr <- lookupOrAlloc name v <- localEnv (envInsert name addr) body assign addr v pure (v, addr) From 9547688b4a0865f316dbea25e5a68233ae717899 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:44:17 -0400 Subject: [PATCH 66/66] :memo: lookupWith. --- src/Control/Abstract/Evaluator.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index c506a4e57..685a18707 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -60,6 +60,7 @@ class Monad m => MonadEnvironment value m | m -> value where lookupLocalEnv :: Name -> m (Maybe (Address (LocationFor value) value)) lookupLocalEnv name = envLookup name <$> askLocalEnv + -- | Look up a 'Name' in the local environment, running an action with the resolved address (if any). lookupWith :: (Address (LocationFor value) value -> m value) -> Name -> m (Maybe value) lookupWith with name = do addr <- lookupLocalEnv name