From d4e46ed3355b7f52ea631a3c6e0058fe09f76c3d Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Mon, 9 Jul 2018 16:35:50 +1000 Subject: [PATCH 1/6] pass superclass addresses to klass --- src/Control/Abstract/Primitive.hs | 4 ++-- src/Control/Abstract/Value.hs | 4 ++-- src/Data/Abstract/Value/Concrete.hs | 2 +- src/Data/Syntax/Declaration.hs | 2 +- src/Language/TypeScript/Syntax.hs | 2 +- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 268850a6e..39107add0 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -32,14 +32,14 @@ defineClass :: ( AbstractValue address value effects , Member (Reader Span) effects ) => Name - -> [Name] + -> [address] -> Evaluator address value effects a -> Evaluator address value effects () defineClass name superclasses scope = define name $ do env <- locally $ do void scope Env.newEnv . Env.head <$> getEnv - klass name (map (string . formatName) superclasses) env + klass name superclasses env defineNamespace :: ( AbstractValue address value effects , HasCallStack diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7a713df4d..9eb6efdf5 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -128,8 +128,8 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV index :: value -> value -> Evaluator address value effects address -- | Build a class value from a name and environment. - klass :: Name -- ^ The new class's identifier - -> [value] -- ^ A list of superclasses + klass :: Name -- ^ The new class's identifier + -> [address] -- ^ A list of superclasses -> Environment address -- ^ The environment to capture -> Evaluator address value effects value diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 29ad5e8f7..c2f5347c2 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -120,7 +120,7 @@ instance ( Coercible body (Eff effects) klass n [] env = pure $ Class n env klass n supers env = do - product <- foldl mergeEnvs lowerBound . catMaybes <$> traverse scopedEnvironment supers + product <- foldl mergeEnvs lowerBound . catMaybes <$> traverse (deref >=> scopedEnvironment) supers pure $ Class n (mergeEnvs product env) namespace name env = do diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 7cf859c98..d79af6e68 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -163,7 +163,7 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Class where eval Class{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier) - supers <- traverse subtermValue classSuperclasses + supers <- traverse subtermAddress classSuperclasses (_, addr) <- letrec name $ do void $ subtermValue classBody classEnv <- newEnv . Env.head <$> getEnv diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 21fbf0227..725239876 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -742,7 +742,7 @@ instance Declarations a => Declarations (AbstractClass a) where instance Evaluatable AbstractClass where eval AbstractClass{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm abstractClassIdentifier) - supers <- traverse subtermValue classHeritage + supers <- traverse subtermAddress classHeritage (v, addr) <- letrec name $ do void $ subtermValue classBody classEnv <- newEnv . Env.head <$> getEnv From 095c10f3fdedcce4a368a6129013bf495073f7d2 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Mon, 9 Jul 2018 16:43:07 +1000 Subject: [PATCH 2/6] don't implement inheritance with mergeEnvs --- src/Control/Abstract/Primitive.hs | 8 +++----- src/Control/Abstract/Value.hs | 6 +++--- src/Data/Abstract/Environment.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 12 +++++------- src/Data/Syntax/Declaration.hs | 4 ++-- src/Language/TypeScript/Syntax.hs | 4 ++-- 6 files changed, 16 insertions(+), 20 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 39107add0..5eeebc4e0 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -35,11 +35,9 @@ defineClass :: ( AbstractValue address value effects -> [address] -> Evaluator address value effects a -> Evaluator address value effects () -defineClass name superclasses scope = define name $ do - env <- locally $ do - void scope - Env.newEnv . Env.head <$> getEnv - klass name superclasses env +defineClass name superclasses body = define name $ do + binds <- Env.head <$> locally (body >> getEnv) + klass name superclasses binds defineNamespace :: ( AbstractValue address value effects , HasCallStack diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 9eb6efdf5..780a34d1b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -128,9 +128,9 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV index :: value -> value -> Evaluator address value effects address -- | Build a class value from a name and environment. - klass :: Name -- ^ The new class's identifier - -> [address] -- ^ A list of superclasses - -> Environment address -- ^ The environment to capture + klass :: Name -- ^ The new class's identifier + -> [address] -- ^ A list of superclasses + -> Bindings address -- ^ The environment to capture -> Evaluator address value effects value -- | Build a namespace value from a name and environment stack diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index d742a8ef6..198580de9 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -36,7 +36,7 @@ import Prologue -- | A map of names to values. Represents a single scope level of an environment chain. newtype Bindings address = Bindings { unBindings :: Map.Map Name address } - deriving (Eq, Ord) + deriving (Eq, Ord, Show) instance Semigroup (Bindings address) where (<>) (Bindings a) (Bindings b) = Bindings (a <> b) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index c2f5347c2..b002581e7 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -2,7 +2,7 @@ module Data.Abstract.Value.Concrete where import Control.Abstract -import Data.Abstract.Environment (Environment, mergeEnvs) +import Data.Abstract.Environment (Environment, Bindings) import qualified Data.Abstract.Environment as Env import Data.Abstract.Name import qualified Data.Abstract.Number as Number @@ -24,7 +24,7 @@ data Value address body | Symbol Text | Tuple [address] | Array [address] - | Class Name (Environment address) + | Class Name [address] (Bindings address) | Namespace Name (Environment address) | KVPair (Value address body) (Value address body) | Hash [Value address body] @@ -118,10 +118,8 @@ instance ( Coercible body (Eff effects) tuple = pure . Tuple array = pure . Array - klass n [] env = pure $ Class n env - klass n supers env = do - product <- foldl mergeEnvs lowerBound . catMaybes <$> traverse (deref >=> scopedEnvironment) supers - pure $ Class n (mergeEnvs product env) + klass n supers binds = do + pure $ Class n supers binds namespace name env = do maybeAddr <- lookupEnv name @@ -132,7 +130,7 @@ instance ( Coercible body (Eff effects) | otherwise = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace") scopedEnvironment o - | Class _ env <- o = pure (Just env) + | Class _ _ env <- o = pure . Just . Env.newEnv $ env | Namespace _ env <- o = pure (Just env) | otherwise = pure Nothing diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index d79af6e68..148127c94 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -166,8 +166,8 @@ instance Evaluatable Class where supers <- traverse subtermAddress classSuperclasses (_, addr) <- letrec name $ do void $ subtermValue classBody - classEnv <- newEnv . Env.head <$> getEnv - klass name supers classEnv + classBinds <- Env.head <$> getEnv + klass name supers classBinds bind name addr pure (Rval addr) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 725239876..f515fe218 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -745,8 +745,8 @@ instance Evaluatable AbstractClass where supers <- traverse subtermAddress classHeritage (v, addr) <- letrec name $ do void $ subtermValue classBody - classEnv <- newEnv . Env.head <$> getEnv - klass name supers classEnv + classBinds <- Env.head <$> getEnv + klass name supers classBinds rvalBox =<< (v <$ bind name addr) From ff24ecbe1fbdf170253e123daedd16ff474df58d Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Tue, 10 Jul 2018 17:12:56 +1000 Subject: [PATCH 3/6] rematerialize environment for class in scopedEnvironment --- src/Data/Abstract/Value/Concrete.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index b002581e7..413fa0447 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances, LambdaCase #-} module Data.Abstract.Value.Concrete where import Control.Abstract @@ -130,9 +130,13 @@ instance ( Coercible body (Eff effects) | otherwise = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace") scopedEnvironment o - | Class _ _ env <- o = pure . Just . Env.newEnv $ env + | Class _ supers binds <- o = (Just . Env.Environment . (binds :|)) <$> ancestorBinds supers | Namespace _ env <- o = pure (Just env) | otherwise = pure Nothing + where ancestorBinds = (pure . concat) <=< traverse (deref >=> \case + Class _ supers binds -> (binds :) <$> ancestorBinds supers + Namespace _ env -> pure . toList . Env.unEnvironment $ env + _ -> pure []) asString v | String n <- v = pure n From 455068bbd7328c2cdb79e8631c4e4b7d504aa6d9 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 11 Jul 2018 13:56:45 +1000 Subject: [PATCH 4/6] changed scopedEnvironment and evaluateInScopedEnv to take address --- src/Control/Abstract/Value.hs | 10 +++++----- src/Data/Abstract/Value/Concrete.hs | 7 +++---- src/Data/Syntax/Expression.hs | 2 +- src/Language/PHP/Syntax.hs | 6 ++++-- src/Language/Ruby/Syntax.hs | 4 ++-- 5 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 780a34d1b..2048a0bb7 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -141,7 +141,7 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV -> Evaluator address value effects value -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). - scopedEnvironment :: value -> Evaluator address value effects (Maybe (Environment address)) + scopedEnvironment :: address -> Evaluator address value effects (Maybe (Environment address)) -- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion. -- @@ -189,7 +189,7 @@ makeNamespace :: ( AbstractValue address value effects ) => Name -> address - -> Maybe value + -> Maybe address -> Evaluator address value effects value makeNamespace name addr super = do superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super @@ -203,11 +203,11 @@ makeNamespace name addr super = do evaluateInScopedEnv :: ( AbstractValue address value effects , Member (Env address) effects ) - => Evaluator address value effects value + => address -> Evaluator address value effects a -> Evaluator address value effects a evaluateInScopedEnv scopedEnvTerm term = do - scopedEnv <- scopedEnvTerm >>= scopedEnvironment + scopedEnv <- scopedEnvironment scopedEnvTerm maybe term (\ env -> locally (bindAll env *> term)) scopedEnv @@ -240,7 +240,7 @@ address :: ( AbstractValue address value effects => ValueRef address -> Evaluator address value effects address address (LvalLocal var) = variable var -address (LvalMember obj prop) = evaluateInScopedEnv (deref obj) (variable prop) +address (LvalMember ptr prop) = evaluateInScopedEnv ptr (variable prop) address (Rval addr) = pure addr -- | Evaluates a 'Subterm' to the address of its rval diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 413fa0447..1f480d80a 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -129,10 +129,9 @@ instance ( Coercible body (Eff effects) | Namespace _ env' <- v = pure env' | otherwise = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace") - scopedEnvironment o - | Class _ supers binds <- o = (Just . Env.Environment . (binds :|)) <$> ancestorBinds supers - | Namespace _ env <- o = pure (Just env) - | otherwise = pure Nothing + scopedEnvironment ptr = do + ancestors <- ancestorBinds [ptr] + pure (Env.Environment <$> nonEmpty ancestors) where ancestorBinds = (pure . concat) <=< traverse (deref >=> \case Class _ supers binds -> (binds :) <$> ancestorBinds supers Namespace _ env -> pure . toList . Env.unEnvironment $ env diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 6ebd10654..aa042a0b4 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -439,7 +439,7 @@ instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ScopeResolution where eval (ScopeResolution xs) = Rval <$> foldl1 f (fmap subtermAddress xs) - where f ns = evaluateInScopedEnv (ns >>= deref) + where f ns id = ns >>= flip evaluateInScopedEnv id -- | A non-null expression such as Typescript or Swift's ! expression. diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 4f7205451..4fd906d2f 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -200,7 +200,9 @@ instance Ord1 QualifiedName where liftCompare = genericLiftCompare instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedName where - eval (QualifiedName name iden) = Rval <$> evaluateInScopedEnv (subtermValue name) (subtermAddress iden) + eval (QualifiedName name iden) = do + namePtr <- subtermAddress name + Rval <$> evaluateInScopedEnv namePtr (subtermAddress iden) newtype NamespaceName a = NamespaceName (NonEmpty a) deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Diffable, Mergeable, FreeVariables1, Declarations1, ToJSONFields1) @@ -212,7 +214,7 @@ instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable NamespaceName where eval (NamespaceName xs) = Rval <$> foldl1 f (fmap subtermAddress xs) - where f ns = evaluateInScopedEnv (ns >>= deref) + where f ns id = ns >>= flip evaluateInScopedEnv id newtype ConstDeclaration a = ConstDeclaration [a] deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 8afd9276c..635b97a91 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -54,7 +54,7 @@ instance Evaluatable Send where let sel = case sendSelector of Just sel -> subtermAddress sel Nothing -> variable (name "call") - func <- deref =<< maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver + func <- deref =<< maybe sel (flip evaluateInScopedEnv sel <=< subtermAddress) sendReceiver Rval <$> call func (map subtermAddress sendArgs) -- TODO pass through sendBlock data Require a = Require { requireRelative :: Bool, requirePath :: !a } @@ -131,7 +131,7 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Class where eval Class{..} = do - super <- traverse subtermValue classSuperClass + super <- traverse subtermAddress classSuperClass name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier) rvalBox =<< letrec' name (\addr -> subtermValue classBody <* makeNamespace name addr super) From ab4956dfa658723f31d321a52250cad0f39ca968 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 11 Jul 2018 15:15:53 +1000 Subject: [PATCH 5/6] fix order of ancestor traversal --- src/Data/Abstract/Value/Concrete.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 1f480d80a..394037f81 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -133,7 +133,7 @@ instance ( Coercible body (Eff effects) ancestors <- ancestorBinds [ptr] pure (Env.Environment <$> nonEmpty ancestors) where ancestorBinds = (pure . concat) <=< traverse (deref >=> \case - Class _ supers binds -> (binds :) <$> ancestorBinds supers + Class _ supers binds -> (binds :) <$> ancestorBinds (reverse supers) Namespace _ env -> pure . toList . Env.unEnvironment $ env _ -> pure []) From 301aca987eb6de2407ef165c79073e227e3c73be Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 11 Jul 2018 15:20:35 +1000 Subject: [PATCH 6/6] remove redundant constraints --- src/Analysis/Abstract/Caching.hs | 1 - src/Control/Abstract/Value.hs | 2 -- 2 files changed, 3 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index b7a83ac3d..9d5a9f274 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -77,7 +77,6 @@ cachingTerms recur term = do convergingModules :: ( AbstractValue address value effects , Cacheable term address (Cell address) value - , Member (Allocator address value) effects , Member Fresh effects , Member NonDet effects , Member (Reader (Cache term address (Cell address) value)) effects diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 2048a0bb7..2d3e8a487 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -233,7 +233,6 @@ subtermValue = value <=< subtermRef -- | Returns the address of a value referenced by a 'ValueRef' address :: ( AbstractValue address value effects - , Member (Allocator address value) effects , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects ) @@ -245,7 +244,6 @@ address (Rval addr) = pure addr -- | Evaluates a 'Subterm' to the address of its rval subtermAddress :: ( AbstractValue address value effects - , Member (Allocator address value) effects , Member (Env address) effects , Member (Resumable (EnvironmentError address)) effects )