From fb3833284951aba853e624df69e7210ef73695b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:00:25 -0400 Subject: [PATCH 01/58] Stub in a module for located names/values/whatever. --- semantic.cabal | 1 + src/Data/Abstract/Located.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Abstract/Located.hs diff --git a/semantic.cabal b/semantic.cabal index 2d7f04a5c..fa6146ff1 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -53,6 +53,7 @@ library , Data.Abstract.FreeVariables , Data.Abstract.Heap , Data.Abstract.Live + , Data.Abstract.Located , Data.Abstract.Module , Data.Abstract.ModuleTable , Data.Abstract.Number diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs new file mode 100644 index 000000000..f61b73e16 --- /dev/null +++ b/src/Data/Abstract/Located.hs @@ -0,0 +1 @@ +module Data.Abstract.Located where From cebcd5daaa96b168b94bf0bd74b90f0a3e8687a5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:00:48 -0400 Subject: [PATCH 02/58] Add a type synonym for the provenance of a symbol. --- src/Data/Abstract/Located.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index f61b73e16..2c5daee00 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -1 +1,6 @@ module Data.Abstract.Located where + +import Data.AST +import Data.Record + +type Provenance = Record Location From aa233f17e131a11c4cd88a75abf46f0c19cf7b0d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:01:20 -0400 Subject: [PATCH 03/58] =?UTF-8?q?Note=20that=20we=E2=80=99ll=20need=20to?= =?UTF-8?q?=20handle=20dependencies.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Located.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 2c5daee00..b7a78c51b 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -3,4 +3,5 @@ module Data.Abstract.Located where import Data.AST import Data.Record +-- TODO: Dependencies type Provenance = Record Location From 49a74de758411eafe69e47ef21e2f558712efb2a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:04:50 -0400 Subject: [PATCH 04/58] =?UTF-8?q?We=20don=E2=80=99t=20need=20injectivity?= =?UTF-8?q?=20for=20Cell.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Address.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index 6015ff4e6..5f84f428e 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilyDependencies #-} +{-# LANGUAGE TypeFamilies #-} module Data.Abstract.Address where import Data.Abstract.FreeVariables @@ -24,7 +24,7 @@ newtype Monovariant = Monovariant { unMonovariant :: Name } -- | The type into which stored values will be written for a given location type. -type family Cell l = res | res -> l where +type family Cell l where Cell Precise = Latest Cell Monovariant = Set From 9ce0fb1fef2bd100ace4e37e01171d96e3041e46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:05:55 -0400 Subject: [PATCH 05/58] Define Cell as an open type family. --- src/Data/Abstract/Address.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index 5f84f428e..b7c1e82bb 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -24,9 +24,9 @@ newtype Monovariant = Monovariant { unMonovariant :: Name } -- | The type into which stored values will be written for a given location type. -type family Cell l where - Cell Precise = Latest - Cell Monovariant = Set +type family Cell l :: * -> * +type instance Cell Precise = Latest +type instance Cell Monovariant = Set -- | A cell holding a single value. Writes will replace any prior value. From 095ece31826ed9f8961da9f5bcd62ac2b9a9d6c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:07:53 -0400 Subject: [PATCH 06/58] Define a Location typeclass of which Cell is an associated type. --- src/Data/Abstract/Address.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index b7c1e82bb..7fc6bf9e6 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -14,19 +14,25 @@ instance Ord l => Ord1 (Address l) where liftCompare = genericLiftCompare instance Show l => Show1 (Address l) where liftShowsPrec = genericLiftShowsPrec +class Location loc where + -- | The type into which stored values will be written for a given location type. + type family Cell loc :: * -> * + + -- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store. newtype Precise = Precise { unPrecise :: Int } deriving (Eq, Ord, Show) +instance Location Precise where + type Cell Precise = Latest + + -- | 'Monovariant' models using one address for a particular name. It trackes the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new. newtype Monovariant = Monovariant { unMonovariant :: Name } deriving (Eq, Ord, Show) - --- | The type into which stored values will be written for a given location type. -type family Cell l :: * -> * -type instance Cell Precise = Latest -type instance Cell Monovariant = Set +instance Location Monovariant where + type Cell Monovariant = Set -- | A cell holding a single value. Writes will replace any prior value. From d49bc17aa774c16f9144f83b1f4d8c27463d2dc8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:18:10 -0400 Subject: [PATCH 07/58] Define LocationFor as an associated type family on an AbstractValue typeclass. --- src/Control/Abstract/Evaluator.hs | 7 ++++--- src/Data/Abstract/Address.hs | 2 +- src/Data/Abstract/Type.hs | 4 +++- src/Data/Abstract/Value.hs | 5 ++++- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 0fbf77d29..efab46971 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -22,7 +22,7 @@ module Control.Abstract.Evaluator , ExportsFor , HeapFor , LiveFor - , LocationFor + , AbstractValue(..) ) where import Control.Effect @@ -205,5 +205,6 @@ type HeapFor value = Heap (LocationFor value) value -- | The address set type for an abstract value type. 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 :: * +class AbstractValue value where + -- | The location type (the body of 'Address'es) which should be used for an abstract value type. + type LocationFor value :: * diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index 7fc6bf9e6..883ac1d8d 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -14,7 +14,7 @@ instance Ord l => Ord1 (Address l) where liftCompare = genericLiftCompare instance Show l => Show1 (Address l) where liftShowsPrec = genericLiftShowsPrec -class Location loc where +class Ord loc => Location loc where -- | The type into which stored values will be written for a given location type. type family Cell loc :: * -> * diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 8e45684ec..f9cae670f 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -43,7 +43,9 @@ unify t1 t2 | otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2) -type instance LocationFor Type = Monovariant +instance AbstractValue Type where + type LocationFor Type = Monovariant + instance ValueRoots Type where valueRoots _ = mempty diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 756035171..943dddbc4 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -184,13 +184,16 @@ instance Ord1 Null where liftCompare = genericLiftCompare instance Show1 Null where liftShowsPrec = genericLiftShowsPrec -type instance LocationFor Value = Precise +instance AbstractValue Value where + type LocationFor Value = Precise + instance ValueRoots Value where valueRoots v | Just (Closure _ _ env) <- prjValue v = Env.addresses env | otherwise = mempty + -- | Construct a 'Value' wrapping the value arguments (if any). instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where unit = pure . injValue $ Unit From 6850aba2a47e9fc10eaf78893d6e09a9c60dd669 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:28:07 -0400 Subject: [PATCH 08/58] Define a Located location type. --- src/Data/Abstract/Located.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index b7a78c51b..2aedd65c4 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -5,3 +5,5 @@ import Data.Record -- TODO: Dependencies type Provenance = Record Location + +data Located location = Located { provenance :: !Provenance, location :: location } From 3466a6d3ffa059ab662f5b53354c58d82203ade7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:28:20 -0400 Subject: [PATCH 09/58] Define a LocatedValue value type. --- src/Data/Abstract/Located.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 2aedd65c4..ae10f85bb 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -7,3 +7,5 @@ import Data.Record type Provenance = Record Location data Located location = Located { provenance :: !Provenance, location :: location } + +newtype LocatedValue value = LocatedValue { getLocatedValue :: value } From f85cf50f7a6e4eda85c8943beca85245d9390425 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:28:32 -0400 Subject: [PATCH 10/58] Define an AbstractValue instance for LocatedValue. --- src/Data/Abstract/Located.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index ae10f85bb..b2b250ef0 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} module Data.Abstract.Located where +import Control.Abstract.Evaluator import Data.AST import Data.Record @@ -9,3 +11,6 @@ type Provenance = Record Location data Located location = Located { provenance :: !Provenance, location :: location } newtype LocatedValue value = LocatedValue { getLocatedValue :: value } + +instance AbstractValue (LocatedValue value) where + type LocationFor (LocatedValue value) = Located (LocationFor value) From 8de38e0f7370bc5ba8ac492541cd9f2835cf7170 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:30:39 -0400 Subject: [PATCH 11/58] =?UTF-8?q?Spell=20out=20Provenance=E2=80=99s=20defi?= =?UTF-8?q?nition.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Located.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index b2b250ef0..79ec0dd97 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -2,11 +2,12 @@ module Data.Abstract.Located where import Control.Abstract.Evaluator -import Data.AST +import Data.Range import Data.Record +import Data.Span -- TODO: Dependencies -type Provenance = Record Location +type Provenance = Record '[Range, Span] data Located location = Located { provenance :: !Provenance, location :: location } From e51d095372207284034dccb2f3e1a05c4957ff3d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:30:48 -0400 Subject: [PATCH 12/58] Derive Eq, Ord, & Show instances for Located. --- src/Data/Abstract/Located.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 79ec0dd97..3bea78f47 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -10,6 +10,7 @@ import Data.Span type Provenance = Record '[Range, Span] data Located location = Located { provenance :: !Provenance, location :: location } + deriving (Eq, Ord, Show) newtype LocatedValue value = LocatedValue { getLocatedValue :: value } From 438c19dd50787b85c32e31296419ee72e631f231 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:31:08 -0400 Subject: [PATCH 13/58] Derive Eq, Ord, & Show instances for LocatedValue. --- src/Data/Abstract/Located.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 3bea78f47..d14daba6b 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -13,6 +13,7 @@ data Located location = Located { provenance :: !Provenance, location :: locatio deriving (Eq, Ord, Show) newtype LocatedValue value = LocatedValue { getLocatedValue :: value } + deriving (Eq, Ord, Show) instance AbstractValue (LocatedValue value) where type LocationFor (LocatedValue value) = Located (LocationFor value) From 1c03f9c4d9352688a930ec5967732834ab9db0ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:31:45 -0400 Subject: [PATCH 14/58] Define a Location instance for Located. --- src/Data/Abstract/Located.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index d14daba6b..d81923b56 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -2,6 +2,7 @@ module Data.Abstract.Located where import Control.Abstract.Evaluator +import Data.Abstract.Address import Data.Range import Data.Record import Data.Span @@ -9,9 +10,14 @@ import Data.Span -- TODO: Dependencies type Provenance = Record '[Range, Span] + data Located location = Located { provenance :: !Provenance, location :: location } deriving (Eq, Ord, Show) +instance Location location => Location (Located location) where + type Cell (Located location) = Cell location + + newtype LocatedValue value = LocatedValue { getLocatedValue :: value } deriving (Eq, Ord, Show) From c2f657202be0e05a71643223239b3cbb5960d66e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:40:45 -0400 Subject: [PATCH 15/58] :fire: the MonadValue constraints on Value. --- src/Semantic/Util.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 27e968800..b9fc17ebc 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -67,7 +67,6 @@ evaluateFile :: forall term effects , FreeVariables term , 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 @@ -101,7 +100,6 @@ evaluateWithPrelude :: forall term effects , FreeVariables term , effects ~ RequiredEffects term Value (Evaluating term Value effects) , MonadAddressable Precise Value (Evaluating term Value effects) - , MonadValue Value (Evaluating term Value effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) ) @@ -121,7 +119,6 @@ evaluateFiles :: forall term effects , FreeVariables term , 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 @@ -152,7 +149,6 @@ evaluateFilesWithPrelude :: forall term effects , FreeVariables term , effects ~ RequiredEffects term Value (Evaluating term Value effects) , MonadAddressable Precise Value (Evaluating term Value effects) - , MonadValue Value (Evaluating term Value effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) ) From fc262873f364a3a093808c738c5d2715e774b85c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 09:56:50 -0400 Subject: [PATCH 16/58] Rename the LocatedValue eliminator. --- src/Data/Abstract/Located.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index d81923b56..ac599027e 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -18,7 +18,7 @@ instance Location location => Location (Located location) where type Cell (Located location) = Cell location -newtype LocatedValue value = LocatedValue { getLocatedValue :: value } +newtype LocatedValue value = LocatedValue { unLocatedValue :: value } deriving (Eq, Ord, Show) instance AbstractValue (LocatedValue value) where From 9a36f7979fa1e68062e8e6cb9970d0f306314491 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 10:04:43 -0400 Subject: [PATCH 17/58] Stub in part of a MonadValue instance for now --- src/Data/Abstract/Located.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index ac599027e..4ca87e016 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -2,10 +2,14 @@ module Data.Abstract.Located where import Control.Abstract.Evaluator +import Control.Abstract.Value import Data.Abstract.Address +import Data.Bifunctor import Data.Range import Data.Record import Data.Span +import Prelude hiding (null) +import Prologue hiding (hash, null) -- TODO: Dependencies type Provenance = Record '[Range, Span] @@ -23,3 +27,19 @@ newtype LocatedValue value = LocatedValue { unLocatedValue :: value } instance AbstractValue (LocatedValue value) where type LocationFor (LocatedValue value) = Located (LocationFor value) + +instance MonadValue value m => MonadValue (LocatedValue value) m where + unit = LocatedValue <$> unit + null = LocatedValue <$> null + integer = fmap LocatedValue . integer + float = fmap LocatedValue . float + rational = fmap LocatedValue . rational + boolean = fmap LocatedValue . boolean + multiple = fmap LocatedValue . multiple . map unLocatedValue + string = fmap LocatedValue . string + symbol = fmap LocatedValue . symbol + array = fmap LocatedValue . array . map unLocatedValue + hash = fmap LocatedValue . hash . map (bimap unLocatedValue unLocatedValue) + ifthenelse = ifthenelse . unLocatedValue + kvPair = fmap (fmap LocatedValue) . (kvPair `on` unLocatedValue) + -- klass name vals env = LocatedValue <$> klass name (map unLocatedValue vals) (fmap unLocatedValue env) From 828bb296365946eaeeb77388af67efbd18a852ce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 20:18:17 -0400 Subject: [PATCH 18/58] Rename the location type parameter. --- src/Control/Abstract/Addressable.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index bec1dc19b..d0b6fa5ec 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -13,10 +13,10 @@ 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 - deref :: Address l value -> m value +class (Monad m, Ord location, location ~ LocationFor value, Reducer value (Cell location value)) => MonadAddressable location value m where + deref :: Address location value -> m value - alloc :: Name -> m (Address l value) + alloc :: Name -> m (Address location value) -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m From a60682ee691b3e71de0ba5e0340183a0304111dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 20:19:01 -0400 Subject: [PATCH 19/58] :fire: the constraint relating the location and value types. --- src/Control/Abstract/Addressable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index d0b6fa5ec..c32bac14a 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -13,7 +13,7 @@ import Prelude hiding (fail) import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. -class (Monad m, Ord location, location ~ LocationFor value, Reducer value (Cell location value)) => MonadAddressable location value m where +class (Monad m, Ord location, Reducer value (Cell location value)) => MonadAddressable location value m where deref :: Address location value -> m value alloc :: Name -> m (Address location value) From c6d06c632bff446988c51ce947cc4c879a064276 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 20:38:23 -0400 Subject: [PATCH 20/58] Parameterize MonadHeap by the location type. --- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Collecting.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Analysis/Abstract/Quiet.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Addressable.hs | 10 +++++----- src/Control/Abstract/Evaluator.hs | 20 ++++++++++---------- src/Control/Abstract/Value.hs | 10 +++++----- src/Data/Abstract/Type.hs | 2 +- 12 files changed, 29 insertions(+), 29 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 192792335..655e766c7 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -13,7 +13,7 @@ newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (BadVariables m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (BadVariables m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects) deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index b1df018cd..faae47f79 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -27,7 +27,7 @@ newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Caching m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (Caching m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects) deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 9a42356a6..6fb5adc81 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -15,7 +15,7 @@ newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Collecting m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (Collecting m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Collecting m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects) instance ( Effectful m diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 1820b739b..e79cb6e34 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -15,7 +15,7 @@ newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (DeadCode m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (DeadCode m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects) deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 29de7bebd..60b76fb5d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -116,7 +116,7 @@ instance Members '[ State (EvaluatingState term value) result <- a result <$ modifyEnv Env.pop -instance Member (State (EvaluatingState term value)) effects => MonadHeap value (Evaluating term value effects) where +instance (Member (State (EvaluatingState term value)) effects, location ~ LocationFor value) => MonadHeap location value (Evaluating term value effects) where getHeap = view _heap putHeap = (_heap .=) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index e36a17bd6..dc167a536 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -28,7 +28,7 @@ newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (ImportGraphing m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (ImportGraphing m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects) deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index f9bb5ee49..afce8d5bd 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -19,7 +19,7 @@ newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Quietly m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (Quietly m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects) deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index ada1f73f8..c46a5e1bf 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -17,7 +17,7 @@ newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Tracing trace m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (Tracing trace m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects) deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index c32bac14a..6e99b0d4a 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} module Control.Abstract.Addressable where import Control.Abstract.Evaluator @@ -29,7 +29,7 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( MonadAddressable (LocationFor value) value m , MonadEnvironment value m - , MonadHeap value m + , MonadHeap (LocationFor value) value m ) => Name -> m value @@ -55,7 +55,7 @@ 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, MonadHeap value m) => MonadAddressable Precise value m where +instance (MonadFail m, MonadHeap Precise value m) => MonadAddressable Precise value m where deref = derefWith (maybeM uninitializedAddress . unLatest) alloc _ = do -- Compute the next available address in the heap, then write an empty value into it. @@ -63,12 +63,12 @@ instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadA addr <$ modifyHeap (heapInit addr mempty) -- | '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 +instance (Alternative m, LocationFor value ~ Monovariant, MonadFail m, MonadHeap Monovariant value m, Ord value) => MonadAddressable Monovariant value m where 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 :: (MonadFail m, MonadHeap location value m, Ord location) => (Cell location value -> m a) -> Address location value -> m a derefWith with = maybe uninitializedAddress with <=< lookupHeap -- | 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). diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index efab46971..807108031 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -49,7 +49,7 @@ class ( MonadControl term m , MonadEnvironment value m , MonadFail m , MonadModuleTable term value m - , MonadHeap value m + , MonadHeap (LocationFor value) value m ) => MonadEvaluator term value m | m -> term, m -> value where -- | Get the current 'Configuration' with a passed-in term. @@ -123,28 +123,28 @@ fullEnvironment :: MonadEnvironment value m => m (EnvironmentFor value) fullEnvironment = mappend <$> getEnv <*> defaultEnvironment -- | A 'Monad' abstracting a heap of values. -class Monad m => MonadHeap value m | m -> value where +class Monad m => MonadHeap location value m | m -> value, m -> location where -- | Retrieve the heap. - getHeap :: m (HeapFor value) + getHeap :: m (Heap location value) -- | Set the heap. - putHeap :: HeapFor value -> m () + putHeap :: Heap location value -> m () -- | Update the heap. -modifyHeap :: MonadHeap value m => (HeapFor value -> HeapFor value) -> m () +modifyHeap :: MonadHeap location value m => (Heap location value -> Heap location value) -> m () 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 :: (MonadHeap location value m, Ord location) => Address location value -> m (Maybe (Cell location value)) lookupHeap = flip fmap getHeap . heapLookup -- | Write a value to the given 'Address' in the 'Store'. -assign :: ( Ord (LocationFor value) - , MonadHeap value m - , Reducer value (CellFor value) +assign :: ( Ord location + , MonadHeap location value m + , Reducer value (Cell location value) ) - => Address (LocationFor value) value + => Address location value -> value -> m () assign address = modifyHeap . heapInsert address diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e880edf50..20ecef868 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -21,7 +21,7 @@ module Control.Abstract.Value import Control.Abstract.Evaluator import Data.Abstract.FreeVariables import Data.Abstract.Environment as Env -import Data.Abstract.Address (Address) +import Data.Abstract.Address (Address, Cell) import Data.Abstract.Number as Number import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) @@ -173,12 +173,12 @@ doWhile body cond = loop $ \ continue -> body *> do makeNamespace :: ( MonadValue value m , MonadEnvironment value m - , MonadHeap value m - , Reducer value (CellFor value) - , Ord (LocationFor value) + , MonadHeap location value m + , Ord location + , Reducer value (Cell location value) ) => Name - -> Address (LocationFor value) value + -> Address location value -> [value] -> m value makeNamespace name addr supers = do diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index f9cae670f..9b08f0c2d 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -52,7 +52,7 @@ instance ValueRoots Type where -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Type m) => MonadValue Type m where +instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Monovariant Type m) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name From 0c57eca3e0a7e19c40ebf80026819d9586264e6b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 20:46:17 -0400 Subject: [PATCH 21/58] Parameterize MonadEnvironment by the location type. --- src/Analysis/Abstract/BadVariables.hs | 10 +++---- src/Analysis/Abstract/Caching.hs | 10 +++---- src/Analysis/Abstract/Collecting.hs | 8 +++--- src/Analysis/Abstract/Dead.hs | 10 +++---- src/Analysis/Abstract/Evaluating.hs | 10 ++++--- src/Analysis/Abstract/ImportGraph.hs | 10 +++---- src/Analysis/Abstract/Quiet.hs | 10 +++---- src/Analysis/Abstract/Tracing.hs | 10 +++---- src/Control/Abstract/Addressable.hs | 20 +++++++------- src/Control/Abstract/Evaluator.hs | 40 +++++++++++++-------------- src/Control/Abstract/Value.hs | 14 +++++----- src/Data/Abstract/Type.hs | 2 +- 12 files changed, 78 insertions(+), 76 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 655e766c7..803f8e081 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,11 +11,11 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (BadVariables m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) +deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadVariables m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) instance ( Effectful m , Member (Resumable (EvalError value)) effects diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index faae47f79..c343a887d 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -25,11 +25,11 @@ type CacheFor term value = Cache (LocationFor value) term value newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Caching m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Caching m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m 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 diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 6fb5adc81..783a34ff5 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -13,10 +13,10 @@ import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Collecting m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Collecting m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Collecting m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Collecting m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects) instance ( Effectful m , Member (Reader (Live (LocationFor value) value)) effects diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index e79cb6e34..04de3e3e5 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,11 +13,11 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (DeadCode m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) +deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (DeadCode m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 60b76fb5d..6a7bdcd9e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -96,10 +96,12 @@ instance Members '[Fail, State (EvaluatingState term value)] effects => MonadCon goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure -instance Members '[ State (EvaluatingState term value) - , Reader (EnvironmentFor value) - ] effects - => MonadEnvironment value (Evaluating term value effects) where +instance ( location ~ LocationFor value + , Members '[ State (EvaluatingState term value) + , Reader (EnvironmentFor value) + ] effects + ) + => MonadEnvironment location value (Evaluating term value effects) where getEnv = view _environment putEnv = (_environment .=) withEnv s = localEvaluatingState _environment (const s) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index dc167a536..edcdfc081 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -26,11 +26,11 @@ renderImportGraph = export (defaultStyle friendlyName) . unImportGraph newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (ImportGraphing m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) +deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (ImportGraphing m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) instance ( Effectful m diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index afce8d5bd..28a6f9bac 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,11 +17,11 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Quietly m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Quietly m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) instance ( Effectful m , Member (Resumable (Unspecialized value)) effects diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index c46a5e1bf..dc032ffa4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -15,11 +15,11 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Tracing trace m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Tracing trace m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) instance ( Corecursive term , Effectful m diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 6e99b0d4a..3be78ea4d 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -19,21 +19,21 @@ class (Monad m, Ord location, Reducer value (Cell location value)) => MonadAddre alloc :: Name -> m (Address location value) -- | Look up or allocate an address for a 'Name'. -lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m - , MonadEnvironment value m +lookupOrAlloc :: ( MonadAddressable location value m + , MonadEnvironment location value m ) => Name - -> m (Address (LocationFor value) value) + -> m (Address location value) lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure -letrec :: ( MonadAddressable (LocationFor value) value m - , MonadEnvironment value m - , MonadHeap (LocationFor value) value m +letrec :: ( MonadAddressable location value m + , MonadEnvironment location value m + , MonadHeap location value m ) => Name -> m value - -> m (value, Address (LocationFor value) value) + -> m (value, Address location value) letrec name body = do addr <- lookupOrAlloc name v <- localEnv (insert name addr) body @@ -41,11 +41,11 @@ letrec name body = do pure (v, addr) -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. -letrec' :: ( MonadAddressable (LocationFor value) value m - , MonadEnvironment value m +letrec' :: ( MonadAddressable location value m + , MonadEnvironment location value m ) => Name - -> (Address (LocationFor value) value -> m value) + -> (Address location value -> m value) -> m value letrec' name body = do addr <- lookupOrAlloc name diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 807108031..71efa64d2 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -29,8 +29,8 @@ import Control.Effect import Control.Monad.Effect.Resumable import Data.Abstract.Address import Data.Abstract.Configuration -import qualified Data.Abstract.Environment as Env -import qualified Data.Abstract.Exports as Export +import Data.Abstract.Environment as Env +import Data.Abstract.Exports as Export import Data.Abstract.FreeVariables import Data.Abstract.Heap import Data.Abstract.Live @@ -46,7 +46,7 @@ import Prologue hiding (throwError) -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class ( MonadControl term m - , MonadEnvironment value m + , MonadEnvironment (LocationFor value) value m , MonadFail m , MonadModuleTable term value m , MonadHeap (LocationFor value) value m @@ -62,64 +62,64 @@ class ( MonadControl term m -- | A 'Monad' abstracting local and global environments. -class Monad m => MonadEnvironment value m | m -> value where +class Monad m => MonadEnvironment location value m | m -> value, m -> location where -- | Retrieve the environment. - getEnv :: m (EnvironmentFor value) + getEnv :: m (Environment location value) -- | Set the environment. - putEnv :: EnvironmentFor value -> m () + putEnv :: Environment location value -> m () -- | Sets the environment for the lifetime of the given action. - withEnv :: EnvironmentFor value -> m a -> m a + withEnv :: Environment location value -> m a -> m a -- | Retrieve the default environment. - defaultEnvironment :: m (EnvironmentFor value) + defaultEnvironment :: m (Environment location value) -- | Set the default environment for the lifetime of an action. -- Usually only invoked in a top-level evaluation function. - withDefaultEnvironment :: EnvironmentFor value -> m a -> m a + withDefaultEnvironment :: Environment location value -> m a -> m a -- | Get the global export state. - getExports :: m (ExportsFor value) + getExports :: m (Exports location value) -- | Set the global export state. - putExports :: ExportsFor value -> m () + putExports :: Exports location value -> m () -- | Sets the global export state for the lifetime of the given action. - withExports :: ExportsFor value -> m a -> m a + withExports :: Exports location value -> m a -> m a -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a + localEnv :: (Environment location value -> Environment location value) -> m a -> m a -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. - lookupEnv :: Name -> m (Maybe (Address (LocationFor value) value)) + lookupEnv :: Name -> m (Maybe (Address location value)) lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) -- | Look up a 'Name' in the environment, running an action with the resolved address (if any). - lookupWith :: (Address (LocationFor value) value -> m value) -> Name -> m (Maybe value) + lookupWith :: (Address location value -> m value) -> Name -> m (Maybe value) lookupWith with name = do addr <- lookupEnv name maybe (pure Nothing) (fmap Just . with) addr -- | Run a computation in a new local environment. -localize :: MonadEnvironment value m => m a -> m a +localize :: MonadEnvironment location value m => m a -> m a localize = localEnv id -- | Update the global environment. -modifyEnv :: MonadEnvironment value m => (EnvironmentFor value -> EnvironmentFor value) -> m () +modifyEnv :: MonadEnvironment location value m => (Environment location value -> Environment location value) -> m () modifyEnv f = do env <- getEnv putEnv $! f env -- | Update the global export state. -modifyExports :: MonadEnvironment value m => (ExportsFor value -> ExportsFor value) -> m () +modifyExports :: MonadEnvironment location value m => (Exports location value -> Exports location value) -> m () modifyExports f = do exports <- getExports putExports $! f exports -- | Add an export to the global export state. -addExport :: MonadEnvironment value m => Name -> Name -> Maybe (Address (LocationFor value) value) -> m () +addExport :: MonadEnvironment location value m => Name -> Name -> Maybe (Address location value) -> m () addExport name alias = modifyExports . Export.insert name alias -- | Obtain an environment that is the composition of the current and default environments. -- Useful for debugging. -fullEnvironment :: MonadEnvironment value m => m (EnvironmentFor value) +fullEnvironment :: MonadEnvironment location value m => m (Environment location value) fullEnvironment = mappend <$> getEnv <*> defaultEnvironment -- | A 'Monad' abstracting a heap of values. diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 20ecef868..892c5b2c8 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -21,7 +21,7 @@ module Control.Abstract.Value import Control.Abstract.Evaluator import Data.Abstract.FreeVariables import Data.Abstract.Environment as Env -import Data.Abstract.Address (Address, Cell) +import Data.Abstract.Address (Address) import Data.Abstract.Number as Number import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) @@ -144,7 +144,7 @@ class (Monad m, Show value) => MonadValue value m where toBool :: MonadValue value m => value -> m Bool toBool v = ifthenelse v (pure True) (pure False) -forLoop :: (MonadEnvironment value m, MonadValue value m) +forLoop :: (MonadEnvironment (LocationFor value) value m, MonadValue value m) => m value -- ^ Initial statement -> m value -- ^ Condition -> m value -- ^ Increment/stepper @@ -172,13 +172,13 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue unit makeNamespace :: ( MonadValue value m - , MonadEnvironment value m - , MonadHeap location value m - , Ord location - , Reducer value (Cell location value) + , MonadEnvironment (LocationFor value) value m + , MonadHeap (LocationFor value) value m + , Ord (LocationFor value) + , Reducer value (CellFor value) ) => Name - -> Address location value + -> Address (LocationFor value) value -> [value] -> m value makeNamespace name addr supers = do diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 9b08f0c2d..6368672f5 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -52,7 +52,7 @@ instance ValueRoots Type where -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Monovariant Type m) => MonadValue Type m where +instance (Alternative m, MonadEnvironment Monovariant Type m, MonadFail m, MonadFresh m, MonadHeap Monovariant Type m) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name From cb2b38da08fb9a3db095bf117ca5282309ac1d68 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 20:50:08 -0400 Subject: [PATCH 22/58] Parameterize MonadModuleTable by the location type. --- src/Analysis/Abstract/BadVariables.hs | 10 +++++----- src/Analysis/Abstract/Caching.hs | 10 +++++----- src/Analysis/Abstract/Collecting.hs | 8 ++++---- src/Analysis/Abstract/Dead.hs | 10 +++++----- src/Analysis/Abstract/Evaluating.hs | 10 ++++++++-- src/Analysis/Abstract/ImportGraph.hs | 10 +++++----- src/Analysis/Abstract/Quiet.hs | 10 +++++----- src/Analysis/Abstract/Tracing.hs | 10 +++++----- src/Control/Abstract/Evaluator.hs | 10 +++++----- 9 files changed, 47 insertions(+), 41 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 803f8e081..5aed95d5f 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,11 +11,11 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadVariables m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) +deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadVariables m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadVariables m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) instance ( Effectful m , Member (Resumable (EvalError value)) effects diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index c343a887d..bad5340ad 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -25,11 +25,11 @@ type CacheFor term value = Cache (LocationFor value) term value newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Caching m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Caching m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Caching m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m 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 diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 783a34ff5..ce054dbc1 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -13,10 +13,10 @@ import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Collecting m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Collecting m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Collecting m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Collecting m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Collecting m effects) instance ( Effectful m , Member (Reader (Live (LocationFor value) value)) effects diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 04de3e3e5..4a224df39 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,11 +13,11 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (DeadCode m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) +deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (DeadCode m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (DeadCode m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 6a7bdcd9e..85c8a5637 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -118,11 +118,17 @@ instance ( location ~ LocationFor value result <- a result <$ modifyEnv Env.pop -instance (Member (State (EvaluatingState term value)) effects, location ~ LocationFor value) => MonadHeap location value (Evaluating term value effects) where +instance ( location ~ LocationFor value + , Member (State (EvaluatingState term value)) effects + ) + => MonadHeap location value (Evaluating term value effects) where getHeap = view _heap putHeap = (_heap .=) -instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState term value)] effects => MonadModuleTable term value (Evaluating term value effects) where +instance ( location ~ LocationFor value + , Members '[Reader (ModuleTable [Module term]), State (EvaluatingState term value)] effects + ) + => MonadModuleTable location term value (Evaluating term value effects) where getModuleTable = view _modules putModuleTable = (_modules .=) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index edcdfc081..f0cbddc47 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -26,11 +26,11 @@ renderImportGraph = export (defaultStyle friendlyName) . unImportGraph newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (ImportGraphing m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) +deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (ImportGraphing m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (ImportGraphing m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) instance ( Effectful m diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 28a6f9bac..4cbb47501 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,11 +17,11 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Quietly m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Quietly m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Quietly m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) instance ( Effectful m , Member (Resumable (Unspecialized value)) effects diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index dc032ffa4..85e426fa4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -15,11 +15,11 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Tracing trace m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects) -deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Tracing trace m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Tracing trace m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) instance ( Corecursive term , Effectful m diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 71efa64d2..698391134 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -48,7 +48,7 @@ import Prologue hiding (throwError) class ( MonadControl term m , MonadEnvironment (LocationFor value) value m , MonadFail m - , MonadModuleTable term value m + , MonadModuleTable (LocationFor value) term value m , MonadHeap (LocationFor value) value m ) => MonadEvaluator term value m | m -> term, m -> value where @@ -151,11 +151,11 @@ assign address = modifyHeap . heapInsert address -- | A 'Monad' abstracting tables of modules available for import. -class Monad m => MonadModuleTable term value m | m -> term, m -> value where +class Monad m => MonadModuleTable location term value m | m -> location, m -> term, m -> value where -- | Retrieve the table of evaluated modules. - getModuleTable :: m (ModuleTable (EnvironmentFor value, value)) + getModuleTable :: m (ModuleTable (Environment location value, value)) -- | Set the table of evaluated modules. - putModuleTable :: ModuleTable (EnvironmentFor value, value) -> m () + putModuleTable :: ModuleTable (Environment location value, value) -> m () -- | Retrieve the table of unevaluated modules. askModuleTable :: m (ModuleTable [Module term]) @@ -163,7 +163,7 @@ class Monad m => MonadModuleTable term value m | m -> term, m -> value where localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m a -> m a -- | Update the evaluated module table. -modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value, value) -> ModuleTable (EnvironmentFor value, value)) -> m () +modifyModuleTable :: MonadModuleTable location term value m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m () modifyModuleTable f = do table <- getModuleTable putModuleTable $! f table From ceed6c844aff6a3b6edb09cff16e83e3d4909ebe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 20:58:36 -0400 Subject: [PATCH 23/58] Parameterize MonadEvaluator by the location type. --- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Analysis/Abstract/Caching.hs | 46 +++++++++++++-------------- src/Analysis/Abstract/Collecting.hs | 8 ++--- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 5 ++- src/Analysis/Abstract/ImportGraph.hs | 4 +-- src/Analysis/Abstract/Quiet.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Analysis.hs | 2 +- src/Control/Abstract/Evaluator.hs | 10 +++--- 10 files changed, 42 insertions(+), 41 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 5aed95d5f..d77866751 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -15,7 +15,7 @@ deriving instance MonadControl term (m effects) => MonadContr deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadVariables m effects) deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects) deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadVariables m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) +deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadVariables m effects) instance ( Effectful m , Member (Resumable (EvalError value)) effects diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index bad5340ad..e856f30b1 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -4,6 +4,7 @@ module Analysis.Abstract.Caching ) where import Control.Abstract.Analysis +import Data.Abstract.Address import Data.Abstract.Cache import Data.Abstract.Configuration import Data.Abstract.Heap @@ -11,16 +12,13 @@ import Data.Abstract.Module import Prologue -- | The effects necessary for caching analyses. -type CachingEffects term value effects - = Fresh -- For 'MonadFresh'. - ': NonDet -- For 'Alternative' and 'MonadNonDet'. - ': Reader (CacheFor term value) -- The in-cache used as an oracle while converging on a result. - ': State (CacheFor term value) -- The out-cache used to record results in each iteration of convergence. +type CachingEffects location term value effects + = Fresh -- For 'MonadFresh'. + ': NonDet -- For 'Alternative' and 'MonadNonDet'. + ': Reader (Cache location term value) -- The in-cache used as an oracle while converging on a result. + ': State (Cache location term value) -- The out-cache used to record results in each iteration of convergence. ': effects --- | The cache for term and abstract value types. -type CacheFor term value = Cache (LocationFor value) term value - -- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs. newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) @@ -29,32 +27,32 @@ deriving instance MonadControl term (m effects) => MonadContr deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Caching m effects) deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects) deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Caching m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects) +deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Caching m 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 +class MonadEvaluator location term value m => MonadCaching location 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, HeapFor value)) + consultOracle :: Configuration location term value -> m (Set (value, Heap location value)) -- | Run an action with the given in-cache. - withOracle :: CacheFor term value -> m a -> m a + withOracle :: Cache location 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, HeapFor value))) + lookupCache :: Configuration location term value -> m (Maybe (Set (value, Heap location 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 + caching :: Configuration location term value -> Set (value, Heap location 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) + isolateCache :: m a -> m (Cache location term value) instance ( Effectful m - , Members (CachingEffects term value '[]) effects - , MonadEvaluator term value (m effects) - , Ord (CellFor value) - , Ord (LocationFor value) + , Members (CachingEffects location term value '[]) effects + , MonadEvaluator location term value (m effects) + , Ord (Cell location value) + , Ord location , Ord term , Ord value ) - => MonadCaching term value (Caching m effects) where + => MonadCaching location term value (Caching m effects) where consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask) withOracle cache = raise . local (const cache) . lower @@ -65,12 +63,12 @@ instance ( Effectful m raise (modify (cacheInsert configuration result)) pure (fst result) - isolateCache action = raise (put (mempty :: CacheFor term value)) *> action *> raise get + isolateCache action = raise (put (mempty :: Cache location term value)) *> action *> raise get -- | This instance coinductively iterates the analysis of a term until the results converge. instance ( Corecursive term , Effectful m - , Members (CachingEffects term value '[]) effects + , Members (CachingEffects (LocationFor value) term value '[]) effects , MonadAnalysis term value (m effects) , MonadFresh (m effects) , MonadNonDet (m effects) @@ -81,7 +79,7 @@ instance ( Corecursive term ) => MonadAnalysis term value (Caching m effects) where -- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'. - type Effects term value (Caching m effects) = CachingEffects term value (Effects term value (m effects)) + type Effects term value (Caching m effects) = CachingEffects (LocationFor value) term value (Effects term value (m effects)) -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. analyzeTerm recur e = do @@ -124,5 +122,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, Heap (LocationFor value) value) -> m a +scatter :: (Alternative m, Foldable t, MonadEvaluator location term value m) => t (a, Heap location value) -> m a scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index ce054dbc1..2fa22e6a0 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -19,10 +19,10 @@ deriving instance MonadHeap location value (m effects) => MonadHeap deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Collecting m effects) instance ( Effectful m - , Member (Reader (Live (LocationFor value) value)) effects - , MonadEvaluator term value (m effects) + , Member (Reader (Live location value)) effects + , MonadEvaluator location term value (m effects) ) - => MonadEvaluator term value (Collecting m effects) where + => MonadEvaluator location term value (Collecting m effects) where getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap askModuleStack = Collecting askModuleStack @@ -51,7 +51,7 @@ instance ( Effectful m -- | Retrieve the local 'Live' set. -askRoots :: (Effectful m, Member (Reader (Live (LocationFor value) value)) effects) => m effects (Live (LocationFor value) value) +askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value) askRoots = raise ask -- | Run a computation with the given 'Live' set added to the local root set. diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 4a224df39..3a0b58ca4 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -17,7 +17,7 @@ deriving instance MonadControl term (m effects) => MonadContr deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (DeadCode m effects) deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects) deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (DeadCode m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) +deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (DeadCode m effects) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 85c8a5637..ec3298ffc 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -135,7 +135,10 @@ instance ( location ~ LocationFor value askModuleTable = raise ask localModuleTable f a = raise (local f (lower a)) -instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where +instance ( location ~ LocationFor value + , Members (EvaluatingEffects term value) effects + ) + => MonadEvaluator location term value (Evaluating term value effects) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap askModuleStack = raise ask diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index f0cbddc47..797fde881 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -30,7 +30,7 @@ deriving instance MonadControl term (m effects) => MonadContr deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (ImportGraphing m effects) deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects) deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (ImportGraphing m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) +deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (ImportGraphing m effects) instance ( Effectful m @@ -52,7 +52,7 @@ instance ( Effectful m insertVertexName :: (Effectful m , Member (State ImportGraph) effects - , MonadEvaluator term value (m effects)) + , MonadEvaluator location term value (m effects)) => NonEmpty ByteString -> ImportGraphing m effects () insertVertexName name = do diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 4cbb47501..46d0eea51 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -21,7 +21,7 @@ deriving instance MonadControl term (m effects) => MonadContr deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Quietly m effects) deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects) deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Quietly m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) +deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Quietly m effects) instance ( Effectful m , Member (Resumable (Unspecialized value)) effects diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 85e426fa4..52d534707 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -19,7 +19,7 @@ deriving instance MonadControl term (m effects) => MonadContr deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Tracing trace m effects) deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects) deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Tracing trace m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) +deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Tracing trace m effects) instance ( Corecursive term , Effectful m diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 9a7e23551..fafd31adf 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -28,7 +28,7 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class MonadEvaluator term value m => MonadAnalysis term value m where +class MonadEvaluator (LocationFor value) term value m => MonadAnalysis term value m where -- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list. type family Effects term value m :: [* -> *] diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 698391134..b23a05b14 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -46,14 +46,14 @@ import Prologue hiding (throwError) -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class ( MonadControl term m - , MonadEnvironment (LocationFor value) value m + , MonadEnvironment location value m , MonadFail m - , MonadModuleTable (LocationFor value) term value m - , MonadHeap (LocationFor value) value m + , MonadModuleTable location term value m + , MonadHeap location value m ) - => MonadEvaluator term value m | m -> term, m -> value where + => MonadEvaluator location term value m | m -> location, m -> term, m -> value where -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord (LocationFor value) => term -> m (ConfigurationFor term value) + getConfiguration :: Ord location => term -> m (Configuration location term value) -- | Retrieve the stack of modules currently being evaluated. -- From c4fcb23601841feec8ffe9d34c5c194487b3021c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 21:06:00 -0400 Subject: [PATCH 24/58] Parameterize MonadValue by the location type. --- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/Quiet.hs | 2 +- src/Control/Abstract/Value.hs | 38 +++++++++++++-------------- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Located.hs | 2 +- src/Data/Abstract/Type.hs | 2 +- src/Data/Abstract/Value.hs | 6 ++--- src/Semantic/Util.hs | 4 +-- 9 files changed, 30 insertions(+), 30 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index d77866751..dc8d55c35 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -21,7 +21,7 @@ instance ( Effectful m , Member (Resumable (EvalError value)) effects , Member (State [Name]) effects , MonadAnalysis term value (m effects) - , MonadValue value (BadVariables m effects) + , MonadValue (LocationFor value) value (BadVariables m effects) ) => MonadAnalysis term value (BadVariables m effects) where type Effects term value (BadVariables m effects) = State [Name] ': Effects term value (m effects) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index ec3298ffc..b13652039 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -144,7 +144,7 @@ instance ( location ~ LocationFor value askModuleStack = raise ask instance ( Members (EvaluatingEffects term value) effects - , MonadValue value (Evaluating term value effects) + , MonadValue (LocationFor value) value (Evaluating term value effects) ) => MonadAnalysis term value (Evaluating term value effects) where type Effects term value (Evaluating term value effects) = EvaluatingEffects term value diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 46d0eea51..804719a05 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -26,7 +26,7 @@ deriving instance MonadEvaluator location term value (m effects) => MonadEvalu instance ( Effectful m , Member (Resumable (Unspecialized value)) effects , MonadAnalysis term value (m effects) - , MonadValue value (Quietly m effects) + , MonadValue (LocationFor value) value (Quietly m effects) ) => MonadAnalysis term value (Quietly m effects) where type Effects term value (Quietly m effects) = Effects term value (m effects) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 892c5b2c8..c9394f9c1 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-} module Control.Abstract.Value ( MonadValue(..) , Comparator(..) @@ -21,7 +21,7 @@ module Control.Abstract.Value import Control.Abstract.Evaluator import Data.Abstract.FreeVariables import Data.Abstract.Environment as Env -import Data.Abstract.Address (Address) +import Data.Abstract.Address (Address, Cell) import Data.Abstract.Number as Number import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) @@ -41,7 +41,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 (Monad m, Show value) => MonadValue value m where +class (Monad m, Show value) => MonadValue location value m | m value -> location where -- | Construct an abstract unit value. -- TODO: This might be the same as the empty tuple for some value types unit :: m value @@ -114,20 +114,20 @@ class (Monad m, Show value) => MonadValue value m where null :: m value -- | Build a class value from a name and environment. - klass :: Name -- ^ The new class's identifier - -> [value] -- ^ A list of superclasses - -> EnvironmentFor value -- ^ The environment to capture + klass :: Name -- ^ The new class's identifier + -> [value] -- ^ A list of superclasses + -> Environment location value -- ^ The environment to capture -> m value -- | Build a namespace value from a name and environment stack -- -- Namespaces model closures with monoidal environments. - namespace :: Name -- ^ The namespace's identifier - -> EnvironmentFor value -- ^ The environment to mappend + namespace :: Name -- ^ The namespace's identifier + -> Environment location value -- ^ The environment to mappend -> m value -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). - scopedEnvironment :: value -> m (EnvironmentFor value) + scopedEnvironment :: value -> m (Environment location value) -- | Evaluate an abstraction (a binder like a lambda or method definition). abstract :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value @@ -141,10 +141,10 @@ class (Monad m, Show value) => MonadValue value m where -- | Attempt to extract a 'Prelude.Bool' from a given value. -toBool :: MonadValue value m => value -> m Bool +toBool :: MonadValue location value m => value -> m Bool toBool v = ifthenelse v (pure True) (pure False) -forLoop :: (MonadEnvironment (LocationFor value) value m, MonadValue value m) +forLoop :: (MonadEnvironment location value m, MonadValue location value m) => m value -- ^ Initial statement -> m value -- ^ Condition -> m value -- ^ Increment/stepper @@ -154,7 +154,7 @@ forLoop initial cond step body = localize (initial *> while cond (body *> step)) -- | The fundamental looping primitive, built on top of ifthenelse. -while :: MonadValue value m +while :: MonadValue location value m => m value -> m value -> m value @@ -163,7 +163,7 @@ while cond body = loop $ \ continue -> do ifthenelse this (body *> continue) unit -- | Do-while loop, built on top of while. -doWhile :: MonadValue value m +doWhile :: MonadValue location value m => m value -> m value -> m value @@ -171,14 +171,14 @@ doWhile body cond = loop $ \ continue -> body *> do this <- cond ifthenelse this continue unit -makeNamespace :: ( MonadValue value m - , MonadEnvironment (LocationFor value) value m - , MonadHeap (LocationFor value) value m - , Ord (LocationFor value) - , Reducer value (CellFor value) +makeNamespace :: ( MonadValue location value m + , MonadEnvironment location value m + , MonadHeap location value m + , Ord location + , Reducer value (Cell location value) ) => Name - -> Address (LocationFor value) value + -> Address location value -> [value] -> m value makeNamespace name addr supers = do diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 1aa0d3728..a8f11ae01 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -37,7 +37,7 @@ type MonadEvaluatable term value m = , MonadThrow (ValueExc value) m , MonadThrow (LoadError term value) m , MonadThrow (EvalError value) m - , MonadValue value m + , MonadValue (LocationFor value) value m , Recursive term , Show (LocationFor value) ) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 4ca87e016..612d7b668 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -28,7 +28,7 @@ newtype LocatedValue value = LocatedValue { unLocatedValue :: value } instance AbstractValue (LocatedValue value) where type LocationFor (LocatedValue value) = Located (LocationFor value) -instance MonadValue value m => MonadValue (LocatedValue value) m where +instance MonadValue (Located location) value m => MonadValue (Located location) (LocatedValue value) m where unit = LocatedValue <$> unit null = LocatedValue <$> null integer = fmap LocatedValue . integer diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 6368672f5..1481b845e 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -52,7 +52,7 @@ instance ValueRoots Type where -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance (Alternative m, MonadEnvironment Monovariant Type m, MonadFail m, MonadFresh m, MonadHeap Monovariant Type m) => MonadValue Type m where +instance (Alternative m, MonadEnvironment Monovariant Type m, MonadFail m, MonadFresh m, MonadHeap Monovariant Type m) => MonadValue Monovariant Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 016170cc0..9c9e6dc5f 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -195,7 +195,7 @@ instance ValueRoots Value where -- | Construct a 'Value' wrapping the value arguments (if any). -instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where +instance (Monad m, MonadEvaluatable term Value m) => MonadValue Precise Value m where unit = pure . injValue $ Unit integer = pure . injValue . Integer . Number.Integer boolean = pure . injValue . Boolean @@ -262,7 +262,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) where -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor - specialize :: MonadValue value m => Number.SomeNumber -> m value + specialize :: MonadValue Precise value m => Number.SomeNumber -> m value specialize (Number.SomeNumber (Number.Integer i)) = integer i specialize (Number.SomeNumber (Number.Ratio r)) = rational r specialize (Number.SomeNumber (Number.Decimal d)) = float d @@ -280,7 +280,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where where -- Explicit type signature is necessary here because we're passing all sorts of things -- to these comparison functions. - go :: (Ord a, MonadValue value m) => a -> a -> m value + go :: (Ord a, MonadValue Precise value m) => a -> a -> m value go l r = case comparator of Concrete f -> boolean (f l r) Generalized -> integer (orderingToInt (compare l r)) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index f99a2957c..111f94f8b 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -84,7 +84,7 @@ evaluateWith :: forall value term effects , Evaluatable (Base term) , FreeVariables term , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue value (Evaluating term value effects) + , MonadValue (LocationFor value) value (Evaluating term value effects) , Recursive term , Show (LocationFor value) ) @@ -137,7 +137,7 @@ evaluatesWith :: forall value term effects , Evaluatable (Base term) , FreeVariables term , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue value (Evaluating term value effects) + , MonadValue (LocationFor value) value (Evaluating term value effects) , Recursive term , Show (LocationFor value) ) From 1689b622ba741e4e7ffa195d084550db21afa8ec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 21:36:11 -0400 Subject: [PATCH 25/58] Parameterize MonadAnalysis by the location type. --- src/Analysis/Abstract/BadVariables.hs | 8 +- src/Analysis/Abstract/Caching.hs | 12 +-- src/Analysis/Abstract/Collecting.hs | 42 +++++------ src/Analysis/Abstract/Dead.hs | 6 +- src/Analysis/Abstract/Evaluating.hs | 103 ++++++++++++-------------- src/Analysis/Abstract/ImportGraph.hs | 6 +- src/Analysis/Abstract/Quiet.hs | 8 +- src/Analysis/Abstract/Tracing.hs | 15 ++-- src/Control/Abstract/Analysis.hs | 8 +- src/Control/Abstract/Value.hs | 5 +- src/Data/Abstract/Evaluatable.hs | 36 ++++----- src/Data/Abstract/Type.hs | 2 +- src/Data/Abstract/Value.hs | 4 +- src/Language/PHP/Syntax.hs | 4 +- src/Language/Ruby/Syntax.hs | 6 +- src/Semantic/Util.hs | 64 ++++++++-------- 16 files changed, 163 insertions(+), 166 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index dc8d55c35..ba2a81177 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -20,11 +20,11 @@ deriving instance MonadEvaluator location term value (m effects) => MonadEvalu instance ( Effectful m , Member (Resumable (EvalError value)) effects , Member (State [Name]) effects - , MonadAnalysis term value (m effects) - , MonadValue (LocationFor value) value (BadVariables m effects) + , MonadAnalysis location term value (m effects) + , MonadValue location value (BadVariables m effects) ) - => MonadAnalysis term value (BadVariables m effects) where - type Effects term value (BadVariables m effects) = State [Name] ': Effects term value (m effects) + => MonadAnalysis location term value (BadVariables m effects) where + type Effects location term value (BadVariables m effects) = State [Name] ': Effects location term value (m effects) analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) ( \yield (FreeVariableError name) -> diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index e856f30b1..8699a95b3 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -68,18 +68,18 @@ instance ( Effectful m -- | This instance coinductively iterates the analysis of a term until the results converge. instance ( Corecursive term , Effectful m - , Members (CachingEffects (LocationFor value) term value '[]) effects - , MonadAnalysis term value (m effects) + , Members (CachingEffects location term value '[]) effects + , MonadAnalysis location term value (m effects) , MonadFresh (m effects) , MonadNonDet (m effects) - , Ord (CellFor value) - , Ord (LocationFor value) + , Ord (Cell location value) + , Ord location , Ord term , Ord value ) - => MonadAnalysis term value (Caching m effects) where + => MonadAnalysis location term value (Caching m effects) where -- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'. - type Effects term value (Caching m effects) = CachingEffects (LocationFor value) term value (Effects term value (m effects)) + type Effects location term value (Caching m effects) = CachingEffects location term value (Effects location term value (m effects)) -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. analyzeTerm recur e = do diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 2fa22e6a0..e76e2a0f7 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -29,16 +29,16 @@ instance ( Effectful m instance ( Effectful m - , Foldable (Cell (LocationFor value)) - , Member (Reader (Live (LocationFor value) value)) effects - , MonadAnalysis term value (m effects) - , Ord (LocationFor value) - , ValueRoots value + , Foldable (Cell location) + , Member (Reader (Live location value)) effects + , MonadAnalysis location term value (m effects) + , Ord location + , ValueRoots location value ) - => MonadAnalysis term value (Collecting m effects) where - type Effects term value (Collecting m effects) - = Reader (Live (LocationFor value) value) - ': Effects term value (m effects) + => MonadAnalysis location term value (Collecting m effects) where + type Effects location term value (Collecting m effects) + = Reader (Live location value) + ': Effects location term value (m effects) -- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term. analyzeTerm recur term = do @@ -60,23 +60,23 @@ askRoots = raise ask -- | 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 +gc :: ( Ord location + , Foldable (Cell location) + , ValueRoots location value ) - => LiveFor value -- ^ The set of addresses to consider rooted. - -> HeapFor value -- ^ A heap to collect unreachable addresses within. - -> HeapFor value -- ^ A garbage-collected heap. + => Live location value -- ^ The set of addresses to consider rooted. + -> Heap location value -- ^ A heap to collect unreachable addresses within. + -> Heap location 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 heap. -reachable :: ( Ord (LocationFor value) - , Foldable (Cell (LocationFor value)) - , ValueRoots value +reachable :: ( Ord location + , Foldable (Cell location) + , ValueRoots location value ) - => 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. + => Live location value -- ^ The set of root addresses. + -> Heap location value -- ^ The heap to trace addresses through. + -> Live location 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 diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 3a0b58ca4..f652acb63 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -42,12 +42,12 @@ instance ( Corecursive term , Effectful m , Foldable (Base term) , Member (State (Dead term)) effects - , MonadAnalysis term value (m effects) + , MonadAnalysis location term value (m effects) , Ord term , Recursive term ) - => MonadAnalysis term value (DeadCode m effects) where - type Effects term value (DeadCode m effects) = State (Dead term) ': Effects term value (m effects) + => MonadAnalysis location term value (DeadCode m effects) where + type Effects location term value (DeadCode m effects) = State (Dead term) ': Effects location term value (m effects) analyzeTerm recur term = do revive (embedSubterm term) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b13652039..75f6cf6ab 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -6,9 +6,12 @@ module Analysis.Abstract.Evaluating import Control.Abstract.Analysis import Control.Monad.Effect +import Data.Abstract.Address import Data.Abstract.Configuration -import qualified Data.Abstract.Environment as Env +import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable +import Data.Abstract.Exports +import Data.Abstract.Heap import Data.Abstract.Module import Data.Abstract.ModuleTable import qualified Data.IntMap as IntMap @@ -17,69 +20,69 @@ import Prelude hiding (fail) import Prologue -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating term value effects a = Evaluating (Eff effects a) +newtype Evaluating location 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 NonDet effects => Alternative (Evaluating term value effects) -deriving instance Member NonDet effects => MonadNonDet (Evaluating term value effects) +deriving instance Member Fail effects => MonadFail (Evaluating location term value effects) +deriving instance Member Fresh effects => MonadFresh (Evaluating location term value effects) +deriving instance Member NonDet effects => Alternative (Evaluating location term value effects) +deriving instance Member NonDet effects => MonadNonDet (Evaluating location term value effects) -- | Effects necessary for evaluating (whether concrete or abstract). -type EvaluatingEffects term value +type EvaluatingEffects location term value = '[ Resumable (EvalError value) , Resumable (LoadError term value) , Resumable (ValueExc value) , Resumable (Unspecialized value) - , Fail -- Failure with an error message - , Reader [Module term] -- The stack of currently-evaluating modules. - , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules - , Reader (EnvironmentFor value) -- Default environment used as a fallback in lookupEnv - , State (EvaluatingState term value) -- Environment, heap, modules, exports, and jumps. + , Fail -- Failure with an error message + , Reader [Module term] -- The stack of currently-evaluating modules. + , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules + , Reader (Environment location value) -- Default environment used as a fallback in lookupEnv + , State (EvaluatingState location term value) -- Environment, heap, modules, exports, and jumps. ] -data EvaluatingState term value = EvaluatingState - { environment :: EnvironmentFor value - , heap :: HeapFor value - , modules :: ModuleTable (EnvironmentFor value, value) - , exports :: ExportsFor value +data EvaluatingState location term value = EvaluatingState + { environment :: Environment location value + , heap :: Heap location value + , modules :: ModuleTable (Environment location value, value) + , exports :: Exports location value , jumps :: IntMap.IntMap term } -deriving instance (Eq (CellFor value), Eq (LocationFor value), Eq term, Eq value) => Eq (EvaluatingState term value) -deriving instance (Ord (CellFor value), Ord (LocationFor value), Ord term, Ord value) => Ord (EvaluatingState term value) -deriving instance (Show (CellFor value), Show (LocationFor value), Show term, Show value) => Show (EvaluatingState term value) +deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value) => Eq (EvaluatingState location term value) +deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value) => Ord (EvaluatingState location term value) +deriving instance (Show (Cell location value), Show location, Show term, Show value) => Show (EvaluatingState location term value) -instance (Ord (LocationFor value), Semigroup (CellFor value)) => Semigroup (EvaluatingState term value) where +instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where EvaluatingState e1 h1 m1 x1 j1 <> EvaluatingState e2 h2 m2 x2 j2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2) -instance (Ord (LocationFor value), Semigroup (CellFor value)) => Monoid (EvaluatingState term value) where +instance (Ord location, Semigroup (Cell location value)) => Monoid (EvaluatingState location term value) where mempty = EvaluatingState mempty mempty mempty mempty mempty mappend = (<>) -_environment :: Lens' (EvaluatingState term value) (EnvironmentFor value) +_environment :: Lens' (EvaluatingState location term value) (Environment location value) _environment = lens environment (\ s e -> s {environment = e}) -_heap :: Lens' (EvaluatingState term value) (HeapFor value) +_heap :: Lens' (EvaluatingState location term value) (Heap location value) _heap = lens heap (\ s h -> s {heap = h}) -_modules :: Lens' (EvaluatingState term value) (ModuleTable (EnvironmentFor value, value)) +_modules :: Lens' (EvaluatingState location term value) (ModuleTable (Environment location value, value)) _modules = lens modules (\ s m -> s {modules = m}) -_exports :: Lens' (EvaluatingState term value) (ExportsFor value) +_exports :: Lens' (EvaluatingState location term value) (Exports location value) _exports = lens exports (\ s e -> s {exports = e}) -_jumps :: Lens' (EvaluatingState term value) (IntMap.IntMap term) +_jumps :: Lens' (EvaluatingState location term value) (IntMap.IntMap term) _jumps = lens jumps (\ s j -> s {jumps = j}) -(.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects () +(.=) :: Member (State (EvaluatingState location term value)) effects => ASetter (EvaluatingState location term value) (EvaluatingState location term value) a b -> b -> Evaluating location term value effects () lens .= val = raise (modify' (lens .~ val)) -view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a +view :: Member (State (EvaluatingState location term value)) effects => Getting a (EvaluatingState location term value) a -> Evaluating location term value effects a view lens = raise (gets (^. lens)) -localEvaluatingState :: Member (State (EvaluatingState term value)) effects => Lens' (EvaluatingState term value) prj -> (prj -> prj) -> Evaluating term value effects a -> Evaluating term value effects a +localEvaluatingState :: Member (State (EvaluatingState location term value)) effects => Lens' (EvaluatingState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a localEvaluatingState lens f action = do original <- view lens lens .= f original @@ -87,7 +90,7 @@ localEvaluatingState lens f action = do v <$ lens .= original -instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where +instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term (Evaluating location term value effects) where label term = do m <- view _jumps let i = IntMap.size m @@ -96,12 +99,10 @@ instance Members '[Fail, State (EvaluatingState term value)] effects => MonadCon goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure -instance ( location ~ LocationFor value - , Members '[ State (EvaluatingState term value) - , Reader (EnvironmentFor value) - ] effects - ) - => MonadEnvironment location value (Evaluating term value effects) where +instance Members '[ State (EvaluatingState location term value) + , Reader (Environment location value) + ] effects + => MonadEnvironment location value (Evaluating location term value effects) where getEnv = view _environment putEnv = (_environment .=) withEnv s = localEvaluatingState _environment (const s) @@ -118,40 +119,34 @@ instance ( location ~ LocationFor value result <- a result <$ modifyEnv Env.pop -instance ( location ~ LocationFor value - , Member (State (EvaluatingState term value)) effects - ) - => MonadHeap location value (Evaluating term value effects) where +instance Member (State (EvaluatingState location term value)) effects + => MonadHeap location value (Evaluating location term value effects) where getHeap = view _heap putHeap = (_heap .=) -instance ( location ~ LocationFor value - , Members '[Reader (ModuleTable [Module term]), State (EvaluatingState term value)] effects - ) - => MonadModuleTable location term value (Evaluating term value effects) where +instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState location term value)] effects + => MonadModuleTable location term value (Evaluating location term value effects) where getModuleTable = view _modules putModuleTable = (_modules .=) askModuleTable = raise ask localModuleTable f a = raise (local f (lower a)) -instance ( location ~ LocationFor value - , Members (EvaluatingEffects term value) effects - ) - => MonadEvaluator location term value (Evaluating term value effects) where +instance Members (EvaluatingEffects location term value) effects + => MonadEvaluator location term value (Evaluating location term value effects) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap askModuleStack = raise ask -instance ( Members (EvaluatingEffects term value) effects - , MonadValue (LocationFor value) value (Evaluating term value effects) +instance ( Members (EvaluatingEffects location term value) effects + , MonadValue location value (Evaluating location term value effects) ) - => MonadAnalysis term value (Evaluating term value effects) where - type Effects term value (Evaluating term value effects) = EvaluatingEffects term value + => MonadAnalysis location term value (Evaluating location term value effects) where + type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value analyzeTerm = id analyzeModule eval m = pushModule (subterm <$> m) (eval m) -pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating term value effects a -> Evaluating term value effects a +pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating location term value effects a -> Evaluating location term value effects a pushModule m = raise . local (m :) . lower diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 797fde881..6f3396247 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -35,11 +35,11 @@ deriving instance MonadEvaluator location term value (m effects) => MonadEvalu instance ( Effectful m , Member (State ImportGraph) effects - , MonadAnalysis term value (m effects) + , MonadAnalysis location term value (m effects) , Member (Resumable (LoadError term value)) effects ) - => MonadAnalysis term value (ImportGraphing m effects) where - type Effects term value (ImportGraphing m effects) = State ImportGraph ': Effects term value (m effects) + => MonadAnalysis location term value (ImportGraphing m effects) where + type Effects location term value (ImportGraphing m effects) = State ImportGraph ': Effects location term value (m effects) analyzeTerm eval term = resumeException @(LoadError term value) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 804719a05..4b30215a6 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -25,11 +25,11 @@ deriving instance MonadEvaluator location term value (m effects) => MonadEvalu instance ( Effectful m , Member (Resumable (Unspecialized value)) effects - , MonadAnalysis term value (m effects) - , MonadValue (LocationFor value) value (Quietly m effects) + , MonadAnalysis location term value (m effects) + , MonadValue location value (Quietly m effects) ) - => MonadAnalysis term value (Quietly m effects) where - type Effects term value (Quietly m effects) = Effects term value (m effects) + => MonadAnalysis location term value (Quietly m effects) where + type Effects location term value (Quietly m effects) = Effects location term value (m effects) analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 52d534707..7dcd0b23a 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -5,6 +5,7 @@ module Analysis.Abstract.Tracing import Control.Abstract.Analysis import Control.Monad.Effect.Writer +import Data.Abstract.Configuration import Data.Semigroup.Reducer as Reducer import Data.Union import Prologue @@ -23,17 +24,17 @@ deriving instance MonadEvaluator location term value (m effects) => MonadEvalu instance ( Corecursive term , Effectful m - , Member (Writer (trace (ConfigurationFor term value))) effects - , MonadAnalysis term value (m effects) - , Ord (LocationFor value) - , Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value)) + , Member (Writer (trace (Configuration location term value))) effects + , MonadAnalysis location term value (m effects) + , Ord location + , Reducer (Configuration location term value) (trace (Configuration location term value)) ) - => MonadAnalysis term value (Tracing trace m effects) where - type Effects term value (Tracing trace m effects) = Writer (trace (ConfigurationFor term value)) ': Effects term value (m effects) + => MonadAnalysis location term value (Tracing trace m effects) where + type Effects location term value (Tracing trace m effects) = Writer (trace (Configuration location term value)) ': Effects location term value (m effects) analyzeTerm recur term = do config <- getConfiguration (embedSubterm term) - raise (tell @(trace (ConfigurationFor term value)) (Reducer.unit config)) + raise (tell @(trace (Configuration location term value)) (Reducer.unit config)) liftAnalyze analyzeTerm recur term analyzeModule = liftAnalyze analyzeModule diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index fafd31adf..941027d04 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -28,9 +28,9 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class MonadEvaluator (LocationFor value) term value m => MonadAnalysis term value m where +class MonadEvaluator location term value m => MonadAnalysis location term value m where -- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list. - type family Effects term value m :: [* -> *] + type family Effects location term value m :: [* -> *] -- | Analyze a term using the semantics of the current analysis. analyzeTerm :: (Base term (Subterm term (outer value)) -> m value) @@ -56,8 +56,8 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r -- -- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects'). runAnalysis :: ( Effectful m - , Effects term value (m effects) ~ effects - , MonadAnalysis term value (m effects) + , Effects location term value (m effects) ~ effects + , MonadAnalysis location term value (m effects) , RunEffects effects a ) => m effects a diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index c9394f9c1..5e52175ce 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -23,6 +23,7 @@ import Data.Abstract.FreeVariables import Data.Abstract.Environment as Env import Data.Abstract.Address (Address, Cell) import Data.Abstract.Number as Number +import Data.Abstract.Live (Live) import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Prelude @@ -189,9 +190,9 @@ makeNamespace name addr supers = do -- | Value types, e.g. closures, which can root a set of addresses. -class ValueRoots value where +class ValueRoots location value where -- | Compute the set of addresses rooted by a given value. - valueRoots :: value -> LiveFor value + valueRoots :: value -> Live location value -- The type of exceptions that can be thrown when constructing values in `MonadValue`. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a8f11ae01..de9802963 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -17,7 +17,7 @@ module Data.Abstract.Evaluatable import Control.Abstract.Addressable as X import Control.Abstract.Analysis as X -import qualified Data.Abstract.Environment as Env +import Data.Abstract.Environment as X import qualified Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables as X import Data.Abstract.Module @@ -28,18 +28,18 @@ import Data.Term import Prelude hiding (fail) import Prologue -type MonadEvaluatable term value m = +type MonadEvaluatable location term value m = ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) value m - , MonadAnalysis term value m + , MonadAddressable location value m + , MonadAnalysis location term value m , MonadThrow (Unspecialized value) m , MonadThrow (ValueExc value) m , MonadThrow (LoadError term value) m , MonadThrow (EvalError value) m - , MonadValue (LocationFor value) value m + , MonadValue location value m , Recursive term - , Show (LocationFor value) + , Show location ) @@ -66,7 +66,7 @@ instance Show1 (EvalError value) where instance Eq1 (EvalError term) where liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b -throwLoadError :: MonadEvaluatable term value m => LoadError term value resume -> m resume +throwLoadError :: MonadEvaluatable location term value m => LoadError term value resume -> m resume throwLoadError = throwException data Unspecialized a b where @@ -82,7 +82,7 @@ instance Show1 (Unspecialized a) where -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class Evaluatable constr where - eval :: MonadEvaluatable term value m + eval :: MonadEvaluatable location term value m => SubtermAlgebra constr term (m value) default eval :: (MonadThrow (Unspecialized value) m, Show1 constr) => SubtermAlgebra constr term (m value) eval expr = throwException (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "")) @@ -110,17 +110,17 @@ instance Evaluatable [] where -- | Require/import another module by name and return it's environment and value. -- -- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. -require :: MonadEvaluatable term value m +require :: MonadEvaluatable location term value m => ModuleName - -> m (EnvironmentFor value, value) + -> m (Environment location value, value) require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup name -- | Load another module by name and return it's environment and value. -- -- Always loads/evaluates. -load :: MonadEvaluatable term value m +load :: MonadEvaluatable location term value m => ModuleName - -> m (EnvironmentFor value, value) + -> m (Environment location value, value) load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache where notFound = throwLoadError (LoadError name) @@ -141,36 +141,36 @@ load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. - filterEnv :: Exports.Exports l a -> Env.Environment l a -> Env.Environment l a + filterEnv :: Exports.Exports l a -> Environment l a -> Environment l a filterEnv ports env | Exports.null ports = env - | otherwise = Exports.toEnvironment ports <> Env.overwrite (Exports.aliases ports) env + | otherwise = Exports.toEnvironment ports <> overwrite (Exports.aliases ports) env -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadEvaluatable term value m +evaluateTerm :: MonadEvaluatable location term value m => term -> m value evaluateTerm = foldSubterms (analyzeTerm eval) -- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs, or (via 'evaluateModules') the entry point of multi-term programs. -evaluateModule :: MonadEvaluatable term value m +evaluateModule :: MonadEvaluatable location term value m => Module term -> m value evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m) -- | Run an action with the a list of 'Module's available for imports. -withModules :: MonadEvaluatable term value m +withModules :: MonadEvaluatable location term value m => [Module term] -> m a -> m a withModules = localModuleTable . const . ModuleTable.fromList -- | Evaluate with a list of modules in scope, taking the head module as the entry point. -evaluateModules :: MonadEvaluatable term value m +evaluateModules :: MonadEvaluatable location term value m => [Module term] -> m value evaluateModules [] = fail "evaluateModules: empty list" diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 1481b845e..7c610d4fa 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -47,7 +47,7 @@ instance AbstractValue Type where type LocationFor Type = Monovariant -instance ValueRoots Type where +instance ValueRoots Monovariant Type where valueRoots _ = mempty diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 9c9e6dc5f..73d1b37ad 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -188,14 +188,14 @@ instance AbstractValue Value where type LocationFor Value = Precise -instance ValueRoots Value where +instance ValueRoots Precise Value where valueRoots v | Just (Closure _ _ env) <- prjValue v = Env.addresses env | otherwise = mempty -- | Construct a 'Value' wrapping the value arguments (if any). -instance (Monad m, MonadEvaluatable term Value m) => MonadValue Precise Value m where +instance (Monad m, MonadEvaluatable Precise term Value m) => MonadValue Precise Value m where unit = pure . injValue $ Unit integer = pure . injValue . Integer . Number.Integer boolean = pure . injValue . Boolean diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index eac43c8a4..5a383b643 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -33,14 +33,14 @@ instance Evaluatable VariableName -- file, the complete contents of the included file are treated as though it -- were defined inside that function. -doInclude :: MonadEvaluatable term value m => Subterm t (m value) -> m value +doInclude :: MonadEvaluatable location term value m => Subterm t (m value) -> m value doInclude path = do name <- toQualifiedName <$> (subtermValue path >>= asString) (importedEnv, v) <- isolate (load name) modifyEnv (mappend importedEnv) pure v -doIncludeOnce :: MonadEvaluatable term value m => Subterm t (m value) -> m value +doIncludeOnce :: MonadEvaluatable location term value m => Subterm t (m value) -> m value doIncludeOnce path = do name <- toQualifiedName <$> (subtermValue path >>= asString) (importedEnv, v) <- isolate (require name) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index a3f59c6ef..3c3d49a93 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -25,9 +25,9 @@ instance Evaluatable Require where where toName = qualifiedName . splitOnPathSeparator . dropRelativePrefix . stripQuotes -doRequire :: MonadEvaluatable term value m +doRequire :: MonadEvaluatable location term value m => ModuleName - -> m (EnvironmentFor value, value) + -> m (Environment location value, value) doRequire name = do moduleTable <- getModuleTable case moduleTableLookup name moduleTable of @@ -52,7 +52,7 @@ instance Evaluatable Load where doLoad path shouldWrap eval (Load _) = fail "invalid argument supplied to load, path is required" -doLoad :: MonadEvaluatable term value m => ByteString -> Bool -> m value +doLoad :: MonadEvaluatable location term value m => ByteString -> Bool -> m value doLoad path shouldWrap = do (importedEnv, _) <- isolate (load (toName path)) unless shouldWrap $ modifyEnv (mappend importedEnv) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 111f94f8b..b940bf473 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -12,7 +12,7 @@ import Analysis.Abstract.Tracing import Analysis.Declaration import Control.Abstract.Analysis import Control.Monad.IO.Class -import Data.Abstract.Evaluatable +import Data.Abstract.Evaluatable hiding (head) import Data.Abstract.Address import Data.Abstract.Module import Data.Abstract.Type @@ -42,27 +42,27 @@ import qualified Language.TypeScript.Assignment as TypeScript -- Ruby evaluateRubyFile = evaluateWithPrelude rubyParser evaluateRubyFiles = evaluateFilesWithPrelude rubyParser -evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths -evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths +evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Precise Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths +evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths -- Go evaluateGoFile = evaluateFile goParser evaluateGoFiles = evaluateFiles goParser -typecheckGoFile path = runAnalysis @(Caching (Evaluating Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path +typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path -- Python evaluatePythonFile = evaluateWithPrelude pythonParser evaluatePythonFiles = evaluateFilesWithPrelude pythonParser -typecheckPythonFile path = runAnalysis @(Caching (Evaluating Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path -tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Python.Term Value)) . evaluateModule <$> parseFile pythonParser Nothing path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Python.Term Value))) . evaluateModule <$> parseFile pythonParser Nothing path +typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path +tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term Value)) . evaluateModule <$> parseFile pythonParser Nothing path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term Value))) . evaluateModule <$> parseFile pythonParser Nothing path -- PHP evaluatePHPFile = evaluateFile phpParser evaluatePHPFiles = evaluateFiles phpParser -- TypeScript -typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path +typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path evaluateTypeScriptFile = evaluateFile typescriptParser evaluateTypeScriptFiles = evaluateFiles typescriptParser @@ -70,28 +70,28 @@ evaluateTypeScriptFiles = evaluateFiles typescriptParser evaluateFile :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ Effects term Value (Evaluating term Value effects) - , MonadAddressable Precise Value (Evaluating term Value effects) + , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) + , MonadAddressable Precise Value (Evaluating Precise term Value effects) , Recursive term ) => Parser term -> FilePath -> IO (Final effects Value) -evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule <$> parseFile parser Nothing path +evaluateFile parser path = runAnalysis @(Evaluating Precise term Value) . evaluateModule <$> parseFile parser Nothing path -evaluateWith :: forall value term effects - . ( effects ~ Effects term value (Evaluating term value effects) +evaluateWith :: forall location value term effects + . ( effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue (LocationFor value) value (Evaluating term value effects) + , MonadAddressable location value (Evaluating location term value effects) + , MonadValue location value (Evaluating location term value effects) , Recursive term - , Show (LocationFor value) + , Show location ) => Module term -> Module term -> Final effects value -evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do +evaluateWith prelude m = runAnalysis @(Evaluating location term value) $ do -- TODO: we could add evaluatePrelude to MonadAnalysis as an alias for evaluateModule, -- overridden in Evaluating to not reset the environment. In the future we'll want the -- result of evaluating the Prelude to be a build artifact, rather than something that's @@ -103,8 +103,8 @@ evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do evaluateWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ Effects term Value (Evaluating term Value effects) - , MonadAddressable Precise Value (Evaluating term Value effects) + , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) + , MonadAddressable Precise Value (Evaluating Precise term Value effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) ) @@ -115,45 +115,45 @@ evaluateWithPrelude parser path = do let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) prelude <- parseFile parser Nothing preludePath m <- parseFile parser Nothing path - pure $ evaluateWith prelude m + pure $ evaluateWith @Precise prelude m -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ Effects term Value (Evaluating term Value effects) - , MonadAddressable Precise Value (Evaluating term Value effects) + , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) + , MonadAddressable Precise Value (Evaluating Precise term Value effects) , Recursive term ) => Parser term -> [FilePath] -> IO (Final effects Value) -evaluateFiles parser paths = runAnalysis @(Evaluating term Value) . evaluateModules <$> parseFiles parser paths +evaluateFiles parser paths = runAnalysis @(Evaluating Precise term Value) . evaluateModules <$> parseFiles parser paths -- | Evaluate terms and an entry point to a value with a given prelude. -evaluatesWith :: forall value term effects - . ( effects ~ Effects term value (Evaluating term value effects) +evaluatesWith :: forall location value term effects + . ( effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) value (Evaluating term value effects) - , MonadValue (LocationFor value) value (Evaluating term value effects) + , MonadAddressable location value (Evaluating location term value effects) + , MonadValue location value (Evaluating location term value effects) , Recursive term - , Show (LocationFor value) + , Show location ) => Module term -- ^ Prelude to evaluate once -> [Module term] -- ^ List of (blob, term) pairs that make up the program to be evaluated -> Module term -- ^ Entrypoint -> Final effects value -evaluatesWith prelude modules m = runAnalysis @(Evaluating term value) $ do +evaluatesWith prelude modules m = runAnalysis @(Evaluating location term value) $ do preludeEnv <- evaluateModule prelude *> getEnv withDefaultEnvironment preludeEnv (withModules modules (evaluateModule m)) evaluateFilesWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ Effects term Value (Evaluating term Value effects) - , MonadAddressable Precise Value (Evaluating term Value effects) + , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) + , MonadAddressable Precise Value (Evaluating Precise term Value effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) ) @@ -164,7 +164,7 @@ evaluateFilesWithPrelude parser paths = do let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) prelude <- parseFile parser Nothing preludePath entry:xs <- traverse (parseFile parser Nothing) paths - pure $ evaluatesWith @Value prelude xs entry + pure $ evaluatesWith @Precise @Value prelude xs entry -- Read and parse a file. From 37ac53fdd8a98c34fe098420e288fa4da5cc0c46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 21:37:23 -0400 Subject: [PATCH 26/58] :fire: a redundant constraint. --- src/Control/Abstract/Addressable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 3be78ea4d..f47a634e1 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -63,7 +63,7 @@ instance (MonadFail m, MonadHeap Precise value m) => MonadAddressable Precise va addr <$ modifyHeap (heapInit addr mempty) -- | '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 Monovariant value m, Ord value) => MonadAddressable Monovariant value m where +instance (Alternative m, MonadFail m, MonadHeap Monovariant value m, Ord value) => MonadAddressable Monovariant value m where deref = derefWith (foldMapA pure) alloc = pure . Address . Monovariant From 7641b20d067143f2af1601abbcc349ad01cc14e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 21:37:33 -0400 Subject: [PATCH 27/58] :fire: some obsolete comments referencing LocationFor. --- src/Analysis/Abstract/Collecting.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index e76e2a0f7..c93901aa4 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -55,7 +55,7 @@ askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m ef askRoots = raise ask -- | Run a computation with the given 'Live' set added to the local root set. --- extraRoots :: (Effectful m, Member (Reader (Live (LocationFor value) value)) effects, Ord (LocationFor value)) => Live (LocationFor value) value -> m effects a -> m effects a +-- extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a -- extraRoots roots = raise . local (<> roots) . lower From 6fff42835216b2c8ae19b9ea69269d7e49ab591d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 21:39:34 -0400 Subject: [PATCH 28/58] Parameterize ValueExc by the location type. --- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Control/Abstract/Value.hs | 16 ++++++++-------- src/Data/Abstract/Evaluatable.hs | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 75f6cf6ab..b74407c65 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -32,7 +32,7 @@ deriving instance Member NonDet effects => MonadNonDet (Evaluating location term type EvaluatingEffects location term value = '[ Resumable (EvalError value) , Resumable (LoadError term value) - , Resumable (ValueExc value) + , Resumable (ValueExc location value) , Resumable (Unspecialized value) , Fail -- Failure with an error message , Reader [Module term] -- The stack of currently-evaluating modules. diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 5e52175ce..667ac3295 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -196,19 +196,19 @@ class ValueRoots location value where -- The type of exceptions that can be thrown when constructing values in `MonadValue`. -data ValueExc value resume where - TypeError :: Prelude.String -> ValueExc value value - StringError :: Prelude.String -> ValueExc value ByteString - NamespaceError :: Prelude.String -> ValueExc value (EnvironmentFor value) - ScopedEnvironmentError :: Prelude.String -> ValueExc value (EnvironmentFor value) +data ValueExc location value resume where + TypeError :: Prelude.String -> ValueExc location value value + StringError :: Prelude.String -> ValueExc location value ByteString + NamespaceError :: Prelude.String -> ValueExc location value (Environment location value) + ScopedEnvironmentError :: Prelude.String -> ValueExc location value (Environment location value) -instance Eq1 (ValueExc value) where +instance Eq1 (ValueExc location value) where liftEq _ (TypeError a) (TypeError b) = a == b liftEq _ (StringError a) (StringError b) = a == b liftEq _ (NamespaceError a) (NamespaceError b) = a == b liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b liftEq _ _ _ = False -deriving instance Show (ValueExc value resume) -instance Show1 (ValueExc value) where +deriving instance Show (ValueExc location value resume) +instance Show1 (ValueExc location value) where liftShowsPrec _ _ = showsPrec diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index de9802963..5ee7a1b3d 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -34,7 +34,7 @@ type MonadEvaluatable location term value m = , MonadAddressable location value m , MonadAnalysis location term value m , MonadThrow (Unspecialized value) m - , MonadThrow (ValueExc value) m + , MonadThrow (ValueExc location value) m , MonadThrow (LoadError term value) m , MonadThrow (EvalError value) m , MonadValue location value m From b8d1369cc73e3b34131edbd743290934cc840c1d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 21:40:32 -0400 Subject: [PATCH 29/58] :fire: the re-exports of the *For synonyms. --- src/Control/Abstract/Value.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 667ac3295..643abebeb 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -9,13 +9,6 @@ module Control.Abstract.Value , makeNamespace , ValueRoots(..) , ValueExc(..) -, EnvironmentFor -, ExportsFor -, HeapFor -, CellFor -, LiveFor -, LocationFor -, ConfigurationFor ) where import Control.Abstract.Evaluator From d3725cbab0aba68facbabdb699e74ef0d1e99aaf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 21:41:38 -0400 Subject: [PATCH 30/58] :fire: the *For type synonyms. --- src/Control/Abstract/Evaluator.hs | 32 ------------------------------- src/Data/Abstract/Located.hs | 3 --- src/Data/Abstract/Type.hs | 4 ---- src/Data/Abstract/Value.hs | 4 ---- 4 files changed, 43 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index b23a05b14..1dc950491 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -15,14 +15,6 @@ module Control.Abstract.Evaluator , modifyModuleTable , MonadControl(..) , MonadThrow(..) - -- Type synonyms specialized for location types - , CellFor - , ConfigurationFor - , EnvironmentFor - , ExportsFor - , HeapFor - , LiveFor - , AbstractValue(..) ) where import Control.Effect @@ -33,7 +25,6 @@ import Data.Abstract.Environment as Env import Data.Abstract.Exports as Export import Data.Abstract.FreeVariables import Data.Abstract.Heap -import Data.Abstract.Live import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Semigroup.Reducer @@ -185,26 +176,3 @@ class Monad m => MonadThrow exc m where instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => MonadThrow exc (m effects) where throwException = raise . throwError - - --- | The cell for an abstract value type. -type CellFor value = Cell (LocationFor value) value - --- | The configuration for term and abstract value types. -type ConfigurationFor term value = Configuration (LocationFor value) term value - --- | The environment for an abstract value type. -type EnvironmentFor value = Env.Environment (LocationFor value) value - --- | The exports for an abstract value type. -type ExportsFor value = Export.Exports (LocationFor value) value - --- | The 'Heap' for an abstract value type. -type HeapFor value = Heap (LocationFor value) value - --- | The address set type for an abstract value type. -type LiveFor value = Live (LocationFor value) value - -class AbstractValue value where - -- | The location type (the body of 'Address'es) which should be used for an abstract value type. - type LocationFor value :: * diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 612d7b668..ff5d49b03 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -25,9 +25,6 @@ instance Location location => Location (Located location) where newtype LocatedValue value = LocatedValue { unLocatedValue :: value } deriving (Eq, Ord, Show) -instance AbstractValue (LocatedValue value) where - type LocationFor (LocatedValue value) = Located (LocationFor value) - instance MonadValue (Located location) value m => MonadValue (Located location) (LocatedValue value) m where unit = LocatedValue <$> unit null = LocatedValue <$> null diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 7c610d4fa..1c4b133f4 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -43,10 +43,6 @@ unify t1 t2 | otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2) -instance AbstractValue Type where - type LocationFor Type = Monovariant - - instance ValueRoots Monovariant Type where valueRoots _ = mempty diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 73d1b37ad..67113576d 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -184,10 +184,6 @@ instance Ord1 Null where liftCompare = genericLiftCompare instance Show1 Null where liftShowsPrec = genericLiftShowsPrec -instance AbstractValue Value where - type LocationFor Value = Precise - - instance ValueRoots Precise Value where valueRoots v | Just (Closure _ _ env) <- prjValue v = Env.addresses env From 8b4c6cf439b6f53eedbff4b4129cf39ffc423e7a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 21:56:43 -0400 Subject: [PATCH 31/58] :fire: the value parameter from MonadAddressable. --- src/Control/Abstract/Addressable.hs | 23 +++++++++++++---------- src/Data/Abstract/Evaluatable.hs | 5 ++++- src/Semantic/Util.hs | 15 +++++++++------ 3 files changed, 26 insertions(+), 17 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index f47a634e1..ddbf568a6 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -13,23 +13,25 @@ import Prelude hiding (fail) import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. -class (Monad m, Ord location, Reducer value (Cell location value)) => MonadAddressable location value m where - deref :: Address location value -> m value +class (Monad m, Ord location) => MonadAddressable location m where + deref :: MonadHeap location value m => Address location value -> m value - alloc :: Name -> m (Address location value) + alloc :: MonadHeap location value m => Name -> m (Address location value) -- | Look up or allocate an address for a 'Name'. -lookupOrAlloc :: ( MonadAddressable location value m +lookupOrAlloc :: ( MonadAddressable location m , MonadEnvironment location value m + , MonadHeap location value m ) - => Name - -> m (Address location value) + => Name + -> m (Address location value) lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure -letrec :: ( MonadAddressable location value m +letrec :: ( MonadAddressable location m , MonadEnvironment location value m , MonadHeap location value m + , Reducer value (Cell location value) ) => Name -> m value @@ -41,8 +43,9 @@ letrec name body = do pure (v, addr) -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. -letrec' :: ( MonadAddressable location value m +letrec' :: ( MonadAddressable location m , MonadEnvironment location value m + , MonadHeap location value m ) => Name -> (Address location value -> m value) @@ -55,7 +58,7 @@ 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, MonadHeap Precise value m) => MonadAddressable Precise value m where +instance MonadFail m => MonadAddressable Precise m where deref = derefWith (maybeM uninitializedAddress . unLatest) alloc _ = do -- Compute the next available address in the heap, then write an empty value into it. @@ -63,7 +66,7 @@ instance (MonadFail m, MonadHeap Precise value m) => MonadAddressable Precise va addr <$ modifyHeap (heapInit addr mempty) -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, MonadFail m, MonadHeap Monovariant value m, Ord value) => MonadAddressable Monovariant value m where +instance (Alternative m, MonadFail m) => MonadAddressable Monovariant m where deref = derefWith (foldMapA pure) alloc = pure . Address . Monovariant diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 5ee7a1b3d..4acb24065 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -17,6 +17,7 @@ module Data.Abstract.Evaluatable import Control.Abstract.Addressable as X import Control.Abstract.Analysis as X +import Data.Abstract.Address import Data.Abstract.Environment as X import qualified Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables as X @@ -24,6 +25,7 @@ import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Semigroup.App import Data.Semigroup.Foldable +import Data.Semigroup.Reducer hiding (unit) import Data.Term import Prelude hiding (fail) import Prologue @@ -31,7 +33,7 @@ import Prologue type MonadEvaluatable location term value m = ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable location value m + , MonadAddressable location m , MonadAnalysis location term value m , MonadThrow (Unspecialized value) m , MonadThrow (ValueExc location value) m @@ -39,6 +41,7 @@ type MonadEvaluatable location term value m = , MonadThrow (EvalError value) m , MonadValue location value m , Recursive term + , Reducer value (Cell location value) , Show location ) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b940bf473..841ad2089 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -21,6 +21,7 @@ import Data.Blob import Data.Diff import Data.Range import Data.Record +import Data.Semigroup.Reducer import Data.Span import Data.Term import Diffing.Algorithm @@ -71,7 +72,7 @@ evaluateFile :: forall term effects . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) - , MonadAddressable Precise Value (Evaluating Precise term Value effects) + , MonadAddressable Precise (Evaluating Precise term Value effects) , Recursive term ) => Parser term @@ -83,9 +84,10 @@ evaluateWith :: forall location value term effects . ( effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term - , MonadAddressable location value (Evaluating location term value effects) + , MonadAddressable location (Evaluating location term value effects) , MonadValue location value (Evaluating location term value effects) , Recursive term + , Reducer value (Cell location value) , Show location ) => Module term @@ -104,7 +106,7 @@ evaluateWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) - , MonadAddressable Precise Value (Evaluating Precise term Value effects) + , MonadAddressable Precise (Evaluating Precise term Value effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) ) @@ -123,7 +125,7 @@ evaluateFiles :: forall term effects . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) - , MonadAddressable Precise Value (Evaluating Precise term Value effects) + , MonadAddressable Precise (Evaluating Precise term Value effects) , Recursive term ) => Parser term @@ -136,9 +138,10 @@ evaluatesWith :: forall location value term effects . ( effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term - , MonadAddressable location value (Evaluating location term value effects) + , MonadAddressable location (Evaluating location term value effects) , MonadValue location value (Evaluating location term value effects) , Recursive term + , Reducer value (Cell location value) , Show location ) => Module term -- ^ Prelude to evaluate once @@ -153,7 +156,7 @@ evaluateFilesWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) - , MonadAddressable Precise Value (Evaluating Precise term Value effects) + , MonadAddressable Precise (Evaluating Precise term Value effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) ) From cf00b9c1ed9927cfbde754d35738d5a91dd14f1e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:03:21 -0400 Subject: [PATCH 32/58] Decouple Value from Precise. --- src/Data/Abstract/Value.hs | 57 +++++++++++++++++++------------------- src/Semantic/Util.hs | 38 ++++++++++++------------- 2 files changed, 47 insertions(+), 48 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 67113576d..004e08306 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -2,7 +2,6 @@ module Data.Abstract.Value where import Control.Abstract.Analysis -import Data.Abstract.Address import Data.Abstract.Environment (Environment) import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable @@ -13,16 +12,16 @@ import Prologue hiding (TypeError) import Prelude hiding (Float, Integer, String, Rational, fail) import qualified Prelude -type ValueConstructors +type ValueConstructors location = '[Array , Boolean - , Class - , Closure + , Class location + , Closure location , Float , Hash , Integer , KVPair - , Namespace + , Namespace location , Null , Rational , String @@ -33,32 +32,32 @@ type ValueConstructors -- | Open union of primitive values that terms can be evaluated to. -- Fix by another name. -newtype Value = Value { deValue :: Union ValueConstructors Value } +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) => f Value -> Value +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) => Value -> Maybe (f Value) +prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location)) prjValue = prj . deValue -- | Convenience function for projecting two values. -prjPair :: (f :< ValueConstructors , g :< ValueConstructors) - => (Value, Value) - -> Maybe (f Value, g Value) +prjPair :: (f :< ValueConstructors location , g :< ValueConstructors location) + => (Value location, Value location) + -> Maybe (f (Value location), g (Value location)) 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 value = Closure [Name] Label (Environment Precise value) +data Closure location value = Closure [Name] Label (Environment location value) deriving (Eq, Generic1, Ord, Show) -instance Eq1 Closure where liftEq = genericLiftEq -instance Ord1 Closure where liftCompare = genericLiftCompare -instance Show1 Closure 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 @@ -138,23 +137,23 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec -- | Class values. There will someday be a difference between classes and objects, -- but for the time being we're pretending all languages have prototypical inheritance. -data Class value = Class +data Class location value = Class { _className :: Name - , _classScope :: Environment Precise value + , _classScope :: Environment location value } deriving (Eq, Generic1, Ord, Show) -instance Eq1 Class where liftEq = genericLiftEq -instance Ord1 Class where liftCompare = genericLiftCompare -instance Show1 Class where liftShowsPrec = genericLiftShowsPrec +instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq +instance Ord location => Ord1 (Class location) where liftCompare = genericLiftCompare +instance Show location => Show1 (Class location) where liftShowsPrec = genericLiftShowsPrec -data Namespace value = Namespace +data Namespace location value = Namespace { namespaceName :: Name - , namespaceScope :: Environment Precise value + , namespaceScope :: Environment location value } deriving (Eq, Generic1, Ord, Show) -instance Eq1 Namespace where liftEq = genericLiftEq -instance Ord1 Namespace where liftCompare = genericLiftCompare -instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec +instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq +instance Ord location => Ord1 (Namespace location) where liftCompare = genericLiftCompare +instance Show location => Show1 (Namespace location) where liftShowsPrec = genericLiftShowsPrec data KVPair value = KVPair value value deriving (Eq, Generic1, Ord, Show) @@ -184,14 +183,14 @@ instance Ord1 Null where liftCompare = genericLiftCompare instance Show1 Null where liftShowsPrec = genericLiftShowsPrec -instance ValueRoots Precise Value where +instance Ord location => ValueRoots location (Value location) where valueRoots v | Just (Closure _ _ env) <- prjValue v = Env.addresses env | otherwise = mempty -- | Construct a 'Value' wrapping the value arguments (if any). -instance (Monad m, MonadEvaluatable Precise term Value m) => MonadValue Precise Value m where +instance (Monad m, MonadEvaluatable location term (Value location) m) => MonadValue location (Value location) m where unit = pure . injValue $ Unit integer = pure . injValue . Integer . Number.Integer boolean = pure . injValue . Boolean @@ -258,7 +257,7 @@ instance (Monad m, MonadEvaluatable Precise term Value m) => MonadValue Precise | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) where -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor - specialize :: MonadValue Precise value m => Number.SomeNumber -> m value + specialize :: MonadValue location value m => Number.SomeNumber -> m value specialize (Number.SomeNumber (Number.Integer i)) = integer i specialize (Number.SomeNumber (Number.Ratio r)) = rational r specialize (Number.SomeNumber (Number.Decimal d)) = float d @@ -276,7 +275,7 @@ instance (Monad m, MonadEvaluatable Precise term Value m) => MonadValue Precise where -- Explicit type signature is necessary here because we're passing all sorts of things -- to these comparison functions. - go :: (Ord a, MonadValue Precise value m) => a -> a -> m value + go :: (Ord a, MonadValue location value m) => a -> a -> m value go l r = case comparator of Concrete f -> boolean (f l r) Generalized -> integer (orderingToInt (compare l r)) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 841ad2089..830278f86 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -43,8 +43,8 @@ import qualified Language.TypeScript.Assignment as TypeScript -- Ruby evaluateRubyFile = evaluateWithPrelude rubyParser evaluateRubyFiles = evaluateFilesWithPrelude rubyParser -evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Precise Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths -evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths +evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser paths +evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser paths -- Go evaluateGoFile = evaluateFile goParser @@ -55,8 +55,8 @@ typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Typ evaluatePythonFile = evaluateWithPrelude pythonParser evaluatePythonFiles = evaluateFilesWithPrelude pythonParser typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path -tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term Value)) . evaluateModule <$> parseFile pythonParser Nothing path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term Value))) . evaluateModule <$> parseFile pythonParser Nothing path +tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path -- PHP evaluatePHPFile = evaluateFile phpParser @@ -71,14 +71,14 @@ evaluateTypeScriptFiles = evaluateFiles typescriptParser evaluateFile :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) - , MonadAddressable Precise (Evaluating Precise term Value effects) + , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) + , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term ) => Parser term -> FilePath - -> IO (Final effects Value) -evaluateFile parser path = runAnalysis @(Evaluating Precise term Value) . evaluateModule <$> parseFile parser Nothing path + -> IO (Final effects (Value Precise)) +evaluateFile parser path = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModule <$> parseFile parser Nothing path evaluateWith :: forall location value term effects . ( effects ~ Effects location term value (Evaluating location term value effects) @@ -105,14 +105,14 @@ evaluateWith prelude m = runAnalysis @(Evaluating location term value) $ do evaluateWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) - , MonadAddressable Precise (Evaluating Precise term Value effects) + , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) + , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) ) => Parser term -> FilePath - -> IO (Final effects Value) + -> IO (Final effects (Value Precise)) evaluateWithPrelude parser path = do let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) prelude <- parseFile parser Nothing preludePath @@ -124,14 +124,14 @@ evaluateWithPrelude parser path = do evaluateFiles :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) - , MonadAddressable Precise (Evaluating Precise term Value effects) + , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) + , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term ) => Parser term -> [FilePath] - -> IO (Final effects Value) -evaluateFiles parser paths = runAnalysis @(Evaluating Precise term Value) . evaluateModules <$> parseFiles parser paths + -> IO (Final effects (Value Precise)) +evaluateFiles parser paths = runAnalysis @(Evaluating Precise term (Value Precise)) . evaluateModules <$> parseFiles parser paths -- | Evaluate terms and an entry point to a value with a given prelude. evaluatesWith :: forall location value term effects @@ -155,19 +155,19 @@ evaluatesWith prelude modules m = runAnalysis @(Evaluating location term value) evaluateFilesWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ Effects Precise term Value (Evaluating Precise term Value effects) - , MonadAddressable Precise (Evaluating Precise term Value effects) + , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) + , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) ) => Parser term -> [FilePath] - -> IO (Final effects Value) + -> IO (Final effects (Value Precise)) evaluateFilesWithPrelude parser paths = do let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)) prelude <- parseFile parser Nothing preludePath entry:xs <- traverse (parseFile parser Nothing) paths - pure $ evaluatesWith @Precise @Value prelude xs entry + pure $ evaluatesWith @Precise @(Value Precise) prelude xs entry -- Read and parse a file. From 65af3ad23834f4ed1054240a15b5bb6998e59b13 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:05:18 -0400 Subject: [PATCH 33/58] Decouple Type from Monovariant. --- src/Data/Abstract/Type.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 1c4b133f4..08e7b48cd 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -5,6 +5,7 @@ import Control.Abstract.Analysis import Data.Abstract.Address import Data.Abstract.Environment as Env import Data.Align (alignWith) +import Data.Semigroup.Reducer (Reducer) import Prelude hiding (fail) import Prologue @@ -43,12 +44,20 @@ unify t1 t2 | otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2) -instance ValueRoots Monovariant Type where +instance Ord location => ValueRoots location Type where valueRoots _ = mempty -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance (Alternative m, MonadEnvironment Monovariant Type m, MonadFail m, MonadFresh m, MonadHeap Monovariant Type m) => MonadValue Monovariant Type m where +instance ( Alternative m + , MonadAddressable location m + , MonadEnvironment location Type m + , MonadFail m + , MonadFresh m + , MonadHeap location Type m + , Reducer Type (Cell location Type) + ) + => MonadValue location Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name From 1b90003f6fca38e5b4154f14766cb743b2059948 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:11:58 -0400 Subject: [PATCH 34/58] :fire: LocatedValue. --- src/Data/Abstract/Located.hs | 25 ------------------------- 1 file changed, 25 deletions(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index ff5d49b03..f5d45be44 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -1,15 +1,10 @@ {-# LANGUAGE TypeFamilies #-} module Data.Abstract.Located where -import Control.Abstract.Evaluator -import Control.Abstract.Value import Data.Abstract.Address -import Data.Bifunctor import Data.Range import Data.Record import Data.Span -import Prelude hiding (null) -import Prologue hiding (hash, null) -- TODO: Dependencies type Provenance = Record '[Range, Span] @@ -20,23 +15,3 @@ data Located location = Located { provenance :: !Provenance, location :: locatio instance Location location => Location (Located location) where type Cell (Located location) = Cell location - - -newtype LocatedValue value = LocatedValue { unLocatedValue :: value } - deriving (Eq, Ord, Show) - -instance MonadValue (Located location) value m => MonadValue (Located location) (LocatedValue value) m where - unit = LocatedValue <$> unit - null = LocatedValue <$> null - integer = fmap LocatedValue . integer - float = fmap LocatedValue . float - rational = fmap LocatedValue . rational - boolean = fmap LocatedValue . boolean - multiple = fmap LocatedValue . multiple . map unLocatedValue - string = fmap LocatedValue . string - symbol = fmap LocatedValue . symbol - array = fmap LocatedValue . array . map unLocatedValue - hash = fmap LocatedValue . hash . map (bimap unLocatedValue unLocatedValue) - ifthenelse = ifthenelse . unLocatedValue - kvPair = fmap (fmap LocatedValue) . (kvPair `on` unLocatedValue) - -- klass name vals env = LocatedValue <$> klass name (map unLocatedValue vals) (fmap unLocatedValue env) From 63a3b8d6423c7a904654d329f06bc96dddecd662 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:22:08 -0400 Subject: [PATCH 35/58] Define MonadAddressable in terms of cell dereferencing. --- src/Control/Abstract/Addressable.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index ddbf568a6..6fce359cf 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -14,7 +14,7 @@ import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. class (Monad m, Ord location) => MonadAddressable location m where - deref :: MonadHeap location value m => Address location value -> m value + derefCell :: Address location value -> Cell location value -> m value alloc :: MonadHeap location value m => Name -> m (Address location value) @@ -59,20 +59,20 @@ letrec' name body = do -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. instance MonadFail m => MonadAddressable Precise m where - deref = derefWith (maybeM uninitializedAddress . unLatest) + derefCell _ = maybeM uninitializedAddress . unLatest alloc _ = do -- Compute the next available address in the heap, then write an empty value into it. addr <- fmap (Address . Precise . heapSize) getHeap addr <$ modifyHeap (heapInit addr mempty) -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, MonadFail m) => MonadAddressable Monovariant m where - deref = derefWith (foldMapA pure) +instance (Alternative m, Monad m) => MonadAddressable Monovariant m where + derefCell _ = 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 location value m, Ord location) => (Cell location value -> m a) -> Address location value -> m a -derefWith with = maybe uninitializedAddress with <=< lookupHeap +-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized. +deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m) => Address location value -> m value +deref addr = maybe uninitializedAddress (derefCell addr) <=< lookupHeap $ addr -- | 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 From 0e0f3a9d4b1ec64a1a7f3d9c8a39c10936affe3a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:24:18 -0400 Subject: [PATCH 36/58] =?UTF-8?q?Fresh=20doesn=E2=80=99t=20refer=20to=20TN?= =?UTF-8?q?ame.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Effect/Fresh.hs | 12 +++++------- src/Data/Abstract/Type.hs | 2 ++ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Control/Effect/Fresh.hs b/src/Control/Effect/Fresh.hs index 44262e93e..8db9ef609 100644 --- a/src/Control/Effect/Fresh.hs +++ b/src/Control/Effect/Fresh.hs @@ -4,22 +4,20 @@ module Control.Effect.Fresh where import Control.Effect import Control.Monad.Effect.Internal -type TName = Int - -- | An effect offering a (resettable) sequence of always-incrementing, and therefore “fresh,” type variables. data Fresh a where -- | Request a reset of the sequence of variable names. - Reset :: TName -> Fresh () + Reset :: Int -> Fresh () -- | Request a fresh variable name. - Fresh :: Fresh TName + Fresh :: Fresh Int -- | 'Monad's offering a (resettable) sequence of guaranteed-fresh type variables. class Monad m => MonadFresh m where -- | Get a fresh variable name, guaranteed unused (since the last 'reset'). - fresh :: m TName + fresh :: m Int -- | Reset the sequence of variable names. Useful to avoid complicated alpha-equivalence comparisons when iteratively recomputing the results of an analysis til convergence. - reset :: TName -> m () + reset :: Int -> m () instance (Fresh :< fs) => MonadFresh (Eff fs) where fresh = send Fresh @@ -28,6 +26,6 @@ instance (Fresh :< fs) => MonadFresh (Eff fs) where -- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset. instance RunEffect Fresh a where - runEffect = relayState (0 :: TName) (const pure) (\ s action k -> case action of + runEffect = relayState (0 :: Int) (const pure) (\ s action k -> case action of Fresh -> k (succ s) s Reset s' -> k s' ()) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 08e7b48cd..f432e95fa 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -9,6 +9,8 @@ import Data.Semigroup.Reducer (Reducer) import Prelude hiding (fail) import Prologue +type TName = Int + -- | A datatype representing primitive types and combinations thereof. data Type = Int -- ^ Primitive int type. From fdb94b085d61ddf084e741fc2b41380805206809 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:30:23 -0400 Subject: [PATCH 37/58] MonadAddressable depends on MonadFresh instead of MonadHeap. --- src/Analysis/Abstract/Caching.hs | 3 +-- src/Analysis/Abstract/Evaluating.hs | 1 + src/Control/Abstract/Addressable.hs | 14 ++++++-------- src/Data/Abstract/Evaluatable.hs | 1 + 4 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 8699a95b3..8071b708e 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -13,8 +13,7 @@ import Prologue -- | The effects necessary for caching analyses. type CachingEffects location term value effects - = Fresh -- For 'MonadFresh'. - ': NonDet -- For 'Alternative' and 'MonadNonDet'. + = NonDet -- For 'Alternative' and 'MonadNonDet'. ': Reader (Cache location term value) -- The in-cache used as an oracle while converging on a result. ': State (Cache location term value) -- The out-cache used to record results in each iteration of convergence. ': effects diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b74407c65..4fa25457e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -35,6 +35,7 @@ type EvaluatingEffects location term value , Resumable (ValueExc location value) , Resumable (Unspecialized value) , Fail -- Failure with an error message + , Fresh -- For allocating new addresses and/or type variables. , Reader [Module term] -- The stack of currently-evaluating modules. , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules , Reader (Environment location value) -- Default environment used as a fallback in lookupEnv diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 6fce359cf..842e3185e 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -3,11 +3,11 @@ module Control.Abstract.Addressable where import Control.Abstract.Evaluator import Control.Applicative +import Control.Effect.Fresh import Control.Monad ((<=<)) import Data.Abstract.Address import Data.Abstract.Environment (insert) import Data.Abstract.FreeVariables -import Data.Abstract.Heap import Data.Semigroup.Reducer import Prelude hiding (fail) import Prologue @@ -16,12 +16,12 @@ import Prologue class (Monad m, Ord location) => MonadAddressable location m where derefCell :: Address location value -> Cell location value -> m value - alloc :: MonadHeap location value m => Name -> m (Address location value) + alloc :: MonadFresh m => Name -> m (Address location value) -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( MonadAddressable location m , MonadEnvironment location value m - , MonadHeap location value m + , MonadFresh m ) => Name -> m (Address location value) @@ -30,6 +30,7 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( MonadAddressable location m , MonadEnvironment location value m + , MonadFresh m , MonadHeap location value m , Reducer value (Cell location value) ) @@ -45,7 +46,7 @@ letrec name body = do -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. letrec' :: ( MonadAddressable location m , MonadEnvironment location value m - , MonadHeap location value m + , MonadFresh m ) => Name -> (Address location value -> m value) @@ -60,10 +61,7 @@ letrec' name body = do -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. instance MonadFail m => MonadAddressable Precise m where derefCell _ = maybeM uninitializedAddress . unLatest - alloc _ = do - -- Compute the next available address in the heap, then write an empty value into it. - addr <- fmap (Address . Precise . heapSize) getHeap - addr <$ modifyHeap (heapInit addr mempty) + alloc _ = Address . Precise <$> fresh -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. instance (Alternative m, Monad m) => MonadAddressable Monovariant m where diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4acb24065..ac2a74b02 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -35,6 +35,7 @@ type MonadEvaluatable location term value m = , FreeVariables term , MonadAddressable location m , MonadAnalysis location term value m + , MonadFresh m , MonadThrow (Unspecialized value) m , MonadThrow (ValueExc location value) m , MonadThrow (LoadError term value) m From 065b95c7aa9c5dcef00e3ef4fb127f16ba3e4279 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:33:18 -0400 Subject: [PATCH 38/58] Show uninitialized addresses. --- src/Control/Abstract/Addressable.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 842e3185e..c6b2d7e5b 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -4,7 +4,6 @@ module Control.Abstract.Addressable where import Control.Abstract.Evaluator import Control.Applicative import Control.Effect.Fresh -import Control.Monad ((<=<)) import Data.Abstract.Address import Data.Abstract.Environment (insert) import Data.Abstract.FreeVariables @@ -60,7 +59,7 @@ letrec' name body = do -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. instance MonadFail m => MonadAddressable Precise m where - derefCell _ = maybeM uninitializedAddress . unLatest + derefCell addr = maybeM (uninitializedAddress addr) . unLatest alloc _ = Address . Precise <$> fresh -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. @@ -69,9 +68,9 @@ instance (Alternative m, Monad m) => MonadAddressable Monovariant m where alloc = pure . Address . Monovariant -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized. -deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m) => Address location value -> m value -deref addr = maybe uninitializedAddress (derefCell addr) <=< lookupHeap $ addr +deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m, Show location) => Address location value -> m value +deref addr = lookupHeap addr >>= maybe (uninitializedAddress addr) (derefCell addr) -- | 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" +uninitializedAddress :: (MonadFail m, Show location) => Address location value -> m a +uninitializedAddress addr = fail $ "uninitialized address: " <> show addr From 9b9aa62d4ecb3bc5e485619abae48a642d4cf2c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:35:49 -0400 Subject: [PATCH 39/58] MonadFresh is a superclass constraint. --- src/Control/Abstract/Addressable.hs | 11 ++++------- src/Data/Abstract/Evaluatable.hs | 1 - 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index c6b2d7e5b..40e1cd74c 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -12,15 +12,14 @@ import Prelude hiding (fail) import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. -class (Monad m, Ord location) => MonadAddressable location m where +class (MonadFresh m, Ord location) => MonadAddressable location m where derefCell :: Address location value -> Cell location value -> m value - alloc :: MonadFresh m => Name -> m (Address location value) + alloc :: Name -> m (Address location value) -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( MonadAddressable location m , MonadEnvironment location value m - , MonadFresh m ) => Name -> m (Address location value) @@ -29,7 +28,6 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( MonadAddressable location m , MonadEnvironment location value m - , MonadFresh m , MonadHeap location value m , Reducer value (Cell location value) ) @@ -45,7 +43,6 @@ letrec name body = do -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. letrec' :: ( MonadAddressable location m , MonadEnvironment location value m - , MonadFresh m ) => Name -> (Address location value -> m value) @@ -58,12 +55,12 @@ 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 => MonadAddressable Precise m where +instance (MonadFail m, MonadFresh m) => MonadAddressable Precise m where derefCell addr = maybeM (uninitializedAddress addr) . unLatest alloc _ = Address . Precise <$> fresh -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, Monad m) => MonadAddressable Monovariant m where +instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where derefCell _ = foldMapA pure alloc = pure . Address . Monovariant diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index ac2a74b02..4acb24065 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -35,7 +35,6 @@ type MonadEvaluatable location term value m = , FreeVariables term , MonadAddressable location m , MonadAnalysis location term value m - , MonadFresh m , MonadThrow (Unspecialized value) m , MonadThrow (ValueExc location value) m , MonadThrow (LoadError term value) m From f4754df71722ba145e48dc7f6878e49251bd2f24 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:44:27 -0400 Subject: [PATCH 40/58] Swap the order of the Located fields. --- src/Data/Abstract/Located.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index f5d45be44..4765f3963 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -10,7 +10,7 @@ import Data.Span type Provenance = Record '[Range, Span] -data Located location = Located { provenance :: !Provenance, location :: location } +data Located location = Located { location :: location, provenance :: !Provenance } deriving (Eq, Ord, Show) instance Location location => Location (Located location) where From 1b668e0c7fd803e908582116b774c9d2b02dbe78 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:48:25 -0400 Subject: [PATCH 41/58] Define MonadAddressable in terms of an allocLoc method. --- src/Control/Abstract/Addressable.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 40e1cd74c..c191ed97c 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -15,7 +15,7 @@ import Prologue class (MonadFresh m, Ord location) => MonadAddressable location m where derefCell :: Address location value -> Cell location value -> m value - alloc :: Name -> m (Address location value) + allocLoc :: Name -> m location -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( MonadAddressable location m @@ -57,17 +57,20 @@ letrec' name body = do -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. instance (MonadFail m, MonadFresh m) => MonadAddressable Precise m where derefCell addr = maybeM (uninitializedAddress addr) . unLatest - alloc _ = Address . Precise <$> fresh + allocLoc _ = Precise <$> fresh -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where derefCell _ = foldMapA pure - alloc = pure . Address . Monovariant + allocLoc = pure . Monovariant -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized. deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m, Show location) => Address location value -> m value deref addr = lookupHeap addr >>= maybe (uninitializedAddress addr) (derefCell addr) +alloc :: MonadAddressable location m => Name -> m (Address location value) +alloc = fmap Address . allocLoc + -- | 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, Show location) => Address location value -> m a uninitializedAddress addr = fail $ "uninitialized address: " <> show addr From f04e0aee747d35860a579571dd5499ef024348a2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 22:59:50 -0400 Subject: [PATCH 42/58] Define a MonadAddressable instance for Located using a MonadProvenance interface. --- src/Data/Abstract/Located.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 4765f3963..9a0e7a039 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Data.Abstract.Located where +import Control.Abstract.Addressable import Data.Abstract.Address import Data.Range import Data.Record @@ -10,8 +11,17 @@ import Data.Span type Provenance = Record '[Range, Span] +class Monad m => MonadProvenance m where + askProvenance :: m Provenance + + data Located location = Located { location :: location, provenance :: !Provenance } deriving (Eq, Ord, Show) instance Location location => Location (Located location) where type Cell (Located location) = Cell location + +instance (MonadAddressable location m, MonadProvenance m) => MonadAddressable (Located location) m where + derefCell (Address (Located loc _)) = derefCell (Address loc) + + allocLoc name = Located <$> allocLoc name <*> askProvenance From 366120bd24aa29696cf45a55f3339ba775065bab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:08:59 -0400 Subject: [PATCH 43/58] Stub in a module for an Origin datatype. --- semantic.cabal | 1 + src/Data/Abstract/Origin.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Abstract/Origin.hs diff --git a/semantic.cabal b/semantic.cabal index a378cca01..f287d9807 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -58,6 +58,7 @@ library , Data.Abstract.Module , Data.Abstract.ModuleTable , Data.Abstract.Number + , Data.Abstract.Origin , Data.Abstract.Path , Data.Abstract.Type , Data.Abstract.Value diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs new file mode 100644 index 000000000..4262b6208 --- /dev/null +++ b/src/Data/Abstract/Origin.hs @@ -0,0 +1 @@ +module Data.Abstract.Origin where From c3845ac457ec46a39034300944f2c2dcee1c62d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:09:50 -0400 Subject: [PATCH 44/58] Origins can be unknown. --- src/Data/Abstract/Origin.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 4262b6208..c99dfd4f0 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -1 +1,3 @@ module Data.Abstract.Origin where + +data Origin = Unknown From ad85506741f5bc2975eaec261e154fd165aa2e0e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:12:09 -0400 Subject: [PATCH 45/58] Origins can be local. --- src/Data/Abstract/Origin.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index c99dfd4f0..7004ff1fe 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -1,3 +1,9 @@ module Data.Abstract.Origin where -data Origin = Unknown +import Data.Abstract.Module +import Data.Range +import Data.Span + +data Origin + = Unknown + | Local ModuleName FilePath Range Span From af4f2dd8b97373a68db424342e06a35fb4ec7a1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:13:28 -0400 Subject: [PATCH 46/58] Origin is a Semigroup. --- src/Data/Abstract/Origin.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 7004ff1fe..9966f3a44 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -3,7 +3,12 @@ module Data.Abstract.Origin where import Data.Abstract.Module import Data.Range import Data.Span +import Prologue data Origin = Unknown | Local ModuleName FilePath Range Span + +instance Semigroup Origin where + a <> Unknown = a + _ <> b = b From c2f4a9d5a515265d469e9c408dfb3e835f2e1c89 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:13:43 -0400 Subject: [PATCH 47/58] Derive Eq, Ord, & Show instances for Origin. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 9966f3a44..1ef575288 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -8,6 +8,7 @@ import Prologue data Origin = Unknown | Local ModuleName FilePath Range Span + deriving (Eq, Ord, Show) instance Semigroup Origin where a <> Unknown = a From b9740a56c2edcbe5414c46ba82a1640155083026 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:14:28 -0400 Subject: [PATCH 48/58] Origin is a Monoid. --- src/Data/Abstract/Origin.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 1ef575288..ad7d28f2d 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -13,3 +13,7 @@ data Origin instance Semigroup Origin where a <> Unknown = a _ <> b = b + +instance Monoid Origin where + mempty = Unknown + mappend = (<>) From 393636dc736550ca3ffe89bf11b5fc67500a5563 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:17:08 -0400 Subject: [PATCH 49/58] =?UTF-8?q?Local=E2=80=99s=20fields=20are=20strict.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Abstract/Origin.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index ad7d28f2d..4be7244ec 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -7,7 +7,7 @@ import Prologue data Origin = Unknown - | Local ModuleName FilePath Range Span + | Local !ModuleName !FilePath !Range !Span deriving (Eq, Ord, Show) instance Semigroup Origin where From fcaffb4fbe506f5e16213b08995a5db742feb2a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:17:57 -0400 Subject: [PATCH 50/58] Note a TODO about upstream dependencies. --- src/Data/Abstract/Origin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 4be7244ec..ea5d9db13 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -5,6 +5,7 @@ import Data.Range import Data.Span import Prologue +-- TODO: Upstream dependencies data Origin = Unknown | Local !ModuleName !FilePath !Range !Span From c8829b39f3ca55c855e85394bd39ba8676ceaa1c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:18:41 -0400 Subject: [PATCH 51/58] Located is defined in terms of Origin. --- src/Data/Abstract/Located.hs | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 9a0e7a039..6beac41f5 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -3,25 +3,19 @@ module Data.Abstract.Located where import Control.Abstract.Addressable import Data.Abstract.Address -import Data.Range -import Data.Record -import Data.Span +import Data.Abstract.Origin --- TODO: Dependencies -type Provenance = Record '[Range, Span] +class Monad m => MonadOrigin m where + askOrigin :: m Origin -class Monad m => MonadProvenance m where - askProvenance :: m Provenance - - -data Located location = Located { location :: location, provenance :: !Provenance } +data Located location = Located { location :: location, provenance :: !Origin } deriving (Eq, Ord, Show) instance Location location => Location (Located location) where type Cell (Located location) = Cell location -instance (MonadAddressable location m, MonadProvenance m) => MonadAddressable (Located location) m where +instance (MonadAddressable location m, MonadOrigin m) => MonadAddressable (Located location) m where derefCell (Address (Located loc _)) = derefCell (Address loc) - allocLoc name = Located <$> allocLoc name <*> askProvenance + allocLoc name = Located <$> allocLoc name <*> askOrigin From a0667d0414d316c695c74982afc2ce5392ec0f30 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:27:23 -0400 Subject: [PATCH 52/58] Move MonadOrigin into the Origin module. --- src/Data/Abstract/Located.hs | 4 ---- src/Data/Abstract/Origin.hs | 5 +++++ 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 6beac41f5..d2748a669 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -5,10 +5,6 @@ import Control.Abstract.Addressable import Data.Abstract.Address import Data.Abstract.Origin -class Monad m => MonadOrigin m where - askOrigin :: m Origin - - data Located location = Located { location :: location, provenance :: !Origin } deriving (Eq, Ord, Show) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index ea5d9db13..7d63bb721 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -11,6 +11,11 @@ data Origin | Local !ModuleName !FilePath !Range !Span deriving (Eq, Ord, Show) + +class Monad m => MonadOrigin m where + askOrigin :: m Origin + + instance Semigroup Origin where a <> Unknown = a _ <> b = b From 424cac7ab250f0c521a358150ba6c00f55ddb283 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:28:32 -0400 Subject: [PATCH 53/58] Define a MonadOrigin instance for Evaluating. --- src/Analysis/Abstract/Evaluating.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 4fa25457e..a6f78c25e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -14,6 +14,7 @@ import Data.Abstract.Exports import Data.Abstract.Heap import Data.Abstract.Module import Data.Abstract.ModuleTable +import Data.Abstract.Origin import qualified Data.IntMap as IntMap import Lens.Micro import Prelude hiding (fail) @@ -37,6 +38,7 @@ type EvaluatingEffects location term value , Fail -- Failure with an error message , Fresh -- For allocating new addresses and/or type variables. , Reader [Module term] -- The stack of currently-evaluating modules. + , Reader Origin -- The current term’s origin. , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules , Reader (Environment location value) -- Default environment used as a fallback in lookupEnv , State (EvaluatingState location term value) -- Environment, heap, modules, exports, and jumps. @@ -139,6 +141,10 @@ instance Members (EvaluatingEffects location term value) effects askModuleStack = raise ask +instance Member (Reader Origin) effects + => MonadOrigin (Evaluating location term value effects) where + askOrigin = raise ask + instance ( Members (EvaluatingEffects location term value) effects , MonadValue location value (Evaluating location term value effects) ) From 2d22d9aa39a8d050f0eaf6be40f6d7ce3b2f62d0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:57:34 -0400 Subject: [PATCH 54/58] Define a HasOrigin typeclass which constructs an Origin from a term. --- src/Data/Abstract/Origin.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 7d63bb721..8f50fd2b0 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -2,7 +2,9 @@ module Data.Abstract.Origin where import Data.Abstract.Module import Data.Range +import Data.Record import Data.Span +import Data.Term import Prologue -- TODO: Upstream dependencies @@ -12,6 +14,14 @@ data Origin deriving (Eq, Ord, Show) +class HasOrigin f where + originFor :: [Module a] -> f b -> Origin + +instance (HasField fields Range, HasField fields Span) => HasOrigin (TermF syntax (Record fields)) where + originFor [] _ = Unknown + originFor (m:_) (In ann _) = Local (moduleName m) (modulePath m) (getField ann) (getField ann) + + class Monad m => MonadOrigin m where askOrigin :: m Origin From 2ff1507410e8cd52f99e2e912c97cdd2f7ee6311 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 29 Mar 2018 23:58:10 -0400 Subject: [PATCH 55/58] Push the origin for the current term in analyzeTerm. --- src/Analysis/Abstract/Evaluating.hs | 8 +++++++- src/Semantic/Util.hs | 7 +++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index a6f78c25e..69148e5a9 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -147,13 +147,19 @@ instance Member (Reader Origin) effects instance ( Members (EvaluatingEffects location term value) effects , MonadValue location value (Evaluating location term value effects) + , HasOrigin (Base term) ) => MonadAnalysis location term value (Evaluating location term value effects) where type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value - analyzeTerm = id + analyzeTerm eval term = do + ms <- askModuleStack + pushOrigin (originFor ms (term)) (eval term) analyzeModule eval m = pushModule (subterm <$> m) (eval m) pushModule :: Member (Reader [Module term]) effects => Module term -> Evaluating location term value effects a -> Evaluating location term value effects a pushModule m = raise . local (m :) . lower + +pushOrigin :: Member (Reader Origin) effects => Origin -> Evaluating location term value effects a -> Evaluating location term value effects a +pushOrigin o = raise . local (const o) . lower diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 830278f86..f520a6353 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -15,6 +15,7 @@ import Control.Monad.IO.Class import Data.Abstract.Evaluatable hiding (head) import Data.Abstract.Address import Data.Abstract.Module +import Data.Abstract.Origin import Data.Abstract.Type import Data.Abstract.Value import Data.Blob @@ -72,6 +73,7 @@ evaluateFile :: forall term effects . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) + , HasOrigin (Base term) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term ) @@ -84,6 +86,7 @@ evaluateWith :: forall location value term effects . ( effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term + , HasOrigin (Base term) , MonadAddressable location (Evaluating location term value effects) , MonadValue location value (Evaluating location term value effects) , Recursive term @@ -106,6 +109,7 @@ evaluateWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) + , HasOrigin (Base term) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) @@ -125,6 +129,7 @@ evaluateFiles :: forall term effects . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) + , HasOrigin (Base term) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term ) @@ -138,6 +143,7 @@ evaluatesWith :: forall location value term effects . ( effects ~ Effects location term value (Evaluating location term value effects) , Evaluatable (Base term) , FreeVariables term + , HasOrigin (Base term) , MonadAddressable location (Evaluating location term value effects) , MonadValue location value (Evaluating location term value effects) , Recursive term @@ -156,6 +162,7 @@ evaluateFilesWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term , effects ~ Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) + , HasOrigin (Base term) , MonadAddressable Precise (Evaluating Precise term (Value Precise) effects) , Recursive term , TypeLevel.KnownSymbol (PreludePath term) From d3b2baa1b2aaa71df04db8fd09360e2f53f4bc84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 00:03:23 -0400 Subject: [PATCH 56/58] Define a single, universal instance of MonadOrigin. --- src/Analysis/Abstract/Evaluating.hs | 4 ---- src/Data/Abstract/Origin.hs | 10 ++++++++++ 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 69148e5a9..aed4fd2a5 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -141,10 +141,6 @@ instance Members (EvaluatingEffects location term value) effects askModuleStack = raise ask -instance Member (Reader Origin) effects - => MonadOrigin (Evaluating location term value effects) where - askOrigin = raise ask - instance ( Members (EvaluatingEffects location term value) effects , MonadValue location value (Evaluating location term value effects) , HasOrigin (Base term) diff --git a/src/Data/Abstract/Origin.hs b/src/Data/Abstract/Origin.hs index 8f50fd2b0..0ec5ac806 100644 --- a/src/Data/Abstract/Origin.hs +++ b/src/Data/Abstract/Origin.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE UndecidableInstances #-} module Data.Abstract.Origin where +import Control.Effect +import Control.Monad.Effect.Reader import Data.Abstract.Module import Data.Range import Data.Record @@ -25,6 +28,13 @@ instance (HasField fields Range, HasField fields Span) => HasOrigin (TermF synta class Monad m => MonadOrigin m where askOrigin :: m Origin +instance ( Effectful m + , Member (Reader Origin) effects + , Monad (m effects) + ) + => MonadOrigin (m effects) where + askOrigin = raise ask + instance Semigroup Origin where a <> Unknown = a From 743eaf0297fa27cf7d7a46f0916e843a63efc1ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 00:03:52 -0400 Subject: [PATCH 57/58] Rename the origin field. --- src/Data/Abstract/Located.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index d2748a669..7309bae55 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -5,7 +5,7 @@ import Control.Abstract.Addressable import Data.Abstract.Address import Data.Abstract.Origin -data Located location = Located { location :: location, provenance :: !Origin } +data Located location = Located { location :: location, origin :: !Origin } deriving (Eq, Ord, Show) instance Location location => Location (Located location) where From ee145328a6e8be863be40c9a159c0e498eb41a98 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 30 Mar 2018 11:00:14 -0400 Subject: [PATCH 58/58] :fire: redundant parens. --- src/Analysis/Abstract/Evaluating.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index aed4fd2a5..98cbeb88c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -150,7 +150,7 @@ instance ( Members (EvaluatingEffects location term value) effects analyzeTerm eval term = do ms <- askModuleStack - pushOrigin (originFor ms (term)) (eval term) + pushOrigin (originFor ms term) (eval term) analyzeModule eval m = pushModule (subterm <$> m) (eval m)