From 0def4afbab99728be2c8e283f77d9343a4d4e1f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 9 Aug 2018 15:40:42 -0400 Subject: [PATCH] Specialize Heap to Set. --- src/Analysis/Abstract/Caching.hs | 8 ++++---- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Heap.hs | 18 +++++++++--------- src/Data/Abstract/Cache.hs | 2 +- src/Data/Abstract/Configuration.hs | 9 ++++----- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Heap.hs | 20 ++++++++++---------- src/Semantic/Graph.hs | 4 ++-- src/Semantic/Util.hs | 4 ++-- test/SpecHelpers.hs | 6 +++--- 10 files changed, 37 insertions(+), 38 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 0032428b1..77a714e2c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -33,7 +33,7 @@ lookupCache :: (Cacheable term address value, Member (State (Cache term address lookupCache configuration = cacheLookup configuration <$> get -- | Run an action, caching its result and 'Heap' under the given configuration. -cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address Set value)) effects) +cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address value)) effects) => Configuration term address value -> Set (Cached address value) -> TermEvaluator term address value effects (ValueRef address) @@ -63,7 +63,7 @@ cachingTerms :: ( Cacheable term address value , Member (Reader (Live address)) effects , Member (State (Cache term address value)) effects , Member (Env address) effects - , Member (State (Heap address Set value)) effects + , Member (State (Heap address value)) effects ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) @@ -87,7 +87,7 @@ convergingModules :: ( AbstractValue address value effects , Member (Resumable (BaseError (EnvironmentError address))) effects , Member (State (Cache term address value)) effects , Member (Env address) effects - , Member (State (Heap address Set value)) effects + , Member (State (Heap address value)) effects , Effects effects ) => SubtermAlgebra Module term (TermEvaluator term address value effects address) @@ -124,7 +124,7 @@ converge seed f = loop seed loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address Set value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address) +scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address) scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 70c92817f..bbf54c7ed 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -15,7 +15,7 @@ import Prologue tracingTerms :: ( Corecursive term , Member (Reader (Live address)) effects , Member (Env address) effects - , Member (State (Heap address Set value)) effects + , Member (State (Heap address value)) effects , Member (Writer (trace (Configuration term address value))) effects , Reducer (Configuration term address value) (trace (Configuration term address value)) ) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index c5fdfdc53..550ed27ad 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -40,20 +40,20 @@ import Data.Span (Span) import Prologue -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address Set value)) effects) => term -> TermEvaluator term address value effects (Configuration term address value) +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) => term -> TermEvaluator term address value effects (Configuration term address value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap -- | Retrieve the heap. -getHeap :: Member (State (Heap address Set value)) effects => Evaluator address value effects (Heap address Set value) +getHeap :: Member (State (Heap address value)) effects => Evaluator address value effects (Heap address value) getHeap = get -- | Set the heap. -putHeap :: Member (State (Heap address Set value)) effects => Heap address Set value -> Evaluator address value effects () +putHeap :: Member (State (Heap address value)) effects => Heap address value -> Evaluator address value effects () putHeap = put -- | Update the heap. -modifyHeap :: Member (State (Heap address Set value)) effects => (Heap address Set value -> Heap address Set value) -> Evaluator address value effects () +modifyHeap :: Member (State (Heap address value)) effects => (Heap address value -> Heap address value) -> Evaluator address value effects () modifyHeap = modify' box :: ( Member (Allocator address value) effects @@ -140,9 +140,9 @@ gc roots = sendAllocator (GC roots) reachable :: ( Ord address , ValueRoots address value ) - => Live address -- ^ The set of root addresses. - -> Heap address Set value -- ^ The heap to trace addresses through. - -> Live address -- ^ The set of addresses reachable from the root set. + => Live address -- ^ The set of root addresses. + -> Heap address value -- ^ The heap to trace addresses through. + -> Live address -- ^ 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 @@ -165,7 +165,7 @@ data Deref address value (m :: * -> *) return where Deref :: address -> Deref address value m value runAllocator :: ( Allocatable address effects - , Member (State (Heap address Set value)) effects + , Member (State (Heap address value)) effects , Ord value , PureEffects effects , ValueRoots address value @@ -185,7 +185,7 @@ runDeref :: ( Derefable address effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects , Member (Resumable (BaseError (AddressError address value))) effects - , Member (State (Heap address Set value)) effects + , Member (State (Heap address value)) effects ) => Evaluator address value (Deref address value ': effects) a -> Evaluator address value effects a diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 33d42d51b..1db43d5a6 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -21,7 +21,7 @@ newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuratio data Cached address value = Cached { cachedValue :: ValueRef address - , cachedHeap :: Heap address Set value + , cachedHeap :: Heap address value } deriving (Eq, Ord, Show) diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index baec5e392..6f6a23e48 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -3,13 +3,12 @@ module Data.Abstract.Configuration ( Configuration (..) ) where import Data.Abstract.Environment import Data.Abstract.Heap import Data.Abstract.Live -import Prologue -- | A single point in a program’s execution. data Configuration term address value = Configuration - { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live address -- ^ The set of rooted addresses. - , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. - , configurationHeap :: Heap address Set value -- ^ The heap of values. + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live address -- ^ The set of rooted addresses. + , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. + , configurationHeap :: Heap address value -- ^ The heap of values. } deriving (Eq, Ord, Show) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 8c5865349..a255758f7 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -91,7 +91,7 @@ evaluate :: ( AbstractValue address value valueEffects , Member (Resumable (BaseError EvalError)) effects , Member (Resumable (BaseError ResolutionError)) effects , Member (Resumable (BaseError (UnspecializedError value))) effects - , Member (State (Heap address Set value)) effects + , Member (State (Heap address value)) effects , Member Trace effects , Ord value , Recursive term diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 956be461f..c4a77cf94 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -15,38 +15,38 @@ import Data.Semigroup.Reducer import Prologue -- | A map of addresses onto cells holding their values. -newtype Heap address cell value = Heap { unHeap :: Monoidal.Map address (cell value) } - deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable) +newtype Heap address value = Heap { unHeap :: Monoidal.Map address (Set value) } + deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup) -- | Look up the cell of values for an 'Address' in a 'Heap', if any. -heapLookup :: Ord address => address -> Heap address cell value -> Maybe (cell value) +heapLookup :: Ord address => address -> Heap address value -> Maybe (Set value) heapLookup address = Monoidal.lookup address . unHeap -- | Look up the list of values stored for a given address, if any. -heapLookupAll :: (Ord address, Foldable cell) => address -> Heap address cell value -> Maybe [value] +heapLookupAll :: Ord address => address -> Heap address value -> Maybe [value] heapLookupAll address = fmap toList . heapLookup address -- | Append a value onto the cell for a given address, inserting a new cell if none existed. -heapInsert :: (Ord address, Reducer value (cell value)) => address -> value -> Heap address cell value -> Heap address cell value +heapInsert :: (Ord address, Ord value) => address -> value -> Heap address value -> Heap address value heapInsert address value = flip snoc (address, value) -- | Manually insert a cell into the heap at a given address. -heapInit :: Ord address => address -> cell value -> Heap address cell value -> Heap address cell value +heapInit :: Ord address => address -> Set value -> Heap address value -> Heap address value heapInit address cell (Heap h) = Heap (Monoidal.insert address cell h) -- | The number of addresses extant in a 'Heap'. -heapSize :: Heap address cell value -> Int +heapSize :: Heap address value -> Int heapSize = Monoidal.size . unHeap -- | Restrict a 'Heap' to only those addresses in the given 'Live' set (in essence garbage collecting the rest). -heapRestrict :: Ord address => Heap address cell value -> Live address -> Heap address cell value +heapRestrict :: Ord address => Heap address value -> Live address -> Heap address value heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) -instance (Ord address, Reducer value (cell value)) => Reducer (address, value) (Heap address cell value) where +instance (Ord address, Ord value) => Reducer (address, value) (Heap address value) where unit = Heap . unit cons (addr, a) (Heap heap) = Heap (cons (addr, a) heap) snoc (Heap heap) (addr, a) = Heap (snoc heap (addr, a)) -instance (Show address, Show (cell value)) => Show (Heap address cell value) where +instance (Show address, Show value) => Show (Heap address value) where showsPrec d = showsUnaryWith showsPrec "Heap" d . Monoidal.pairs . unHeap diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 9aa9dc715..4cbb05a2e 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -100,7 +100,7 @@ runCallGraph lang includePackages modules package = do = runTermEvaluator @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract . graphing @_ @_ @(Maybe Name) @Monovariant . caching - . runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) Set Abstract)) + . runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) Abstract)) . runFresh 0 . resumingLoadError . resumingUnspecialized @@ -204,7 +204,7 @@ newtype ImportGraphEff address outerEffects a = ImportGraphEff ': Resumable (BaseError (UnspecializedError (Value address (ImportGraphEff address outerEffects)))) ': Resumable (BaseError (LoadError address)) ': Fresh - ': State (Heap address Set (Value address (ImportGraphEff address outerEffects))) + ': State (Heap address (Value address (ImportGraphEff address outerEffects))) ': outerEffects ) a } diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index f6f4ff208..92df73fad 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -73,14 +73,14 @@ newtype UtilEff a = UtilEff , Resumable (BaseError (LoadError Precise)) , Trace , Fresh - , State (Heap Precise Set (Value Precise UtilEff)) + , State (Heap Precise (Value Precise UtilEff)) , Lift IO ] a } checking = runM @_ @IO - . runState (lowerBound @(Heap Monovariant Set Type)) + . runState (lowerBound @(Heap Monovariant Type)) . runFresh 0 . runPrintingTrace . runTermEvaluator @_ @Monovariant @Type diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 681521f82..434999d10 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -105,7 +105,7 @@ type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise UtilEff , Resumable (BaseError (LoadError Precise)) , Trace , Fresh - , State (Heap Precise Set Val) + , State (Heap Precise Val) , Lift IO ] type TestEvaluatingErrors = '[ BaseError (ValueError Precise UtilEff) @@ -119,7 +119,7 @@ type TestEvaluatingErrors = '[ BaseError (ValueError Precise UtilEff) testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (ModuleResult Precise)))) -> IO ( [String] - , ( Heap Precise Set Val + , ( Heap Precise Val , Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors)) (ModuleTable (NonEmpty (Module (ModuleResult Precise)))) ) @@ -164,7 +164,7 @@ namespaceScope heap ns@(Namespace _ _ _) namespaceScope _ _ = Nothing -derefQName :: Heap Precise Set (Value Precise term) -> NonEmpty Name -> Bindings Precise -> Maybe (Value Precise term) +derefQName :: Heap Precise (Value Precise term) -> NonEmpty Name -> Bindings Precise -> Maybe (Value Precise term) derefQName heap names binds = go names (Env.newEnv binds) where go (n1 :| ns) env = Env.lookupEnv' n1 env >>= flip heapLookup heap >>= fmap fst . Set.minView >>= case ns of [] -> Just