From 010f4fdd0b8e92511c7d7e4679560b95514ab84c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Mar 2018 15:04:16 -0500 Subject: [PATCH 001/104] 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 002/104] 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 003/104] =?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 004/104] 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 005/104] 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 006/104] 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 007/104] 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 008/104] 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 009/104] 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 010/104] 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 011/104] 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 012/104] 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 013/104] 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 014/104] 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 015/104] :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 016/104] 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 017/104] 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 018/104] 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 019/104] 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 020/104] 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 021/104] 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 022/104] 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 023/104] 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 024/104] 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 025/104] 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 026/104] 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 027/104] 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 028/104] 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 029/104] 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 030/104] 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 031/104] 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 032/104] 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 033/104] 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 034/104] 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 035/104] 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 036/104] 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 037/104] =?UTF-8?q?Don=E2=80=99t=20generate=20vertices=20f?= =?UTF-8?q?or=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 038/104] 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 039/104] 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 040/104] 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 041/104] 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 042/104] 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 043/104] :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 044/104] 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 045/104] :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 046/104] :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 047/104] 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 048/104] :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 049/104] :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 050/104] :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 051/104] :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 052/104] :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 053/104] :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 054/104] 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 055/104] 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 056/104] :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 057/104] :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 058/104] :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 3ac59ce62386326f40fcec2a97a180d9e8757787 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 16:39:58 -0400 Subject: [PATCH 059/104] Define an elaborating analysis. --- semantic.cabal | 1 + src/Analysis/Abstract/Elaborating.hs | 5 +++++ 2 files changed, 6 insertions(+) create mode 100644 src/Analysis/Abstract/Elaborating.hs diff --git a/semantic.cabal b/semantic.cabal index defc9f833..447eeddd8 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -18,6 +18,7 @@ library Analysis.Abstract.Caching , Analysis.Abstract.Collecting , Analysis.Abstract.Dead + , Analysis.Abstract.Elaborating , Analysis.Abstract.Evaluating , Analysis.Abstract.Tracing , Analysis.ConstructorName diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs new file mode 100644 index 000000000..4d6af64e7 --- /dev/null +++ b/src/Analysis/Abstract/Elaborating.hs @@ -0,0 +1,5 @@ +module Analysis.Abstract.Elaborating +( Elaborating +) where + +newtype Elaborating m term value effects a = Elaborating (m term value effects a) From 0c199987ca2fe42b1dce8b5695128b0dd790a11d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 16:42:11 -0400 Subject: [PATCH 060/104] Derive a bunch of instances. --- src/Analysis/Abstract/Elaborating.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs index 4d6af64e7..d9034b566 100644 --- a/src/Analysis/Abstract/Elaborating.hs +++ b/src/Analysis/Abstract/Elaborating.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} module Analysis.Abstract.Elaborating -( Elaborating +( type Elaborating ) where -newtype Elaborating m term value effects a = Elaborating (m term value effects a) +import Control.Abstract.Analysis +import Prologue + +newtype Elaborating m term value (effects :: [* -> *]) a = Elaborating (m term value effects a) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) From 67c25c004adb6b36ac736d572b45550ca576956d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 16:42:54 -0400 Subject: [PATCH 061/104] Derive the evaluator instances. --- src/Analysis/Abstract/Elaborating.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs index d9034b566..7d3c80587 100644 --- a/src/Analysis/Abstract/Elaborating.hs +++ b/src/Analysis/Abstract/Elaborating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies #-} module Analysis.Abstract.Elaborating ( type Elaborating ) where @@ -8,3 +8,8 @@ import Prologue newtype Elaborating m term value (effects :: [* -> *]) a = Elaborating (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) + +deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Elaborating m term value effects) +deriving instance MonadStore value (m term value effects) => MonadStore value (Elaborating m term value effects) +deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Elaborating m term value effects) +deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Elaborating m term value effects) From c3ba46d82f23360e643112523dc63929211d133e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 16:44:33 -0400 Subject: [PATCH 062/104] Define a MonadAnalysis instance. --- src/Analysis/Abstract/Elaborating.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs index 7d3c80587..8e0f90620 100644 --- a/src/Analysis/Abstract/Elaborating.hs +++ b/src/Analysis/Abstract/Elaborating.hs @@ -13,3 +13,8 @@ deriving instance MonadEnvironment value (m term value effects) => MonadEnvironm deriving instance MonadStore value (m term value effects) => MonadStore value (Elaborating m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Elaborating m term value effects) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Elaborating m term value effects) + +instance MonadAnalysis term value (m term value effects) + => MonadAnalysis term value (Elaborating m term value effects) where + type RequiredEffects term value (Elaborating m term value effects) = RequiredEffects term value (m term value effects) + analyzeTerm = liftAnalyze analyzeTerm From 3bba683093f51406e0443112f8a6389de805ca07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 16:56:17 -0400 Subject: [PATCH 063/104] Stub in a MonadValue instance for elaborated terms. --- src/Analysis/Abstract/Elaborating.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs index 8e0f90620..6f70af454 100644 --- a/src/Analysis/Abstract/Elaborating.hs +++ b/src/Analysis/Abstract/Elaborating.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Elaborating ( type Elaborating ) where import Control.Abstract.Analysis +import Control.Abstract.Value +import Data.Term import Prologue newtype Elaborating m term value (effects :: [* -> *]) a = Elaborating (m term value effects a) @@ -18,3 +20,11 @@ instance MonadAnalysis term value (m term value effects) => MonadAnalysis term value (Elaborating m term value effects) where type RequiredEffects term value (Elaborating m term value effects) = RequiredEffects term value (m term value effects) analyzeTerm = liftAnalyze analyzeTerm + +instance ( elab ~ Term (Base term) value + , MonadAnalysis term elab (m term elab effects) + , Recursive term + , Show1 (Base term) + , Show value + ) + => MonadValue term elab (Elaborating m term elab effects) where From f022d0202cd92372d862488cdf098bab148d9b9b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 19:54:06 -0400 Subject: [PATCH 064/104] Define a MonadControl typeclass which allocates and performs gotos. --- src/Control/Abstract/Evaluator.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 5f1e96fe6..b6fd9d53f 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -8,6 +8,7 @@ module Control.Abstract.Evaluator , assign , MonadModuleTable(..) , modifyModuleTable +, MonadControl(..) ) where import Data.Abstract.Address @@ -103,3 +104,10 @@ modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentF modifyModuleTable f = do table <- getModuleTable putModuleTable $! f table + + +type Label = Int + +class Monad m => MonadControl term m where + label :: term -> m Label + goto :: Label -> m term From dfebaf7911a13705bc6e716234915bd069874f36 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 19:54:21 -0400 Subject: [PATCH 065/104] Define MonadControl for Evaluating. --- src/Analysis/Abstract/Evaluating.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index a25887cbd..1a9583d42 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -18,6 +18,7 @@ import Data.Abstract.Address import Data.Abstract.ModuleTable import Data.Abstract.Value import Data.Blob +import qualified Data.IntMap as IntMap import Data.Language import Data.List.Split (splitWhen) import Prelude hiding (fail) @@ -70,7 +71,6 @@ withModules Blob{..} pairs = localModuleTable (const moduleTable) newtype Evaluating term value effects a = Evaluating (Eff effects a) deriving (Applicative, Functor, Effectful, Monad) - deriving instance Member Fail effects => MonadFail (Evaluating term value effects) deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects) deriving instance Member NonDetEff effects => Alternative (Evaluating term value effects) @@ -86,8 +86,18 @@ type EvaluatingEffects term value , State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules , State (Map Name (Name, Maybe (Address (LocationFor value) value))) -- Set of exports + , State (IntMap.IntMap term) -- For jumps ] +instance Members '[Fail, State (IntMap.IntMap term)] effects => MonadControl term (Evaluating term value effects) where + label term = do + m <- raise get + let i = IntMap.size m + raise (put (IntMap.insert i term m)) + pure i + + goto label = IntMap.lookup label <$> raise get >>= maybe (fail ("unknown label: " <> show label)) pure + instance Members '[State (Map Name (Name, Maybe (Address (LocationFor value) value))), Reader (EnvironmentFor value), State (EnvironmentFor value)] effects => MonadEnvironment value (Evaluating term value effects) where getGlobalEnv = raise get putGlobalEnv = raise . put From c6baf4d8731cbc372c10fad423348dee89f076d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 19:54:39 -0400 Subject: [PATCH 066/104] Derive MonadControl instances for the other analyses. --- src/Analysis/Abstract/Caching.hs | 1 + src/Analysis/Abstract/Collecting.hs | 1 + src/Analysis/Abstract/Dead.hs | 1 + src/Analysis/Abstract/Elaborating.hs | 1 + src/Analysis/Abstract/Tracing.hs | 1 + 5 files changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 09d45f4a7..cf8fcf354 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -26,6 +26,7 @@ type CacheFor term value = Cache (LocationFor value) term value newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) +deriving instance MonadControl term (m term value effects) => MonadControl term (Caching m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects) deriving instance MonadStore value (m term value effects) => MonadStore value (Caching m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index e6bb87d9c..d986df0f0 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -14,6 +14,7 @@ import Prologue newtype Collecting m term value (effects :: [* -> *]) a = Collecting (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) +deriving instance MonadControl term (m term value effects) => MonadControl term (Collecting m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Collecting m term value effects) deriving instance MonadStore value (m term value effects) => MonadStore value (Collecting m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Collecting m term value effects) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index c3cb2c4fc..a4ea0a3b1 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -12,6 +12,7 @@ import Prologue newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) +deriving instance MonadControl term (m term value effects) => MonadControl term (DeadCode m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects) deriving instance MonadStore value (m term value effects) => MonadStore value (DeadCode m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects) diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs index 6f70af454..39db41a7f 100644 --- a/src/Analysis/Abstract/Elaborating.hs +++ b/src/Analysis/Abstract/Elaborating.hs @@ -11,6 +11,7 @@ import Prologue newtype Elaborating m term value (effects :: [* -> *]) a = Elaborating (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) +deriving instance MonadControl term (m term value effects) => MonadControl term (Elaborating m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Elaborating m term value effects) deriving instance MonadStore value (m term value effects) => MonadStore value (Elaborating m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Elaborating m term value effects) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index d7b18ac97..6f43d3619 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -17,6 +17,7 @@ import Prologue hiding (trace) newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) +deriving instance MonadControl term (m term value effects) => MonadControl term (Tracing trace m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects) deriving instance MonadStore value (m term value effects) => MonadStore value (Tracing trace m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects) From d6fd75143fa37e3e0cf315348cfc61c48229b858 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 19:54:52 -0400 Subject: [PATCH 067/104] Require MonadControl for MonadEvaluator. --- src/Control/Abstract/Evaluator.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index b6fd9d53f..51cb39210 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -27,7 +27,8 @@ import Prologue -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class ( MonadEnvironment value m +class ( MonadControl term m + , MonadEnvironment value m , MonadFail m , MonadModuleTable term value m , MonadStore value m From d987682a638a39779df757f3b344b68f91a45fdf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 19:58:30 -0400 Subject: [PATCH 068/104] Closures wrap labels. --- src/Control/Abstract/Value.hs | 8 +++++--- src/Data/Abstract/Value.hs | 24 ++++++++++++------------ 2 files changed, 17 insertions(+), 15 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 850c95a59..21d721d18 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -184,16 +184,18 @@ instance ( FreeVariables term pair = (left, right) - abstract names (Subterm body _) = injValue . Closure names body . bindEnv (foldr Set.delete (freeVariables body) names) <$> askLocalEnv + abstract names (Subterm body _) = do + l <- label body + injValue . Closure names l . bindEnv (foldr Set.delete (freeVariables body) names) <$> askLocalEnv apply op params = do - Closure names body env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) + Closure names l env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) bindings <- foldr (\ (name, param) rest -> do v <- param a <- alloc name assign a v envInsert name a <$> rest) (pure env) (zip names params) - localEnv (mappend bindings) (evaluateTerm body) + localEnv (mappend bindings) (goto l >>= evaluateTerm) loop = fix diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index e0fbc208e..516835f7f 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -13,8 +13,8 @@ import Prologue import Prelude hiding (Float, Integer, String, Rational, fail) import qualified Prelude -type ValueConstructors location term - = '[Closure location term +type ValueConstructors location + = '[Closure location , Unit , Boolean , Float @@ -27,19 +27,19 @@ type ValueConstructors location term -- | Open union of primitive values that terms can be evaluated to. -- Fix by another name. -newtype Value location term = Value { deValue :: Union (ValueConstructors location term) (Value location term) } +newtype Value location term = Value { deValue :: Union (ValueConstructors location) (Value location term) } deriving (Eq, Show, Ord) -- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'. -injValue :: (f :< ValueConstructors location term) => f (Value location term) -> Value location term +injValue :: (f :< ValueConstructors location) => f (Value location term) -> Value location term injValue = Value . inj -- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper. -prjValue :: (f :< ValueConstructors location term) => Value location term -> Maybe (f (Value location term)) +prjValue :: (f :< ValueConstructors location) => Value location term -> Maybe (f (Value location term)) prjValue = prj . deValue -- | Convenience function for projecting two values. -prjPair :: ( f :< ValueConstructors loc term1 , g :< ValueConstructors loc term2) +prjPair :: (f :< ValueConstructors loc , g :< ValueConstructors loc) => (Value loc term1, Value loc term2) -> Maybe (f (Value loc term1), g (Value loc term2)) prjPair = bitraverse prjValue prjValue @@ -47,12 +47,12 @@ prjPair = bitraverse prjValue prjValue -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. -- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body. -data Closure location term value = Closure [Name] term (Environment location value) +data Closure location value = Closure [Name] Int (Environment location value) deriving (Eq, Generic1, Ord, Show) -instance (Eq location, Eq term) => Eq1 (Closure location term) where liftEq = genericLiftEq -instance (Ord location, Ord term) => Ord1 (Closure location term) where liftCompare = genericLiftCompare -instance (Show location, Show term) => Show1 (Closure location term) where liftShowsPrec = genericLiftShowsPrec +instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq +instance Ord location => Ord1 (Closure location) where liftCompare = genericLiftCompare +instance Show location => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec -- | The unit value. Typically used to represent the result of imperative statements. data Unit value = Unit @@ -146,8 +146,8 @@ class ValueRoots value where instance Ord location => ValueRoots (Value location term) where valueRoots v - | Just (Closure _ body env) <- prjValue v = envAll env `const` (body :: term) - | otherwise = mempty + | Just (Closure _ _ env) <- prjValue v = envAll env + | otherwise = mempty instance ValueRoots Type.Type where valueRoots _ = mempty From d47f91968ae1597949ae2371c4458b381134bf04 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 20:04:55 -0400 Subject: [PATCH 069/104] Remove the term parameter from Value. --- src/Control/Abstract/Value.hs | 6 +++--- src/Data/Abstract/Value.hs | 16 ++++++++-------- src/Semantic/Util.hs | 29 ++++++++++------------------- 3 files changed, 21 insertions(+), 30 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 21d721d18..c7e0aa0e8 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -115,12 +115,12 @@ doWhile body cond = loop $ \ continue -> body *> do -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables term - , MonadAddressable location (Value location term) m - , MonadAnalysis term (Value location term) m + , MonadAddressable location (Value location) m + , MonadAnalysis term (Value location) m , Show location , Show term ) - => MonadValue term (Value location term) m where + => MonadValue term (Value location) m where unit = pure . injValue $ Value.Unit integer = pure . injValue . Value.Integer . Number.Integer diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 516835f7f..8d1377ca7 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -27,21 +27,21 @@ type ValueConstructors location -- | Open union of primitive values that terms can be evaluated to. -- Fix by another name. -newtype Value location term = Value { deValue :: Union (ValueConstructors location) (Value location term) } +newtype Value location = Value { deValue :: Union (ValueConstructors location) (Value location) } deriving (Eq, Show, Ord) -- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'. -injValue :: (f :< ValueConstructors location) => f (Value location term) -> Value location term +injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location injValue = Value . inj -- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper. -prjValue :: (f :< ValueConstructors location) => Value location term -> Maybe (f (Value location term)) +prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location)) prjValue = prj . deValue -- | Convenience function for projecting two values. -prjPair :: (f :< ValueConstructors loc , g :< ValueConstructors loc) - => (Value loc term1, Value loc term2) - -> Maybe (f (Value loc term1), g (Value loc term2)) +prjPair :: (f :< ValueConstructors loc1 , g :< ValueConstructors loc2) + => (Value loc1, Value loc2) + -> Maybe (f (Value loc1), g (Value loc2)) prjPair = bitraverse prjValue prjValue -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. @@ -136,7 +136,7 @@ type LiveFor value = Live (LocationFor value) value -- | 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 (Value location) = location LocationFor Type.Type = Monovariant -- | Value types, e.g. closures, which can root a set of addresses. @@ -144,7 +144,7 @@ class ValueRoots value where -- | Compute the set of addresses rooted by a given value. valueRoots :: value -> LiveFor value -instance Ord location => ValueRoots (Value location term) where +instance Ord location => ValueRoots (Value location) where valueRoots v | Just (Closure _ _ env) <- prjValue v = envAll env | otherwise = mempty diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 9089d4502..78bfa3e9f 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -14,7 +14,6 @@ import Data.Abstract.Evaluatable import Data.Abstract.Address import Data.Abstract.Type import Data.Abstract.Value -import Data.AST import Data.Blob import Data.Diff import Data.Range @@ -31,36 +30,28 @@ import Semantic.Task import qualified Language.Go.Assignment as Go import qualified Language.Python.Assignment as Python -import qualified Language.Ruby.Assignment as Ruby import qualified Language.TypeScript.Assignment as TypeScript -type PreciseValue a = Value Precise (Term (Union a) (Record Location)) - -type GoValue = PreciseValue Go.Syntax -type RubyValue = PreciseValue Ruby.Syntax -type PythonValue = PreciseValue Python.Syntax -type TypeScriptValue = PreciseValue TypeScript.Syntax - -- Ruby -evaluateRubyFile = evaluateFile @RubyValue rubyParser -evaluateRubyFiles = evaluateFiles @RubyValue rubyParser +evaluateRubyFile = evaluateFile @(Value Precise) rubyParser +evaluateRubyFiles = evaluateFiles @(Value Precise) rubyParser -- Go -evaluateGoFile = evaluateFile @GoValue goParser -evaluateGoFiles = evaluateFiles @GoValue goParser +evaluateGoFile = evaluateFile @(Value Precise) goParser +evaluateGoFiles = evaluateFiles @(Value Precise) goParser typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . snd <$> parseFile goParser path -- Python -evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path -evaluatePythonFiles = evaluateFiles @PythonValue pythonParser +evaluatePythonFile path = evaluate @(Value Precise) . snd <$> parseFile pythonParser path +evaluatePythonFiles = evaluateFiles @(Value Precise) pythonParser typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term (Value Precise)) . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term (Value Precise)) . evaluateModule . snd <$> parseFile pythonParser path -- TypeScript typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . snd <$> parseFile typescriptParser path -evaluateTypeScriptFile = evaluateFile @TypeScriptValue typescriptParser -evaluateTypeScriptFiles = evaluateFiles @TypeScriptValue typescriptParser +evaluateTypeScriptFile = evaluateFile @(Value Precise) typescriptParser +evaluateTypeScriptFiles = evaluateFiles @(Value Precise) typescriptParser -- Evalute a single file. evaluateFile :: forall value term effects From 272f6ec68a694c7b833e3f0ce183df4f9434ba7a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 20:10:14 -0400 Subject: [PATCH 070/104] Remove the term parameter from MonadValue. --- src/Analysis/Abstract/Elaborating.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 6 +++--- src/Control/Abstract/Value.hs | 27 ++++++++++++++------------- src/Data/Abstract/Evaluatable.hs | 4 ++-- src/Semantic/Util.hs | 4 ++-- 5 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs index 39db41a7f..2383aac42 100644 --- a/src/Analysis/Abstract/Elaborating.hs +++ b/src/Analysis/Abstract/Elaborating.hs @@ -28,4 +28,4 @@ instance ( elab ~ Term (Base term) value , Show1 (Base term) , Show value ) - => MonadValue term elab (Elaborating m term elab effects) where + => MonadValue elab (Elaborating m term elab effects) where diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 1a9583d42..1ae3843af 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -33,7 +33,7 @@ evaluate :: forall value term effects , Evaluatable (Base term) , FreeVariables term , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue term value (Evaluating term value effects) + , MonadValue value (Evaluating term value effects) , Recursive term ) => term @@ -46,7 +46,7 @@ evaluates :: forall value term effects , Evaluatable (Base term) , FreeVariables term , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue term value (Evaluating term value effects) + , MonadValue value (Evaluating term value effects) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated @@ -128,7 +128,7 @@ instance ( Evaluatable (Base term) , FreeVariables term , Members (EvaluatingEffects term value) effects , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue term value (Evaluating term value effects) + , MonadValue value (Evaluating term value effects) , Recursive term ) => MonadAnalysis term value (Evaluating term value effects) where diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index c7e0aa0e8..8280c0b35 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -26,7 +26,7 @@ data Comparator -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadAnalysis term value m, Show value) => MonadValue term value m where +class (MonadEnvironment value m, MonadFail m, MonadStore value m, Show value) => MonadValue value m where -- | Construct an abstract unit value. -- TODO: This might be the same as the empty tuple for some value types unit :: m value @@ -71,7 +71,7 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where ifthenelse :: value -> m a -> m a -> m a -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm term (m value) -> m value + abstract :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value -- | Evaluate an application (like a function call). apply :: value -> [m value] -> m value @@ -81,10 +81,10 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where loop :: (m value -> m value) -> m value -- | Attempt to extract a 'Prelude.Bool' from a given value. -toBool :: MonadValue term value m => value -> m Bool +toBool :: MonadValue value m => value -> m Bool toBool v = ifthenelse v (pure True) (pure False) -forLoop :: MonadValue term value m +forLoop :: MonadValue value m => m value -- | Initial statement -> m value -- | Condition -> m value -- | Increment/stepper @@ -96,7 +96,7 @@ forLoop initial cond step body = do localEnv (mappend env) (while cond (body *> step)) -- | The fundamental looping primitive, built on top of ifthenelse. -while :: MonadValue term value m +while :: MonadValue value m => m value -> m value -> m value @@ -105,7 +105,7 @@ while cond body = loop $ \ continue -> do ifthenelse this (body *> continue) unit -- | Do-while loop, built on top of while. -doWhile :: MonadValue term value m +doWhile :: MonadValue value m => m value -> m value -> m value @@ -114,13 +114,14 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue unit -- | Construct a 'Value' wrapping the value arguments (if any). -instance ( FreeVariables term - , MonadAddressable location (Value location) m +instance ( MonadAddressable location (Value location) m , MonadAnalysis term (Value location) m + , MonadEnvironment (Value location) m + , MonadFail m + , MonadStore (Value location) m , Show location - , Show term ) - => MonadValue term (Value location) m where + => MonadValue (Value location) m where unit = pure . injValue $ Value.Unit integer = pure . injValue . Value.Integer . Number.Integer @@ -155,7 +156,7 @@ instance ( FreeVariables term | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) where -- Dispatch whatever's contained inside a 'SomeNumber' to its appropriate 'MonadValue' ctor - specialize :: MonadValue term value m => SomeNumber -> m value + specialize :: MonadValue value m => SomeNumber -> m value specialize (SomeNumber (Number.Integer i)) = integer i specialize (SomeNumber (Ratio r)) = rational r specialize (SomeNumber (Decimal d)) = float d @@ -173,7 +174,7 @@ instance ( FreeVariables term where -- Explicit type signature is necessary here because we're passing all sorts of things -- to these comparison functions. - go :: (Ord a, MonadValue term value m) => a -> a -> m value + go :: (Ord a, MonadValue value m) => a -> a -> m value go l r = case comparator of Concrete f -> boolean (f l r) Generalized -> integer (orderingToInt (compare l r)) @@ -200,7 +201,7 @@ instance ( FreeVariables term loop = fix -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue term Type m where +instance (Alternative m, MonadAnalysis term Type m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadStore Type m) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 740c49f32..31d90fbb0 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -26,7 +26,7 @@ class Evaluatable constr where eval :: ( FreeVariables term , MonadAddressable (LocationFor value) value m , MonadAnalysis term value m - , MonadValue term value m + , MonadValue value m ) => SubtermAlgebra constr term (m value) default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) @@ -60,6 +60,6 @@ instance MonadEnvironment value m => Semigroup (Imperative m a) where env <- getGlobalEnv localEnv (<> env) b -instance MonadValue term value m => Monoid (Imperative m value) where +instance MonadValue value m => Monoid (Imperative m value) where mempty = Imperative unit mappend = (<>) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 78bfa3e9f..cfdcbb331 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -59,7 +59,7 @@ evaluateFile :: forall value term effects , FreeVariables term , effects ~ RequiredEffects term value (Evaluating term value effects) , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue term value (Evaluating term value effects) + , MonadValue value (Evaluating term value effects) , Recursive term ) => Parser term @@ -73,7 +73,7 @@ evaluateFiles :: forall value term effects , FreeVariables term , effects ~ RequiredEffects term value (Evaluating term value effects) , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue term value (Evaluating term value effects) + , MonadValue value (Evaluating term value effects) , Recursive term ) => Parser term From 8378c0aed3b2d6f96b87244f856e736c8d05fd98 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 20:27:15 -0400 Subject: [PATCH 071/104] Correct the docs for Closure. --- src/Data/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 8d1377ca7..9fdbf4adb 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -46,7 +46,7 @@ prjPair = bitraverse prjValue prjValue -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. --- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body. +-- | A function value consisting of a list of parameters, a label to jump to the body of the function, and an environment of bindings captured by the body. data Closure location value = Closure [Name] Int (Environment location value) deriving (Eq, Generic1, Ord, Show) From f68da4275461ab1ada64acabc967cb559af1aefd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 20:30:26 -0400 Subject: [PATCH 072/104] Simplify the superclasses of MonadValue. --- src/Control/Abstract/Value.hs | 14 ++++++-------- src/Data/Abstract/Evaluatable.hs | 2 +- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8280c0b35..07e7504b7 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -26,7 +26,7 @@ data Comparator -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEnvironment value m, MonadFail m, MonadStore value m, Show value) => MonadValue value m where +class (Monad m, Show value) => MonadValue value m where -- | Construct an abstract unit value. -- TODO: This might be the same as the empty tuple for some value types unit :: m value @@ -84,7 +84,7 @@ class (MonadEnvironment value m, MonadFail m, MonadStore value m, Show value) => toBool :: MonadValue value m => value -> m Bool toBool v = ifthenelse v (pure True) (pure False) -forLoop :: MonadValue value m +forLoop :: (MonadEnvironment value m, MonadValue value m) => m value -- | Initial statement -> m value -- | Condition -> m value -- | Increment/stepper @@ -114,11 +114,9 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue unit -- | Construct a 'Value' wrapping the value arguments (if any). -instance ( MonadAddressable location (Value location) m +instance ( Monad m + , MonadAddressable location (Value location) m , MonadAnalysis term (Value location) m - , MonadEnvironment (Value location) m - , MonadFail m - , MonadStore (Value location) m , Show location ) => MonadValue (Value location) m where @@ -200,8 +198,8 @@ instance ( MonadAddressable location (Value location) m loop = fix --- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative m, MonadAnalysis term Type m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadStore Type m) => MonadValue Type m where +-- | Discard the value arguments (if any), constructing a 'Type' instead. +instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadStore Type m) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 31d90fbb0..5455f0e0c 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -60,6 +60,6 @@ instance MonadEnvironment value m => Semigroup (Imperative m a) where env <- getGlobalEnv localEnv (<> env) b -instance MonadValue value m => Monoid (Imperative m value) where +instance (MonadEnvironment value m, MonadValue value m) => Monoid (Imperative m value) where mempty = Imperative unit mappend = (<>) From fcf44b5a37d7dd48314c48cbf6147dc0c5f2bdf5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 20:42:59 -0400 Subject: [PATCH 073/104] Rename Store to Heap. --- semantic.cabal | 2 +- src/Analysis/Abstract/Caching.hs | 20 ++++++------- src/Analysis/Abstract/Collecting.hs | 30 +++++++++---------- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Elaborating.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 10 +++---- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Addressable.hs | 20 ++++++------- src/Control/Abstract/Evaluator.hs | 26 ++++++++-------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Cache.hs | 28 ++++++++--------- src/Data/Abstract/Configuration.hs | 4 +-- src/Data/Abstract/Heap.hs | 45 ++++++++++++++++++++++++++++ src/Data/Abstract/Store.hs | 45 ---------------------------- src/Data/Abstract/Value.hs | 6 ++-- test/SpecHelpers.hs | 2 +- 16 files changed, 123 insertions(+), 123 deletions(-) create mode 100644 src/Data/Abstract/Heap.hs delete mode 100644 src/Data/Abstract/Store.hs diff --git a/semantic.cabal b/semantic.cabal index 447eeddd8..69f597ece 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -47,10 +47,10 @@ library , Data.Abstract.Environment , Data.Abstract.Evaluatable , Data.Abstract.FreeVariables + , Data.Abstract.Heap , Data.Abstract.Live , Data.Abstract.ModuleTable , Data.Abstract.Number - , Data.Abstract.Store , Data.Abstract.Type , Data.Abstract.Value -- General datatype definitions & generic algorithms diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index cf8fcf354..425d1328e 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -6,7 +6,7 @@ module Analysis.Abstract.Caching import Control.Abstract.Analysis import Data.Abstract.Cache import Data.Abstract.Configuration -import Data.Abstract.Store +import Data.Abstract.Heap import Data.Abstract.Value import Data.Monoid (Alt (..)) import Prologue @@ -28,21 +28,21 @@ newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value eff deriving instance MonadControl term (m term value effects) => MonadControl term (Caching m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects) -deriving instance MonadStore value (m term value effects) => MonadStore value (Caching m term value effects) +deriving instance MonadHeap value (m term value effects) => MonadHeap value (Caching m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects) -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons. class MonadEvaluator term value m => MonadCaching term value m where -- | Look up the set of values for a given configuration in the in-cache. - consultOracle :: ConfigurationFor term value -> m (Set (value, StoreFor value)) + consultOracle :: ConfigurationFor term value -> m (Set (value, HeapFor value)) -- | Run an action with the given in-cache. withOracle :: CacheFor term value -> m a -> m a -- | Look up the set of values for a given configuration in the out-cache. - lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, StoreFor value))) - -- | Run an action, caching its result and 'Store' under the given configuration. - caching :: ConfigurationFor term value -> Set (value, StoreFor value) -> m value -> m value + lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, HeapFor value))) + -- | Run an action, caching its result and 'Heap' under the given configuration. + caching :: ConfigurationFor term value -> Set (value, HeapFor value) -> m value -> m value -- | Run an action starting from an empty out-cache, and return the out-cache afterwards. isolateCache :: m a -> m (CacheFor term value) @@ -62,7 +62,7 @@ instance ( Effectful (m term value) lookupCache configuration = raise (cacheLookup configuration <$> get) caching configuration values action = do raise (modify (cacheSet configuration values)) - result <- (,) <$> action <*> getStore + result <- (,) <$> action <*> getHeap raise (modify (cacheInsert configuration result)) pure (fst result) @@ -98,7 +98,7 @@ instance ( Corecursive term c <- getConfiguration e -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge (\ prevCache -> isolateCache $ do - putStore (configurationStore c) + putHeap (configurationHeap c) -- We need to reset fresh generation so that this invocation converges. reset 0 -- This is subtle: though the calling context supports nondeterminism, we want @@ -125,5 +125,5 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Store (LocationFor value) value) -> m a -scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) +scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Heap (LocationFor value) value) -> m a +scatter = getAlt . foldMap (\ (value, heap') -> Alt (putHeap heap' *> pure value)) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index d986df0f0..6399b795e 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -6,8 +6,8 @@ module Analysis.Abstract.Collecting import Control.Abstract.Analysis import Data.Abstract.Address import Data.Abstract.Configuration +import Data.Abstract.Heap import Data.Abstract.Live -import Data.Abstract.Store import Data.Abstract.Value import Prologue @@ -16,7 +16,7 @@ newtype Collecting m term value (effects :: [* -> *]) a = Collecting (m term val deriving instance MonadControl term (m term value effects) => MonadControl term (Collecting m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Collecting m term value effects) -deriving instance MonadStore value (m term value effects) => MonadStore value (Collecting m term value effects) +deriving instance MonadHeap value (m term value effects) => MonadHeap value (Collecting m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Collecting m term value effects) instance ( Effectful (m term value) @@ -24,7 +24,7 @@ instance ( Effectful (m term value) , MonadEvaluator term value (m term value effects) ) => MonadEvaluator term value (Collecting m term value effects) where - getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore + getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getHeap instance ( Effectful (m term value) @@ -43,7 +43,7 @@ instance ( Effectful (m term value) analyzeTerm term = do roots <- askRoots v <- liftAnalyze analyzeTerm term - modifyStore (gc (roots <> valueRoots v)) + modifyHeap (gc (roots <> valueRoots v)) pure v @@ -56,27 +56,27 @@ askRoots = raise ask -- extraRoots roots = raise . local (<> roots) . lower --- | Collect any addresses in the store not rooted in or reachable from the given 'Live' set. +-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set. gc :: ( Ord (LocationFor value) , Foldable (Cell (LocationFor value)) , ValueRoots value ) - => LiveFor value -- ^ The set of addresses to consider rooted. - -> StoreFor value -- ^ A store to collect unreachable addresses within. - -> StoreFor value -- ^ A garbage-collected store. -gc roots store = storeRestrict store (reachable roots store) + => LiveFor value -- ^ The set of addresses to consider rooted. + -> HeapFor value -- ^ A heap to collect unreachable addresses within. + -> HeapFor value -- ^ A garbage-collected heap. +gc roots heap = heapRestrict heap (reachable roots heap) --- | Compute the set of addresses reachable from a given root set in a given store. +-- | Compute the set of addresses reachable from a given root set in a given heap. reachable :: ( Ord (LocationFor value) , Foldable (Cell (LocationFor value)) , ValueRoots value ) - => LiveFor value -- ^ The set of root addresses. - -> StoreFor value -- ^ The store to trace addresses through. - -> LiveFor value -- ^ The set of addresses reachable from the root set. -reachable roots store = go mempty roots + => LiveFor value -- ^ The set of root addresses. + -> HeapFor value -- ^ The heap to trace addresses through. + -> LiveFor value -- ^ The set of addresses reachable from the root set. +reachable roots heap = go mempty roots where go seen set = case liveSplit set of Nothing -> seen - Just (a, as) -> go (liveInsert a seen) (case storeLookupAll a store of + Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen _ -> seen) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index a4ea0a3b1..cf004925d 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -14,7 +14,7 @@ newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value e deriving instance MonadControl term (m term value effects) => MonadControl term (DeadCode m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects) -deriving instance MonadStore value (m term value effects) => MonadStore value (DeadCode m term value effects) +deriving instance MonadHeap value (m term value effects) => MonadHeap value (DeadCode m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects) diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs index 2383aac42..38f9d6cee 100644 --- a/src/Analysis/Abstract/Elaborating.hs +++ b/src/Analysis/Abstract/Elaborating.hs @@ -13,7 +13,7 @@ newtype Elaborating m term value (effects :: [* -> *]) a = Elaborating (m term v deriving instance MonadControl term (m term value effects) => MonadControl term (Elaborating m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Elaborating m term value effects) -deriving instance MonadStore value (m term value effects) => MonadStore value (Elaborating m term value effects) +deriving instance MonadHeap value (m term value effects) => MonadHeap value (Elaborating m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Elaborating m term value effects) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Elaborating m term value effects) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 1ae3843af..8f131fffd 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -81,7 +81,7 @@ type EvaluatingEffects term value = '[ Fail -- Failure with an error message , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) , State (EnvironmentFor value) -- Global (imperative) environment - , State (StoreFor value) -- The heap + , State (HeapFor value) -- The heap , Reader (ModuleTable [term]) -- Cache of unevaluated modules , State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules @@ -110,9 +110,9 @@ instance Members '[State (Map Name (Name, Maybe (Address (LocationFor value) val askLocalEnv = raise ask localEnv f a = raise (local f (lower a)) -instance Member (State (StoreFor value)) effects => MonadStore value (Evaluating term value effects) where - getStore = raise get - putStore = raise . put +instance Member (State (HeapFor value)) effects => MonadHeap value (Evaluating term value effects) where + getHeap = raise get + putHeap = raise . put instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentFor value))] effects => MonadModuleTable term value (Evaluating term value effects) where getModuleTable = raise get @@ -122,7 +122,7 @@ instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentF localModuleTable f a = raise (local f (lower a)) instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where - getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore + getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getHeap instance ( Evaluatable (Base term) , FreeVariables term diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 6f43d3619..d21f8b3c3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -19,7 +19,7 @@ newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing deriving instance MonadControl term (m term value effects) => MonadControl term (Tracing trace m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects) -deriving instance MonadStore value (m term value effects) => MonadStore value (Tracing trace m term value effects) +deriving instance MonadHeap value (m term value effects) => MonadHeap value (Tracing trace m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 66b76919f..d9c38504e 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -7,14 +7,14 @@ import Control.Monad ((<=<)) import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.FreeVariables -import Data.Abstract.Store +import Data.Abstract.Heap import Data.Abstract.Value import Data.Foldable (asum, toList) import Data.Semigroup import Data.Semigroup.Reducer import Prelude hiding (fail) --- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. +-- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where deref :: Address l value -> m value @@ -25,7 +25,7 @@ class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => M -- 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 , MonadAddressable (LocationFor value) value m - , MonadStore value m + , MonadHeap value m , Semigroup (CellFor value) ) => term @@ -38,7 +38,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | 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 - , MonadStore value m + , MonadHeap value m ) => Name -> value @@ -52,7 +52,7 @@ lookupOrAlloc' name v env = do letrec :: ( MonadAddressable (LocationFor value) value m , MonadEnvironment value m - , MonadStore value m + , MonadHeap value m ) => Name -> m value @@ -67,18 +67,18 @@ letrec name body = do -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (MonadFail m, LocationFor value ~ Precise, MonadStore value m) => MonadAddressable Precise value m where - deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup +instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadAddressable Precise value m where + deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getHeap . heapLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). uninitializedAddress :: MonadFail m => m a uninitializedAddress = fail "uninitialized address" - alloc _ = fmap (Address . Precise . storeSize) getStore + alloc _ = fmap (Address . Precise . heapSize) getHeap -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, LocationFor value ~ Monovariant, MonadStore value m, Ord value) => MonadAddressable Monovariant value m where - deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup +instance (Alternative m, LocationFor value ~ Monovariant, MonadHeap value m, Ord value) => MonadAddressable Monovariant value m where + deref = asum . maybe [] (map pure . toList) <=< flip fmap getHeap . heapLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 51cb39210..1b2cf4192 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -3,8 +3,8 @@ module Control.Abstract.Evaluator ( MonadEvaluator(..) , MonadEnvironment(..) , modifyGlobalEnv -, MonadStore(..) -, modifyStore +, MonadHeap(..) +, modifyHeap , assign , MonadModuleTable(..) , modifyModuleTable @@ -14,8 +14,8 @@ module Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Configuration import Data.Abstract.FreeVariables +import Data.Abstract.Heap import Data.Abstract.ModuleTable -import Data.Abstract.Store import Data.Abstract.Value import Data.Semigroup.Reducer import Prelude hiding (fail) @@ -31,7 +31,7 @@ class ( MonadControl term m , MonadEnvironment value m , MonadFail m , MonadModuleTable term value m - , MonadStore value m + , MonadHeap value m ) => MonadEvaluator term value m | m -> term, m -> value where -- | Get the current 'Configuration' with a passed-in term. @@ -65,27 +65,27 @@ modifyGlobalEnv f = do -- | A 'Monad' abstracting a heap of values. -class Monad m => MonadStore value m | m -> value where +class Monad m => MonadHeap value m | m -> value where -- | Retrieve the heap. - getStore :: m (StoreFor value) + getHeap :: m (HeapFor value) -- | Set the heap. - putStore :: StoreFor value -> m () + putHeap :: HeapFor value -> m () -- | Update the heap. -modifyStore :: MonadStore value m => (StoreFor value -> StoreFor value) -> m () -modifyStore f = do - s <- getStore - putStore $! f s +modifyHeap :: MonadHeap value m => (HeapFor value -> HeapFor value) -> m () +modifyHeap f = do + s <- getHeap + putHeap $! f s -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor value) - , MonadStore value m + , MonadHeap value m , Reducer value (CellFor value) ) => Address (LocationFor value) value -> value -> m () -assign address = modifyStore . storeInsert address +assign address = modifyHeap . heapInsert address -- | A 'Monad' abstracting tables of modules available for import. diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 07e7504b7..b7aaccb5b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -199,7 +199,7 @@ instance ( Monad m loop = fix -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadStore Type m) => MonadValue Type m where +instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Type m) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index f7c9550b1..34660dcb2 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -3,30 +3,30 @@ module Data.Abstract.Cache where import Data.Abstract.Address import Data.Abstract.Configuration -import Data.Abstract.Store +import Data.Abstract.Heap import Data.Map.Monoidal as Monoidal import Prologue --- | A map of 'Configuration's to 'Set's of resulting values & 'Store's. -newtype Cache l t v = Cache { unCache :: Monoidal.Map (Configuration l t v) (Set (v, Store l v)) } +-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's. +newtype Cache l t v = Cache { unCache :: Monoidal.Map (Configuration l t v) (Set (v, Heap l v)) } deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v) deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Semigroup (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Monoid (Cache l t v) -deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Reducer (Configuration l t v, (v, Store l v)) (Cache l t v) +deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Reducer (Configuration l t v, (v, Heap l v)) (Cache l t v) --- | Look up the resulting value & 'Store' for a given 'Configuration'. -cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Store l v)) +-- | Look up the resulting value & 'Heap' for a given 'Configuration'. +cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Heap l v)) cacheLookup key = Monoidal.lookup key . unCache --- | Set the resulting value & 'Store' for a given 'Configuration', overwriting any previous entry. -cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set (v, Store l v) -> Cache l t v -> Cache l t v +-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry. +cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set (v, Heap l v) -> Cache l t v -> Cache l t v cacheSet key value = Cache . Monoidal.insert key value . unCache --- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry. -cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v +-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry. +cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Heap l v) -> Cache l t v -> Cache l t v cacheInsert = curry cons @@ -40,7 +40,7 @@ instance (Show l, Show t, Show1 (Cell l)) => Show1 (Cache l t) where liftShowsPrec spV slV d = showsUnaryWith (liftShowsPrec2 spKey slKey (liftShowsPrec spPair slPair) (liftShowList spPair slPair)) "Cache" d . unCache where spKey = liftShowsPrec spV slV slKey = liftShowList spV slV - spPair = liftShowsPrec2 spV slV spStore slStore - slPair = liftShowList2 spV slV spStore slStore - spStore = liftShowsPrec spV slV - slStore = liftShowList spV slV + spPair = liftShowsPrec2 spV slV spHeap slHeap + slPair = liftShowList2 spV slV spHeap slHeap + spHeap = liftShowsPrec spV slV + slHeap = liftShowList spV slV diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 0028c09f8..f08aef5c5 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -3,8 +3,8 @@ module Data.Abstract.Configuration where import Data.Abstract.Address import Data.Abstract.Environment +import Data.Abstract.Heap import Data.Abstract.Live -import Data.Abstract.Store import Data.Abstract.Value import Prologue @@ -17,7 +17,7 @@ data Configuration l t v { configurationTerm :: t -- ^ The “instruction,” i.e. the current term to evaluate. , configurationRoots :: Live l v -- ^ The set of rooted addresses. , configurationEnvironment :: Environment l v -- ^ The environment binding any free variables in 'configurationTerm'. - , configurationStore :: Store l v -- ^ The store of values. + , configurationHeap :: Heap l v -- ^ The heap of values. } deriving (Generic1) diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs new file mode 100644 index 000000000..8f02ce79f --- /dev/null +++ b/src/Data/Abstract/Heap.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} +module Data.Abstract.Heap where + +import Data.Abstract.Address +import Data.Abstract.Live +import qualified Data.Map.Monoidal as Monoidal +import Data.Semigroup.Reducer +import Prologue + +-- | A map of addresses onto cells holding their values. +newtype Heap l a = Heap { unStore :: Monoidal.Map l (Cell l a) } + deriving (Generic1) + +deriving instance (Eq l, Eq (Cell l a)) => Eq (Heap l a) +deriving instance (Ord l, Ord (Cell l a)) => Ord (Heap l a) +deriving instance (Show l, Show (Cell l a)) => Show (Heap l a) +instance (Eq l, Eq1 (Cell l)) => Eq1 (Heap l) where liftEq = genericLiftEq +instance (Ord l, Ord1 (Cell l)) => Ord1 (Heap l) where liftCompare = genericLiftCompare +instance (Show l, Show1 (Cell l)) => Show1 (Heap l) where liftShowsPrec = genericLiftShowsPrec +deriving instance Foldable (Cell l) => Foldable (Heap l) +deriving instance Functor (Cell l) => Functor (Heap l) +deriving instance Traversable (Cell l) => Traversable (Heap l) +deriving instance (Ord l, Semigroup (Cell l a)) => Semigroup (Heap l a) +deriving instance (Ord l, Semigroup (Cell l a)) => Monoid (Heap l a) +deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Heap l a) + +-- | Look up the cell of values for an 'Address' in a 'Heap', if any. +heapLookup :: Ord l => Address l a -> Heap l a -> Maybe (Cell l a) +heapLookup (Address address) = Monoidal.lookup address . unStore + +-- | Look up the list of values stored for a given address, if any. +heapLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Heap l a -> Maybe [a] +heapLookupAll address = fmap toList . heapLookup address + +-- | Append a value onto the cell for a given address, inserting a new cell if none existed. +heapInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Heap l a -> Heap l a +heapInsert (Address address) value = flip snoc (address, value) + +-- | The number of addresses extant in a 'Heap'. +heapSize :: Heap l a -> Int +heapSize = Monoidal.size . unStore + +-- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest). +heapRestrict :: Ord l => Heap l a -> Live l a -> Heap l a +heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m) diff --git a/src/Data/Abstract/Store.hs b/src/Data/Abstract/Store.hs deleted file mode 100644 index d92847036..000000000 --- a/src/Data/Abstract/Store.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} -module Data.Abstract.Store where - -import Data.Abstract.Address -import Data.Abstract.Live -import qualified Data.Map.Monoidal as Monoidal -import Data.Semigroup.Reducer -import Prologue - --- | A map of addresses onto cells holding their values. -newtype Store l a = Store { unStore :: Monoidal.Map l (Cell l a) } - deriving (Generic1) - -deriving instance (Eq l, Eq (Cell l a)) => Eq (Store l a) -deriving instance (Ord l, Ord (Cell l a)) => Ord (Store l a) -deriving instance (Show l, Show (Cell l a)) => Show (Store l a) -instance (Eq l, Eq1 (Cell l)) => Eq1 (Store l) where liftEq = genericLiftEq -instance (Ord l, Ord1 (Cell l)) => Ord1 (Store l) where liftCompare = genericLiftCompare -instance (Show l, Show1 (Cell l)) => Show1 (Store l) where liftShowsPrec = genericLiftShowsPrec -deriving instance Foldable (Cell l) => Foldable (Store l) -deriving instance Functor (Cell l) => Functor (Store l) -deriving instance Traversable (Cell l) => Traversable (Store l) -deriving instance (Ord l, Semigroup (Cell l a)) => Semigroup (Store l a) -deriving instance (Ord l, Semigroup (Cell l a)) => Monoid (Store l a) -deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Store l a) - --- | Look up the cell of values for an 'Address' in a 'Store', if any. -storeLookup :: Ord l => Address l a -> Store l a -> Maybe (Cell l a) -storeLookup (Address address) = Monoidal.lookup address . unStore - --- | Look up the list of values stored for a given address, if any. -storeLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Store l a -> Maybe [a] -storeLookupAll address = fmap toList . storeLookup address - --- | Append a value onto the cell for a given address, inserting a new cell if none existed. -storeInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Store l a -> Store l a -storeInsert (Address address) value = flip snoc (address, value) - --- | The number of addresses extant in a 'Store'. -storeSize :: Store l a -> Int -storeSize = Monoidal.size . unStore - --- | Restrict a 'Store' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest). -storeRestrict :: Ord l => Store l a -> Live l a -> Store l a -storeRestrict (Store m) roots = Store (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 9fdbf4adb..73915e9b1 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -3,8 +3,8 @@ module Data.Abstract.Value where import Data.Abstract.Address import Data.Abstract.Environment -import Data.Abstract.Store import Data.Abstract.FreeVariables +import Data.Abstract.Heap import Data.Abstract.Live import Data.Abstract.Number import qualified Data.Abstract.Type as Type @@ -125,8 +125,8 @@ instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec -- | The environment for an abstract value type. type EnvironmentFor v = Environment (LocationFor v) v --- | The store for an abstract value type. -type StoreFor v = Store (LocationFor v) v +-- | The 'Heap' for an abstract value type. +type HeapFor value = Heap (LocationFor value) value -- | The cell for an abstract value type. type CellFor value = Cell (LocationFor value) value diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index d3752cf8a..568fb4276 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -12,8 +12,8 @@ module SpecHelpers ( import Data.Abstract.Address as X import Data.Abstract.Environment as X import Data.Abstract.FreeVariables as X +import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X -import Data.Abstract.Store as X import Data.Blob as X import Data.Functor.Listable as X import Data.Language as X From 6831bc2502e730dedeacce9edc2067f8b1079364 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 21:40:43 -0400 Subject: [PATCH 074/104] Simplify the language extensions. --- src/Data/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 73915e9b1..182624649 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-} +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-} module Data.Abstract.Value where import Data.Abstract.Address From f575c05257de0d024ff626388d49c8037534d7dd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:01:23 -0400 Subject: [PATCH 075/104] :fire: Elaborating for now. --- semantic.cabal | 1 - src/Analysis/Abstract/Elaborating.hs | 31 ---------------------------- 2 files changed, 32 deletions(-) delete mode 100644 src/Analysis/Abstract/Elaborating.hs diff --git a/semantic.cabal b/semantic.cabal index 69f597ece..80601fe49 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -18,7 +18,6 @@ library Analysis.Abstract.Caching , Analysis.Abstract.Collecting , Analysis.Abstract.Dead - , Analysis.Abstract.Elaborating , Analysis.Abstract.Evaluating , Analysis.Abstract.Tracing , Analysis.ConstructorName diff --git a/src/Analysis/Abstract/Elaborating.hs b/src/Analysis/Abstract/Elaborating.hs deleted file mode 100644 index 38f9d6cee..000000000 --- a/src/Analysis/Abstract/Elaborating.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} -module Analysis.Abstract.Elaborating -( type Elaborating -) where - -import Control.Abstract.Analysis -import Control.Abstract.Value -import Data.Term -import Prologue - -newtype Elaborating m term value (effects :: [* -> *]) a = Elaborating (m term value effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) - -deriving instance MonadControl term (m term value effects) => MonadControl term (Elaborating m term value effects) -deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Elaborating m term value effects) -deriving instance MonadHeap value (m term value effects) => MonadHeap value (Elaborating m term value effects) -deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Elaborating m term value effects) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Elaborating m term value effects) - -instance MonadAnalysis term value (m term value effects) - => MonadAnalysis term value (Elaborating m term value effects) where - type RequiredEffects term value (Elaborating m term value effects) = RequiredEffects term value (m term value effects) - analyzeTerm = liftAnalyze analyzeTerm - -instance ( elab ~ Term (Base term) value - , MonadAnalysis term elab (m term elab effects) - , Recursive term - , Show1 (Base term) - , Show value - ) - => MonadValue elab (Elaborating m term elab effects) where From 07ff06f2f0e5bcba03479652eb11704bb87404ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:08:57 -0400 Subject: [PATCH 076/104] :memo: Label. --- 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 1b2cf4192..8cf000d67 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -107,6 +107,7 @@ modifyModuleTable f = do putModuleTable $! f table +-- | The type of labels. type Label = Int class Monad m => MonadControl term m where From 6764d3110597e5272ea69cfb44ded3035aa76c7e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:09:02 -0400 Subject: [PATCH 077/104] Note a TODO for Label. --- 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 8cf000d67..37e423232 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -108,6 +108,7 @@ modifyModuleTable f = do -- | The type of labels. +-- TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels. type Label = Int class Monad m => MonadControl term m where From acd7051b344d2cb26e1d5fcc20bcafb7fb980b1f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:09:51 -0400 Subject: [PATCH 078/104] :memo: MonadControl. --- 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 37e423232..89919ad60 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -111,6 +111,7 @@ modifyModuleTable f = do -- TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels. type Label = Int +-- | A 'Monad' abstracting jumps in imperative control. class Monad m => MonadControl term m where label :: term -> m Label goto :: Label -> m term From 6e68f0115a58d629c2e140b5ac2e80d0503d07b4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:12:26 -0400 Subject: [PATCH 079/104] :memo: label. --- src/Control/Abstract/Evaluator.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 89919ad60..72215b7f6 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -113,5 +113,8 @@ type Label = Int -- | A 'Monad' abstracting jumps in imperative control. class Monad m => MonadControl term m where + -- | Allocate a 'Label' for the given @term@. + -- + -- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms. label :: term -> m Label goto :: Label -> m term From 84af53a4fa052876a62d6b3642e702424610b460 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:12:31 -0400 Subject: [PATCH 080/104] :memo: goto. --- 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 72215b7f6..1a0ea3d3c 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -117,4 +117,5 @@ class Monad m => MonadControl term m where -- -- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms. label :: term -> m Label + -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance). goto :: Label -> m term From 3c6d4f9976ab8249b4d416db30100798f559cc5e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:14:22 -0400 Subject: [PATCH 081/104] :fire: mentions of the obsolete *Value synonyms. --- test/Analysis/Go/Spec.hs | 2 +- test/Analysis/Python/Spec.hs | 2 +- test/Analysis/TypeScript/Spec.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index faf26ff28..1d03d91d7 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -34,7 +34,7 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/go/analysis/" evaluate entry = snd . fst . fst . fst <$> - evaluateFiles @GoValue goParser + evaluateFiles @(Value Precise) goParser [ fixtures <> entry , fixtures <> "foo/foo.go" , fixtures <> "bar/bar.go" diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 4f7baa1ec..baca662c0 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -38,7 +38,7 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = snd . fst . fst . fst <$> - evaluateFiles @PythonValue pythonParser + evaluateFiles @(Value Precise) pythonParser [ fixtures <> entry , fixtures <> "a.py" , fixtures <> "b/c.py" diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 3ecc7962a..e266d980a 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -35,7 +35,7 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/typescript/analysis/" evaluate entry = snd . fst . fst . fst <$> - evaluateFiles @TypeScriptValue typescriptParser + evaluateFiles @(Value Precise) typescriptParser [ fixtures <> entry , fixtures <> "a.ts" , fixtures <> "foo.ts" From 300af7ebde18da2286ee33c9e8569b8352c296a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:23:50 -0400 Subject: [PATCH 082/104] Correct the paths to the global env. --- test/Analysis/Go/Spec.hs | 2 +- test/Analysis/Python/Spec.hs | 2 +- test/Analysis/TypeScript/Spec.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 1d03d91d7..a7159092b 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -33,7 +33,7 @@ spec = parallel $ do where addr = Address . Precise fixtures = "test/fixtures/go/analysis/" - evaluate entry = snd . fst . fst . fst <$> + evaluate entry = snd . fst . fst . fst . fst <$> evaluateFiles @(Value Precise) goParser [ fixtures <> entry , fixtures <> "foo/foo.go" diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index baca662c0..2a03cf69d 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -37,7 +37,7 @@ spec = parallel $ do where addr = Address . Precise fixtures = "test/fixtures/python/analysis/" - evaluate entry = snd . fst . fst . fst <$> + evaluate entry = snd . fst . fst . fst . fst <$> evaluateFiles @(Value Precise) pythonParser [ fixtures <> entry , fixtures <> "a.py" diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index e266d980a..087af7185 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -34,7 +34,7 @@ spec = parallel $ do where addr = Address . Precise fixtures = "test/fixtures/typescript/analysis/" - evaluate entry = snd . fst . fst . fst <$> + evaluate entry = snd . fst . fst . fst . fst <$> evaluateFiles @(Value Precise) typescriptParser [ fixtures <> entry , fixtures <> "a.ts" From af21fa48fe060d546650efd4ee530128de4af229 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 10:36:21 -0400 Subject: [PATCH 083/104] :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 084/104] 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 085/104] 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 086/104] :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 087/104] 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 088/104] =?UTF-8?q?lookupOrAlloc=20doesn=E2=80=99t=20assig?= =?UTF-8?q?n.?= 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 089/104] 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 090/104] :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 From 527d157d90d402feae55adef6830bb92d5104cd6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:35:02 -0400 Subject: [PATCH 091/104] Pull uninitializedAddress out to the top level. --- src/Control/Abstract/Addressable.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index d9c38504e..899a791de 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -69,10 +69,6 @@ letrec name body = do -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadAddressable Precise value m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getHeap . heapLookup - where - -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). - uninitializedAddress :: MonadFail m => m a - uninitializedAddress = fail "uninitialized address" alloc _ = fmap (Address . Precise . heapSize) getHeap @@ -82,3 +78,7 @@ instance (Alternative m, LocationFor value ~ Monovariant, MonadHeap value m, Ord deref = asum . maybe [] (map pure . toList) <=< flip fmap getHeap . heapLookup alloc = pure . Address . Monovariant + +-- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). +uninitializedAddress :: MonadFail m => m a +uninitializedAddress = fail "uninitialized address" From 5a8b13c63b4673c0523d31d95375caea710d5058 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:41:57 -0400 Subject: [PATCH 092/104] Define a helper to look an address up in the heap. --- 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 1a0ea3d3c..50f5b683e 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -5,6 +5,7 @@ module Control.Abstract.Evaluator , modifyGlobalEnv , MonadHeap(..) , modifyHeap +, lookupHeap , assign , MonadModuleTable(..) , modifyModuleTable @@ -77,6 +78,10 @@ modifyHeap f = do s <- getHeap putHeap $! f s +-- | Look up the cell for the given 'Address' in the 'Heap'. +lookupHeap :: (MonadHeap value m, Ord (LocationFor value)) => Address (LocationFor value) value -> m (Maybe (CellFor value)) +lookupHeap = flip fmap getHeap . heapLookup + -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor value) , MonadHeap value m From 42b059d88ca2d575e47513a1c74218f9d0caeffb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:42:11 -0400 Subject: [PATCH 093/104] Define a helper to fold a collection in an Alternative context. --- src/Control/Abstract/Addressable.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 899a791de..e747d72b7 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -79,6 +79,10 @@ instance (Alternative m, LocationFor value ~ Monovariant, MonadHeap value m, Ord alloc = pure . Address . Monovariant +-- | Fold a collection by mapping each element onto an 'Alternative' action. +foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a +foldMapA f = getAlt . foldMap (Alt . f) + -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). uninitializedAddress :: MonadFail m => m a uninitializedAddress = fail "uninitialized address" From 6099ec037f0296e360c4ce3d23f830b96230a4e7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:42:33 -0400 Subject: [PATCH 094/104] Dereference using lookupHeap. --- src/Control/Abstract/Addressable.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index e747d72b7..57287c0d0 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -9,10 +9,11 @@ import Data.Abstract.Environment import Data.Abstract.FreeVariables import Data.Abstract.Heap import Data.Abstract.Value -import Data.Foldable (asum, toList) +import Data.Monoid (Alt(..)) import Data.Semigroup import Data.Semigroup.Reducer import Prelude hiding (fail) +import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where @@ -68,14 +69,14 @@ letrec name body = do -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadAddressable Precise value m where - deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getHeap . heapLookup + deref = maybe uninitializedAddress (pure . unLatest) <=< lookupHeap alloc _ = fmap (Address . Precise . heapSize) getHeap -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, LocationFor value ~ Monovariant, MonadHeap value m, Ord value) => MonadAddressable Monovariant value m where - deref = asum . maybe [] (map pure . toList) <=< flip fmap getHeap . heapLookup +instance (Alternative m, LocationFor value ~ Monovariant, MonadFail m, MonadHeap value m, Ord value) => MonadAddressable Monovariant value m where + deref = maybe uninitializedAddress (foldMapA pure) <=< lookupHeap alloc = pure . Address . Monovariant From ba84fffd567c1571b61169813b9206e51cdd013c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:46:38 -0400 Subject: [PATCH 095/104] Define deref using a helper function. --- src/Control/Abstract/Addressable.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 57287c0d0..5e1308300 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -69,17 +69,19 @@ letrec name body = do -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadAddressable Precise value m where - deref = maybe uninitializedAddress (pure . unLatest) <=< lookupHeap - + deref = derefWith (pure . unLatest) alloc _ = fmap (Address . Precise . heapSize) getHeap -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. instance (Alternative m, LocationFor value ~ Monovariant, MonadFail m, MonadHeap value m, Ord value) => MonadAddressable Monovariant value m where - deref = maybe uninitializedAddress (foldMapA pure) <=< lookupHeap - + deref = derefWith (foldMapA pure) alloc = pure . Address . Monovariant +-- | Dereference the given 'Address' in the heap, using the supplied function to act on the cell, or failing if the address is uninitialized. +derefWith :: (MonadFail m, MonadHeap value m, Ord (LocationFor value)) => (CellFor value -> m a) -> Address (LocationFor value) value -> m a +derefWith with = maybe uninitializedAddress with <=< lookupHeap + -- | Fold a collection by mapping each element onto an 'Alternative' action. foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a foldMapA f = getAlt . foldMap (Alt . f) From 6fc1747652d23b1a9fe0e75b5c905acd298f5f78 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:48:06 -0400 Subject: [PATCH 096/104] Spell out the label field. --- src/Control/Abstract/Value.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 155f62e7f..d4c7cf552 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -193,13 +193,13 @@ instance ( Monad m injValue . Closure names l . bindEnv (foldr Set.delete (freeVariables body) names) <$> askLocalEnv apply op params = do - Closure names l env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) + Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) bindings <- foldr (\ (name, param) rest -> do v <- param a <- alloc name assign a v envInsert name a <$> rest) (pure env) (zip names params) - localEnv (mappend bindings) (goto l >>= evaluateTerm) + localEnv (mappend bindings) (goto label >>= evaluateTerm) loop = fix From 42ec0c8717698ee5a498aeca9febc3b319e26ce6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:49:59 -0400 Subject: [PATCH 097/104] Move Label into Data.Abstract.FreeVariables. --- src/Control/Abstract/Evaluator.hs | 4 ---- src/Data/Abstract/FreeVariables.hs | 5 +++++ src/Language/Go/Syntax.hs | 4 ++-- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 50f5b683e..d42b2aa94 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -112,10 +112,6 @@ modifyModuleTable f = do putModuleTable $! f table --- | The type of labels. --- TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels. -type Label = Int - -- | A 'Monad' abstracting jumps in imperative control. class Monad m => MonadControl term m where -- | Allocate a 'Label' for the given @term@. diff --git a/src/Data/Abstract/FreeVariables.hs b/src/Data/Abstract/FreeVariables.hs index 2e73218c2..55138f9e9 100644 --- a/src/Data/Abstract/FreeVariables.hs +++ b/src/Data/Abstract/FreeVariables.hs @@ -19,6 +19,11 @@ friendlyName :: Name -> ByteString friendlyName xs = intercalate "." (NonEmpty.toList xs) +-- | The type of labels. +-- TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels. +type Label = Int + + -- | Types which can contain unbound variables. class FreeVariables term where -- | The set of free variables in the given value. diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 904cbb2b1..27b67ce46 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.Go.Syntax where -import Prologue -import Data.Abstract.Evaluatable +import Data.Abstract.Evaluatable hiding (Label) import Diffing.Algorithm +import Prologue -- A composite literal in Go data Composite a = Composite { compositeType :: !a, compositeElement :: !a } From 0e5e84f35db36f863f2439447265dd25d9825f28 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:52:28 -0400 Subject: [PATCH 098/104] Use the Label type in Closure. --- src/Data/Abstract/Value.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index b1c7f7180..fcaf4b5ae 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -47,8 +47,8 @@ prjPair = bitraverse prjValue prjValue -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. --- | A function value consisting of a list of parameters, a label to jump to the body of the function, and an environment of bindings captured by the body. -data Closure location value = Closure [Name] Int (Environment location value) +-- | A function value consisting of a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body. +data Closure location value = Closure [Name] Label (Environment location value) deriving (Eq, Generic1, Ord, Show) instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq From 7fab2e26aa2d39fef32ed43d328a2ec7459c2c65 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:58:07 -0400 Subject: [PATCH 099/104] Specialize evaluateFile/evaluateFiles to Value Precise. --- src/Semantic/Util.hs | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index cfdcbb331..eac5e3b0a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -33,55 +33,55 @@ import qualified Language.Python.Assignment as Python import qualified Language.TypeScript.Assignment as TypeScript -- Ruby -evaluateRubyFile = evaluateFile @(Value Precise) rubyParser -evaluateRubyFiles = evaluateFiles @(Value Precise) rubyParser +evaluateRubyFile = evaluateFile rubyParser +evaluateRubyFiles = evaluateFiles rubyParser -- Go -evaluateGoFile = evaluateFile @(Value Precise) goParser -evaluateGoFiles = evaluateFiles @(Value Precise) goParser +evaluateGoFile = evaluateFile goParser +evaluateGoFiles = evaluateFiles goParser typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . snd <$> parseFile goParser path -- Python -evaluatePythonFile path = evaluate @(Value Precise) . snd <$> parseFile pythonParser path -evaluatePythonFiles = evaluateFiles @(Value Precise) pythonParser +evaluatePythonFile path = evaluate . snd <$> parseFile pythonParser path +evaluatePythonFiles = evaluateFiles pythonParser typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term (Value Precise)) . evaluateModule . snd <$> parseFile pythonParser path evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term (Value Precise)) . evaluateModule . snd <$> parseFile pythonParser path -- TypeScript typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . snd <$> parseFile typescriptParser path -evaluateTypeScriptFile = evaluateFile @(Value Precise) typescriptParser -evaluateTypeScriptFiles = evaluateFiles @(Value Precise) typescriptParser +evaluateTypeScriptFile = evaluateFile typescriptParser +evaluateTypeScriptFiles = evaluateFiles typescriptParser -- Evalute a single file. -evaluateFile :: forall value term effects +evaluateFile :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ RequiredEffects term value (Evaluating term value effects) - , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue value (Evaluating term value effects) + , effects ~ RequiredEffects term (Value Precise) (Evaluating term (Value Precise) effects) + , MonadAddressable Precise (Value Precise) (Evaluating term (Value Precise) effects) + , MonadValue (Value Precise) (Evaluating term (Value Precise) effects) , Recursive term ) => Parser term -> FilePath - -> IO (Final effects value) -evaluateFile parser path = runAnalysis @(Evaluating term value) . evaluateModule . snd <$> parseFile parser path + -> IO (Final effects (Value Precise)) +evaluateFile parser path = evaluate . snd <$> parseFile parser path -- Evaluate a list of files (head of file list is considered the entry point). -evaluateFiles :: forall value term effects +evaluateFiles :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ RequiredEffects term value (Evaluating term value effects) - , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue value (Evaluating term value effects) + , effects ~ RequiredEffects term (Value Precise) (Evaluating term (Value Precise) effects) + , MonadAddressable Precise (Value Precise) (Evaluating term (Value Precise) effects) + , MonadValue (Value Precise) (Evaluating term (Value Precise) effects) , Recursive term ) => Parser term -> [FilePath] - -> IO (Final effects value) + -> IO (Final effects (Value Precise)) evaluateFiles parser paths = do entry:xs <- traverse (parseFile parser) paths - pure $ evaluates @value xs entry + pure $ evaluates @(Value Precise) xs entry -- Read and parse a file. parseFile :: Parser term -> FilePath -> IO (Blob, term) From 4bd7bc54275220b569533a1e148d8f6e711a8bf4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 16:04:36 -0400 Subject: [PATCH 100/104] Remove the location parameter from Value. --- src/Control/Abstract/Value.hs | 6 +++--- src/Data/Abstract/Value.hs | 28 ++++++++++++++-------------- src/Semantic/Util.hs | 22 +++++++++++----------- test/Analysis/Go/Spec.hs | 2 +- test/Analysis/Python/Spec.hs | 2 +- test/Analysis/TypeScript/Spec.hs | 2 +- 6 files changed, 31 insertions(+), 31 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d4c7cf552..afb01920b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -118,11 +118,11 @@ doWhile body cond = loop $ \ continue -> body *> do -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Monad m - , MonadAddressable location (Value location) m - , MonadAnalysis term (Value location) m + , MonadAddressable location Value m + , MonadAnalysis term Value m , Show location ) - => MonadValue (Value location) m where + => MonadValue Value m where unit = pure . injValue $ Value.Unit integer = pure . injValue . Value.Integer . Number.Integer diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index fcaf4b5ae..7c17fcec8 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -13,10 +13,10 @@ import Prologue import Prelude hiding (Float, Integer, String, Rational, fail) import qualified Prelude -type ValueConstructors location +type ValueConstructors = '[Array , Boolean - , Closure location + , Closure , Float , Integer , String @@ -28,32 +28,32 @@ type ValueConstructors location -- | Open union of primitive values that terms can be evaluated to. -- Fix by another name. -newtype Value location = Value { deValue :: Union (ValueConstructors location) (Value location) } +newtype Value = Value { deValue :: Union ValueConstructors Value } deriving (Eq, Show, Ord) -- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'. -injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location +injValue :: (f :< ValueConstructors) => f Value -> Value injValue = Value . inj -- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper. -prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location)) +prjValue :: (f :< ValueConstructors) => Value -> Maybe (f Value) prjValue = prj . deValue -- | Convenience function for projecting two values. -prjPair :: (f :< ValueConstructors loc1 , g :< ValueConstructors loc2) - => (Value loc1, Value loc2) - -> Maybe (f (Value loc1), g (Value loc2)) +prjPair :: (f :< ValueConstructors , g :< ValueConstructors) + => (Value, Value) + -> Maybe (f Value, g Value) prjPair = bitraverse prjValue prjValue -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. -- | A function value consisting of a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body. -data Closure location value = Closure [Name] Label (Environment location value) +data Closure value = Closure [Name] Label (Environment Precise value) deriving (Eq, Generic1, Ord, Show) -instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq -instance Ord location => Ord1 (Closure location) where liftCompare = genericLiftCompare -instance Show location => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec +instance Eq1 Closure where liftEq = genericLiftEq +instance Ord1 Closure where liftCompare = genericLiftCompare +instance Show1 Closure where liftShowsPrec = genericLiftShowsPrec -- | The unit value. Typically used to represent the result of imperative statements. data Unit value = Unit @@ -145,7 +145,7 @@ type LiveFor value = Live (LocationFor value) value -- | 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) = location + LocationFor Value = Precise LocationFor Type.Type = Monovariant -- | Value types, e.g. closures, which can root a set of addresses. @@ -153,7 +153,7 @@ class ValueRoots value where -- | Compute the set of addresses rooted by a given value. valueRoots :: value -> LiveFor value -instance Ord location => ValueRoots (Value location) where +instance ValueRoots Value where valueRoots v | Just (Closure _ _ env) <- prjValue v = envAll env | otherwise = mempty diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index eac5e3b0a..e41b90f52 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -45,8 +45,8 @@ typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluate evaluatePythonFile path = evaluate . snd <$> parseFile pythonParser path evaluatePythonFiles = evaluateFiles pythonParser typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term (Value Precise)) . evaluateModule . snd <$> parseFile pythonParser path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term (Value Precise)) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path -- TypeScript typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . snd <$> parseFile typescriptParser path @@ -57,31 +57,31 @@ evaluateTypeScriptFiles = evaluateFiles typescriptParser evaluateFile :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ RequiredEffects term (Value Precise) (Evaluating term (Value Precise) effects) - , MonadAddressable Precise (Value Precise) (Evaluating term (Value Precise) effects) - , MonadValue (Value Precise) (Evaluating term (Value Precise) effects) + , effects ~ RequiredEffects term Value (Evaluating term Value effects) + , MonadAddressable Precise Value (Evaluating term Value effects) + , MonadValue Value (Evaluating term Value effects) , Recursive term ) => Parser term -> FilePath - -> IO (Final effects (Value Precise)) + -> IO (Final effects Value) evaluateFile parser path = evaluate . snd <$> parseFile parser path -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ RequiredEffects term (Value Precise) (Evaluating term (Value Precise) effects) - , MonadAddressable Precise (Value Precise) (Evaluating term (Value Precise) effects) - , MonadValue (Value Precise) (Evaluating term (Value Precise) effects) + , effects ~ RequiredEffects term Value (Evaluating term Value effects) + , MonadAddressable Precise Value (Evaluating term Value effects) + , MonadValue Value (Evaluating term Value effects) , Recursive term ) => Parser term -> [FilePath] - -> IO (Final effects (Value Precise)) + -> IO (Final effects Value) evaluateFiles parser paths = do entry:xs <- traverse (parseFile parser) paths - pure $ evaluates @(Value Precise) xs entry + pure $ evaluates @Value xs entry -- Read and parse a file. parseFile :: Parser term -> FilePath -> IO (Blob, term) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index a7159092b..1e2d044ac 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -34,7 +34,7 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/go/analysis/" evaluate entry = snd . fst . fst . fst . fst <$> - evaluateFiles @(Value Precise) goParser + evaluateFiles goParser [ fixtures <> entry , fixtures <> "foo/foo.go" , fixtures <> "bar/bar.go" diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 2a03cf69d..84df0f177 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -38,7 +38,7 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = snd . fst . fst . fst . fst <$> - evaluateFiles @(Value Precise) pythonParser + evaluateFiles pythonParser [ fixtures <> entry , fixtures <> "a.py" , fixtures <> "b/c.py" diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 087af7185..0deef4129 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -35,7 +35,7 @@ spec = parallel $ do addr = Address . Precise fixtures = "test/fixtures/typescript/analysis/" evaluate entry = snd . fst . fst . fst . fst <$> - evaluateFiles @(Value Precise) typescriptParser + evaluateFiles typescriptParser [ fixtures <> entry , fixtures <> "a.ts" , fixtures <> "foo.ts" From c81fafb184b229411e2826a70a28a9c992faf330 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 16:14:51 -0400 Subject: [PATCH 101/104] Move foldMapA into the Prologue. --- src/Control/Abstract/Addressable.hs | 6 +----- src/Prologue.hs | 12 +++++++++--- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 98788eec6..f96f02a3a 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -9,9 +9,9 @@ import Data.Abstract.Environment import Data.Abstract.FreeVariables import Data.Abstract.Heap import Data.Abstract.Value -import Data.Monoid (Alt(..)) import Data.Semigroup.Reducer import Prelude hiding (fail) +import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where @@ -59,10 +59,6 @@ instance (Alternative m, LocationFor value ~ Monovariant, MonadFail m, MonadHeap derefWith :: (MonadFail m, MonadHeap value m, Ord (LocationFor value)) => (CellFor value -> m a) -> Address (LocationFor value) value -> m a derefWith with = maybe uninitializedAddress with <=< lookupHeap --- | Fold a collection by mapping each element onto an 'Alternative' action. -foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a -foldMapA f = getAlt . foldMap (Alt . f) - -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). uninitializedAddress :: MonadFail m => m a uninitializedAddress = fail "uninitialized address" diff --git a/src/Prologue.hs b/src/Prologue.hs index cff645a5b..5d70b0572 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -1,7 +1,8 @@ {-# LANGUAGE UndecidableInstances #-} -module Prologue ( - module X -, ) where +module Prologue +( module X +, foldMapA +) where import Data.Bifunctor.Join as X @@ -11,6 +12,7 @@ import Data.IntMap as X (IntMap) import Data.IntSet as X (IntSet) import Data.Ix as X (Ix(..)) import Data.Map as X (Map) +import Data.Monoid (Alt(..)) import Data.Maybe as X import Data.Sequence as X (Seq) import Data.Set as X (Set) @@ -67,3 +69,7 @@ import Data.Hashable as X ( -- Generics import GHC.Generics as X hiding (moduleName) import GHC.Stack as X + +-- | Fold a collection by mapping each element onto an 'Alternative' action. +foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a +foldMapA f = getAlt . foldMap (Alt . f) From 0f8b874fb9f54313172c51652e70c3427ded46ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 16:15:40 -0400 Subject: [PATCH 102/104] Define scatter using foldMapA. --- src/Analysis/Abstract/Caching.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 425d1328e..77b6c7d2b 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -8,7 +8,6 @@ import Data.Abstract.Cache import Data.Abstract.Configuration import Data.Abstract.Heap import Data.Abstract.Value -import Data.Monoid (Alt (..)) import Prologue -- | The effects necessary for caching analyses. @@ -126,4 +125,4 @@ converge f = loop -- | Nondeterministically write each of a collection of stores & return their associated results. scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Heap (LocationFor value) value) -> m a -scatter = getAlt . foldMap (\ (value, heap') -> Alt (putHeap heap' *> pure value)) +scatter = foldMapA (\ (value, heap') -> putHeap heap' *> pure value) From 1ab4bd0c9d5eebb15427ea3359fe6384ec724210 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 15 Mar 2018 16:25:53 -0400 Subject: [PATCH 103/104] Add maybeM and maybeFail. `maybeM act may` returns the `Just` in `may` or runs `act`. `maybeFail str may` fails with `str` as an error or extracts the `Just`. These combinators are so useful that I don't know why they're not in the Prelude or some library. I use them constantly. --- src/Prologue.hs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/Prologue.hs b/src/Prologue.hs index cff645a5b..004060fcf 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -1,7 +1,9 @@ {-# LANGUAGE UndecidableInstances #-} -module Prologue ( - module X -, ) where +module Prologue + ( module X + , maybeM + , maybeFail + ) where import Data.Bifunctor.Join as X @@ -67,3 +69,11 @@ import Data.Hashable as X ( -- Generics import GHC.Generics as X hiding (moduleName) import GHC.Stack as X + +-- Extract the 'Just' of a Maybe in an Applicative context or, given Nothing, run the provided action. +maybeM :: Applicative f => f a -> Maybe a -> f a +maybeM f = maybe f pure + +-- Either extract the 'Just' of a Maybe or invoke `fail` with the provided string. +maybeFail :: MonadFail m => String -> Maybe a -> m a +maybeFail s = maybeFail (X.fail s) From 8359d4d3e4ad06be4de4a979701505383edcc037 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 15 Mar 2018 16:32:48 -0400 Subject: [PATCH 104/104] oops --- src/Prologue.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Prologue.hs b/src/Prologue.hs index 88ad79ab8..61a799667 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -82,4 +82,4 @@ maybeM f = maybe f pure -- | Either extract the 'Just' of a 'Maybe' or invoke 'fail' with the provided string. maybeFail :: MonadFail m => String -> Maybe a -> m a -maybeFail s = maybeFail (X.fail s) +maybeFail s = maybeM (X.fail s)