From 3ac59ce62386326f40fcec2a97a180d9e8757787 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 14 Mar 2018 16:39:58 -0400 Subject: [PATCH 01/36] 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 02/36] 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 03/36] 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 04/36] 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 05/36] 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 06/36] 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 07/36] 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 08/36] 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 09/36] 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 10/36] 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 11/36] 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 12/36] 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 13/36] 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 14/36] 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 15/36] 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 16/36] 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 17/36] :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 18/36] :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 19/36] 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 20/36] :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 21/36] :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 22/36] :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 23/36] :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 24/36] 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 527d157d90d402feae55adef6830bb92d5104cd6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 15 Mar 2018 14:35:02 -0400 Subject: [PATCH 25/36] 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 26/36] 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 27/36] 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 28/36] 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 29/36] 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 30/36] 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 31/36] 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 32/36] 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 33/36] 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 34/36] 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 35/36] 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 36/36] 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)