github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00
Code Issues Projects Releases Wiki Activity

Specialize Heap to Set.

Browse Source
This commit is contained in:
Rob Rix 2018-08-09 15:40:42 -04:00
parent c6bd54769a
commit 0def4afbab
10 changed files with 37 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Analysis/Abstract/Caching.hs
View File

@ -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)

2
src/Analysis/Abstract/Tracing.hs
View File

@ -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))
)

18
src/Control/Abstract/Heap.hs
View File

@ -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

2
src/Data/Abstract/Cache.hs
View File

@ -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)

9
src/Data/Abstract/Configuration.hs
View File

@ -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)

2
src/Data/Abstract/Evaluatable.hs
View File

@ -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

20
src/Data/Abstract/Heap.hs
View File

@ -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

4
src/Semantic/Graph.hs
View File

@ -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
}

4
src/Semantic/Util.hs
View File

@ -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

6
test/SpecHelpers.hs
View File

@ -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