1
1
mirror of https://github.com/github/semantic.git synced 2024-12-20 05:11:44 +03:00

Merge pull request #1572 from github/jump-around,-jump-around

Goto
This commit is contained in:
Rob Rix 2018-03-15 16:23:11 -04:00 committed by GitHub
commit 2cae3739dc
23 changed files with 247 additions and 212 deletions

View File

@ -47,10 +47,10 @@ library
, Data.Abstract.Environment , Data.Abstract.Environment
, Data.Abstract.Evaluatable , Data.Abstract.Evaluatable
, Data.Abstract.FreeVariables , Data.Abstract.FreeVariables
, Data.Abstract.Heap
, Data.Abstract.Live , Data.Abstract.Live
, Data.Abstract.ModuleTable , Data.Abstract.ModuleTable
, Data.Abstract.Number , Data.Abstract.Number
, Data.Abstract.Store
, Data.Abstract.Type , Data.Abstract.Type
, Data.Abstract.Value , Data.Abstract.Value
-- General datatype definitions & generic algorithms -- General datatype definitions & generic algorithms

View File

@ -6,9 +6,8 @@ module Analysis.Abstract.Caching
import Control.Abstract.Analysis import Control.Abstract.Analysis
import Data.Abstract.Cache import Data.Abstract.Cache
import Data.Abstract.Configuration import Data.Abstract.Configuration
import Data.Abstract.Store import Data.Abstract.Heap
import Data.Abstract.Value import Data.Abstract.Value
import Data.Monoid (Alt (..))
import Prologue import Prologue
-- | The effects necessary for caching analyses. -- | The effects necessary for caching analyses.
@ -26,22 +25,23 @@ type CacheFor term value = Cache (LocationFor value) term value
newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a) newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
deriving instance MonadControl term (m term value effects) => MonadControl term (Caching m term value effects)
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects)
deriving instance MonadStore value (m term value effects) => MonadStore value (Caching m term value effects) deriving instance MonadHeap value (m term value effects) => MonadHeap value (Caching m term value effects)
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects)
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects)
-- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons. -- | 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 term value m => MonadCaching term value m where
-- | Look up the set of values for a given configuration in the in-cache. -- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: ConfigurationFor term value -> m (Set (value, StoreFor value)) consultOracle :: ConfigurationFor term value -> m (Set (value, HeapFor value))
-- | Run an action with the given in-cache. -- | Run an action with the given in-cache.
withOracle :: CacheFor term value -> m a -> m a withOracle :: CacheFor term value -> m a -> m a
-- | Look up the set of values for a given configuration in the out-cache. -- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, StoreFor value))) lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, HeapFor value)))
-- | Run an action, caching its result and 'Store' under the given configuration. -- | Run an action, caching its result and 'Heap' under the given configuration.
caching :: ConfigurationFor term value -> Set (value, StoreFor value) -> m value -> m value caching :: ConfigurationFor term value -> Set (value, HeapFor value) -> m value -> m value
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards. -- | 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 (CacheFor term value)
@ -61,7 +61,7 @@ instance ( Effectful (m term value)
lookupCache configuration = raise (cacheLookup configuration <$> get) lookupCache configuration = raise (cacheLookup configuration <$> get)
caching configuration values action = do caching configuration values action = do
raise (modify (cacheSet configuration values)) raise (modify (cacheSet configuration values))
result <- (,) <$> action <*> getStore result <- (,) <$> action <*> getHeap
raise (modify (cacheInsert configuration result)) raise (modify (cacheInsert configuration result))
pure (fst result) pure (fst result)
@ -97,7 +97,7 @@ instance ( Corecursive term
c <- getConfiguration e c <- getConfiguration e
-- Convergence here is predicated upon an Eq instance, not α-equivalence -- Convergence here is predicated upon an Eq instance, not α-equivalence
cache <- converge (\ prevCache -> isolateCache $ do cache <- converge (\ prevCache -> isolateCache $ do
putStore (configurationStore c) putHeap (configurationHeap c)
-- We need to reset fresh generation so that this invocation converges. -- We need to reset fresh generation so that this invocation converges.
reset 0 reset 0
-- This is subtle: though the calling context supports nondeterminism, we want -- This is subtle: though the calling context supports nondeterminism, we want
@ -124,5 +124,5 @@ converge f = loop
loop x' loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results. -- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Store (LocationFor value) value) -> m a scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Heap (LocationFor value) value) -> m a
scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) scatter = foldMapA (\ (value, heap') -> putHeap heap' *> pure value)

View File

@ -6,16 +6,17 @@ module Analysis.Abstract.Collecting
import Control.Abstract.Analysis import Control.Abstract.Analysis
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Configuration import Data.Abstract.Configuration
import Data.Abstract.Heap
import Data.Abstract.Live import Data.Abstract.Live
import Data.Abstract.Store
import Data.Abstract.Value import Data.Abstract.Value
import Prologue import Prologue
newtype Collecting m term value (effects :: [* -> *]) a = Collecting (m term value effects a) newtype Collecting m term value (effects :: [* -> *]) a = Collecting (m term value effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
deriving instance MonadControl term (m term value effects) => MonadControl term (Collecting m term value effects)
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Collecting m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Collecting m term value effects)
deriving instance MonadStore value (m term value effects) => MonadStore value (Collecting m term value effects) deriving instance MonadHeap value (m term value effects) => MonadHeap value (Collecting m term value effects)
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Collecting m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Collecting m term value effects)
instance ( Effectful (m term value) instance ( Effectful (m term value)
@ -23,7 +24,7 @@ instance ( Effectful (m term value)
, MonadEvaluator term value (m term value effects) , MonadEvaluator term value (m term value effects)
) )
=> MonadEvaluator term value (Collecting m term value effects) where => MonadEvaluator term value (Collecting m term value effects) where
getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getHeap
instance ( Effectful (m term value) instance ( Effectful (m term value)
@ -42,7 +43,7 @@ instance ( Effectful (m term value)
analyzeTerm term = do analyzeTerm term = do
roots <- askRoots roots <- askRoots
v <- liftAnalyze analyzeTerm term v <- liftAnalyze analyzeTerm term
modifyStore (gc (roots <> valueRoots v)) modifyHeap (gc (roots <> valueRoots v))
pure v pure v
@ -55,27 +56,27 @@ askRoots = raise ask
-- extraRoots roots = raise . local (<> roots) . lower -- extraRoots roots = raise . local (<> roots) . lower
-- | Collect any addresses in the store not rooted in or reachable from the given 'Live' set. -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
gc :: ( Ord (LocationFor value) gc :: ( Ord (LocationFor value)
, Foldable (Cell (LocationFor value)) , Foldable (Cell (LocationFor value))
, ValueRoots value , ValueRoots value
) )
=> LiveFor value -- ^ The set of addresses to consider rooted. => LiveFor value -- ^ The set of addresses to consider rooted.
-> StoreFor value -- ^ A store to collect unreachable addresses within. -> HeapFor value -- ^ A heap to collect unreachable addresses within.
-> StoreFor value -- ^ A garbage-collected store. -> HeapFor value -- ^ A garbage-collected heap.
gc roots store = storeRestrict store (reachable roots store) gc roots heap = heapRestrict heap (reachable roots heap)
-- | Compute the set of addresses reachable from a given root set in a given store. -- | Compute the set of addresses reachable from a given root set in a given heap.
reachable :: ( Ord (LocationFor value) reachable :: ( Ord (LocationFor value)
, Foldable (Cell (LocationFor value)) , Foldable (Cell (LocationFor value))
, ValueRoots value , ValueRoots value
) )
=> LiveFor value -- ^ The set of root addresses. => LiveFor value -- ^ The set of root addresses.
-> StoreFor value -- ^ The store to trace addresses through. -> HeapFor value -- ^ The heap to trace addresses through.
-> LiveFor value -- ^ The set of addresses reachable from the root set. -> LiveFor value -- ^ The set of addresses reachable from the root set.
reachable roots store = go mempty roots reachable roots heap = go mempty roots
where go seen set = case liveSplit set of where go seen set = case liveSplit set of
Nothing -> seen Nothing -> seen
Just (a, as) -> go (liveInsert a seen) (case storeLookupAll a store of Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of
Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen
_ -> seen) _ -> seen)

View File

@ -12,8 +12,9 @@ import Prologue
newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a) newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
deriving instance MonadControl term (m term value effects) => MonadControl term (DeadCode m term value effects)
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects)
deriving instance MonadStore value (m term value effects) => MonadStore value (DeadCode m term value effects) deriving instance MonadHeap value (m term value effects) => MonadHeap value (DeadCode m term value effects)
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects)
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects)

View File

@ -18,6 +18,7 @@ import Data.Abstract.Address
import Data.Abstract.ModuleTable import Data.Abstract.ModuleTable
import Data.Abstract.Value import Data.Abstract.Value
import Data.Blob import Data.Blob
import qualified Data.IntMap as IntMap
import Data.Language import Data.Language
import Data.List.Split (splitWhen) import Data.List.Split (splitWhen)
import Prelude hiding (fail) import Prelude hiding (fail)
@ -32,7 +33,7 @@ evaluate :: forall value term effects
, Evaluatable (Base term) , Evaluatable (Base term)
, FreeVariables term , FreeVariables term
, MonadAddressable (LocationFor value) value (Evaluating term value effects) , MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue term value (Evaluating term value effects) , MonadValue value (Evaluating term value effects)
, Recursive term , Recursive term
) )
=> term => term
@ -45,7 +46,7 @@ evaluates :: forall value term effects
, Evaluatable (Base term) , Evaluatable (Base term)
, FreeVariables term , FreeVariables term
, MonadAddressable (LocationFor value) value (Evaluating term value effects) , MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue term value (Evaluating term value effects) , MonadValue value (Evaluating term value effects)
, Recursive term , Recursive term
) )
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
@ -70,7 +71,6 @@ withModules Blob{..} pairs = localModuleTable (const moduleTable)
newtype Evaluating term value effects a = Evaluating (Eff effects a) newtype Evaluating term value effects a = Evaluating (Eff effects a)
deriving (Applicative, Functor, Effectful, Monad) deriving (Applicative, Functor, Effectful, Monad)
deriving instance Member Fail effects => MonadFail (Evaluating term value effects) deriving instance Member Fail effects => MonadFail (Evaluating term value effects)
deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects) deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects)
deriving instance Member NonDetEff effects => Alternative (Evaluating term value effects) deriving instance Member NonDetEff effects => Alternative (Evaluating term value effects)
@ -81,13 +81,23 @@ type EvaluatingEffects term value
= '[ Fail -- Failure with an error message = '[ Fail -- Failure with an error message
, Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure)
, State (EnvironmentFor value) -- Global (imperative) environment , State (EnvironmentFor value) -- Global (imperative) environment
, State (StoreFor value) -- The heap , State (HeapFor value) -- The heap
, Reader (ModuleTable [term]) -- Cache of unevaluated modules , Reader (ModuleTable [term]) -- Cache of unevaluated modules
, State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules , State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules
, State (Map Name (Name, Maybe (Address (LocationFor value) value))) -- Set of exports , State (Map Name (Name, Maybe (Address (LocationFor value) value))) -- Set of exports
, State (IntMap.IntMap term) -- For jumps
] ]
instance Members '[Fail, State (IntMap.IntMap term)] effects => MonadControl term (Evaluating term value effects) where
label term = do
m <- raise get
let i = IntMap.size m
raise (put (IntMap.insert i term m))
pure i
goto label = IntMap.lookup label <$> raise get >>= maybe (fail ("unknown label: " <> show label)) pure
instance Members '[State (Map Name (Name, Maybe (Address (LocationFor value) value))), Reader (EnvironmentFor value), State (EnvironmentFor value)] effects => MonadEnvironment value (Evaluating term value effects) where instance Members '[State (Map Name (Name, Maybe (Address (LocationFor value) value))), Reader (EnvironmentFor value), State (EnvironmentFor value)] effects => MonadEnvironment value (Evaluating term value effects) where
getGlobalEnv = raise get getGlobalEnv = raise get
putGlobalEnv = raise . put putGlobalEnv = raise . put
@ -100,9 +110,9 @@ instance Members '[State (Map Name (Name, Maybe (Address (LocationFor value) val
askLocalEnv = raise ask askLocalEnv = raise ask
localEnv f a = raise (local f (lower a)) localEnv f a = raise (local f (lower a))
instance Member (State (StoreFor value)) effects => MonadStore value (Evaluating term value effects) where instance Member (State (HeapFor value)) effects => MonadHeap value (Evaluating term value effects) where
getStore = raise get getHeap = raise get
putStore = raise . put putHeap = raise . put
instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentFor value))] effects => MonadModuleTable term value (Evaluating term value effects) where instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentFor value))] effects => MonadModuleTable term value (Evaluating term value effects) where
getModuleTable = raise get getModuleTable = raise get
@ -112,13 +122,13 @@ instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentF
localModuleTable f a = raise (local f (lower a)) localModuleTable f a = raise (local f (lower a))
instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where
getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getHeap
instance ( Evaluatable (Base term) instance ( Evaluatable (Base term)
, FreeVariables term , FreeVariables term
, Members (EvaluatingEffects term value) effects , Members (EvaluatingEffects term value) effects
, MonadAddressable (LocationFor value) value (Evaluating term value effects) , MonadAddressable (LocationFor value) value (Evaluating term value effects)
, MonadValue term value (Evaluating term value effects) , MonadValue value (Evaluating term value effects)
, Recursive term , Recursive term
) )
=> MonadAnalysis term value (Evaluating term value effects) where => MonadAnalysis term value (Evaluating term value effects) where

View File

@ -17,8 +17,9 @@ import Prologue hiding (trace)
newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a) newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
deriving instance MonadControl term (m term value effects) => MonadControl term (Tracing trace m term value effects)
deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects) deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects)
deriving instance MonadStore value (m term value effects) => MonadStore value (Tracing trace m term value effects) deriving instance MonadHeap value (m term value effects) => MonadHeap value (Tracing trace m term value effects)
deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects) deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects)
deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects)

View File

@ -7,13 +7,13 @@ import Control.Monad ((<=<))
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Store import Data.Abstract.Heap
import Data.Abstract.Value import Data.Abstract.Value
import Data.Foldable (asum, toList)
import Data.Semigroup.Reducer import Data.Semigroup.Reducer
import Prelude hiding (fail) import Prelude hiding (fail)
import Prologue
-- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap.
class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where
deref :: Address l value -> m value deref :: Address l value -> m value
@ -30,7 +30,7 @@ lookupOrAlloc name = lookupLocalEnv name >>= maybe (alloc name) pure
letrec :: ( MonadAddressable (LocationFor value) value m letrec :: ( MonadAddressable (LocationFor value) value m
, MonadEnvironment value m , MonadEnvironment value m
, MonadStore value m , MonadHeap value m
) )
=> Name => Name
-> m value -> m value
@ -45,18 +45,20 @@ letrec name body = do
-- Instances -- Instances
-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
instance (MonadFail m, LocationFor value ~ Precise, MonadStore value m) => MonadAddressable Precise value m where instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadAddressable Precise value m where
deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup deref = derefWith (pure . unLatest)
where alloc _ = fmap (Address . Precise . heapSize) getHeap
-- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
uninitializedAddress :: MonadFail m => m a
uninitializedAddress = fail "uninitialized address"
alloc _ = fmap (Address . Precise . storeSize) getStore
-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
instance (Alternative m, LocationFor value ~ Monovariant, MonadStore value m, Ord value) => MonadAddressable Monovariant value m where instance (Alternative m, LocationFor value ~ Monovariant, MonadFail m, MonadHeap value m, Ord value) => MonadAddressable Monovariant value m where
deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup deref = derefWith (foldMapA pure)
alloc = pure . Address . Monovariant alloc = pure . Address . Monovariant
-- | Dereference the given 'Address' in the heap, using the supplied function to act on the cell, or failing if the address is uninitialized.
derefWith :: (MonadFail m, MonadHeap value m, Ord (LocationFor value)) => (CellFor value -> m a) -> Address (LocationFor value) value -> m a
derefWith with = maybe uninitializedAddress with <=< lookupHeap
-- | 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"

View File

@ -3,19 +3,21 @@ module Control.Abstract.Evaluator
( MonadEvaluator(..) ( MonadEvaluator(..)
, MonadEnvironment(..) , MonadEnvironment(..)
, modifyGlobalEnv , modifyGlobalEnv
, MonadStore(..) , MonadHeap(..)
, modifyStore , modifyHeap
, lookupHeap
, assign , assign
, MonadModuleTable(..) , MonadModuleTable(..)
, modifyModuleTable , modifyModuleTable
, MonadControl(..)
) where ) where
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Configuration import Data.Abstract.Configuration
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Heap
import Data.Abstract.ModuleTable import Data.Abstract.ModuleTable
import Data.Abstract.Store
import Data.Abstract.Value import Data.Abstract.Value
import Data.Semigroup.Reducer import Data.Semigroup.Reducer
import Prelude hiding (fail) import Prelude hiding (fail)
@ -27,10 +29,11 @@ import Prologue
-- - environments binding names to addresses -- - environments binding names to addresses
-- - a heap mapping addresses to (possibly sets of) values -- - a heap mapping addresses to (possibly sets of) values
-- - tables of modules available for import -- - tables of modules available for import
class ( MonadEnvironment value m class ( MonadControl term m
, MonadEnvironment value m
, MonadFail m , MonadFail m
, MonadModuleTable term value m , MonadModuleTable term value m
, MonadStore value m , MonadHeap value m
) )
=> MonadEvaluator term value m | m -> term, m -> value where => MonadEvaluator term value m | m -> term, m -> value where
-- | Get the current 'Configuration' with a passed-in term. -- | Get the current 'Configuration' with a passed-in term.
@ -74,27 +77,31 @@ modifyGlobalEnv f = do
-- | A 'Monad' abstracting a heap of values. -- | A 'Monad' abstracting a heap of values.
class Monad m => MonadStore value m | m -> value where class Monad m => MonadHeap value m | m -> value where
-- | Retrieve the heap. -- | Retrieve the heap.
getStore :: m (StoreFor value) getHeap :: m (HeapFor value)
-- | Set the heap. -- | Set the heap.
putStore :: StoreFor value -> m () putHeap :: HeapFor value -> m ()
-- | Update the heap. -- | Update the heap.
modifyStore :: MonadStore value m => (StoreFor value -> StoreFor value) -> m () modifyHeap :: MonadHeap value m => (HeapFor value -> HeapFor value) -> m ()
modifyStore f = do modifyHeap f = do
s <- getStore s <- getHeap
putStore $! f s putHeap $! f s
-- | Look up the cell for the given 'Address' in the 'Heap'.
lookupHeap :: (MonadHeap value m, Ord (LocationFor value)) => Address (LocationFor value) value -> m (Maybe (CellFor value))
lookupHeap = flip fmap getHeap . heapLookup
-- | Write a value to the given 'Address' in the 'Store'. -- | Write a value to the given 'Address' in the 'Store'.
assign :: ( Ord (LocationFor value) assign :: ( Ord (LocationFor value)
, MonadStore value m , MonadHeap value m
, Reducer value (CellFor value) , Reducer value (CellFor value)
) )
=> Address (LocationFor value) value => Address (LocationFor value) value
-> value -> value
-> m () -> m ()
assign address = modifyStore . storeInsert address assign address = modifyHeap . heapInsert address
-- | A 'Monad' abstracting tables of modules available for import. -- | A 'Monad' abstracting tables of modules available for import.
@ -114,3 +121,13 @@ modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentF
modifyModuleTable f = do modifyModuleTable f = do
table <- getModuleTable table <- getModuleTable
putModuleTable $! f table putModuleTable $! f table
-- | A 'Monad' abstracting jumps in imperative control.
class Monad m => MonadControl term m where
-- | Allocate a 'Label' for the given @term@.
--
-- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms.
label :: term -> m Label
-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance).
goto :: Label -> m term

View File

@ -26,7 +26,7 @@ data Comparator
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- | 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. -- This allows us to abstract the choice of whether to evaluate under binders for different value types.
class (MonadAnalysis term value m, Show value) => MonadValue term value m where class (Monad m, Show value) => MonadValue value m where
-- | Construct an abstract unit value. -- | Construct an abstract unit value.
-- TODO: This might be the same as the empty tuple for some value types -- TODO: This might be the same as the empty tuple for some value types
unit :: m value unit :: m value
@ -74,7 +74,7 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
ifthenelse :: value -> m a -> m a -> m a ifthenelse :: value -> m a -> m a -> m a
-- | Evaluate an abstraction (a binder like a lambda or method definition). -- | Evaluate an abstraction (a binder like a lambda or method definition).
abstract :: [Name] -> Subterm term (m value) -> m value abstract :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value
-- | Evaluate an application (like a function call). -- | Evaluate an application (like a function call).
apply :: value -> [m value] -> m value apply :: value -> [m value] -> m value
@ -84,10 +84,10 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
loop :: (m value -> m value) -> m value loop :: (m value -> m value) -> m value
-- | Attempt to extract a 'Prelude.Bool' from a given value. -- | Attempt to extract a 'Prelude.Bool' from a given value.
toBool :: MonadValue term value m => value -> m Bool toBool :: MonadValue value m => value -> m Bool
toBool v = ifthenelse v (pure True) (pure False) toBool v = ifthenelse v (pure True) (pure False)
forLoop :: MonadValue term value m forLoop :: (MonadEnvironment value m, MonadValue value m)
=> m value -- | Initial statement => m value -- | Initial statement
-> m value -- | Condition -> m value -- | Condition
-> m value -- | Increment/stepper -> m value -- | Increment/stepper
@ -99,7 +99,7 @@ forLoop initial cond step body = do
localEnv (mappend env) (while cond (body *> step)) localEnv (mappend env) (while cond (body *> step))
-- | The fundamental looping primitive, built on top of ifthenelse. -- | The fundamental looping primitive, built on top of ifthenelse.
while :: MonadValue term value m while :: MonadValue value m
=> m value => m value
-> m value -> m value
-> m value -> m value
@ -108,7 +108,7 @@ while cond body = loop $ \ continue -> do
ifthenelse this (body *> continue) unit ifthenelse this (body *> continue) unit
-- | Do-while loop, built on top of while. -- | Do-while loop, built on top of while.
doWhile :: MonadValue term value m doWhile :: MonadValue value m
=> m value => m value
-> m value -> m value
-> m value -> m value
@ -117,13 +117,12 @@ doWhile body cond = loop $ \ continue -> body *> do
ifthenelse this continue unit ifthenelse this continue unit
-- | Construct a 'Value' wrapping the value arguments (if any). -- | Construct a 'Value' wrapping the value arguments (if any).
instance ( FreeVariables term instance ( Monad m
, MonadAddressable location (Value location term) m , MonadAddressable location Value m
, MonadAnalysis term (Value location term) m , MonadAnalysis term Value m
, Show location , Show location
, Show term
) )
=> MonadValue term (Value location term) m where => MonadValue Value m where
unit = pure . injValue $ Value.Unit unit = pure . injValue $ Value.Unit
integer = pure . injValue . Value.Integer . Number.Integer integer = pure . injValue . Value.Integer . Number.Integer
@ -160,7 +159,7 @@ instance ( FreeVariables term
| otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair)
where where
-- Dispatch whatever's contained inside a 'SomeNumber' to its appropriate 'MonadValue' ctor -- Dispatch whatever's contained inside a 'SomeNumber' to its appropriate 'MonadValue' ctor
specialize :: MonadValue term value m => SomeNumber -> m value specialize :: MonadValue value m => SomeNumber -> m value
specialize (SomeNumber (Number.Integer i)) = integer i specialize (SomeNumber (Number.Integer i)) = integer i
specialize (SomeNumber (Ratio r)) = rational r specialize (SomeNumber (Ratio r)) = rational r
specialize (SomeNumber (Decimal d)) = float d specialize (SomeNumber (Decimal d)) = float d
@ -178,7 +177,7 @@ instance ( FreeVariables term
where where
-- Explicit type signature is necessary here because we're passing all sorts of things -- Explicit type signature is necessary here because we're passing all sorts of things
-- to these comparison functions. -- to these comparison functions.
go :: (Ord a, MonadValue term value m) => a -> a -> m value go :: (Ord a, MonadValue value m) => a -> a -> m value
go l r = case comparator of go l r = case comparator of
Concrete f -> boolean (f l r) Concrete f -> boolean (f l r)
Generalized -> integer (orderingToInt (compare l r)) Generalized -> integer (orderingToInt (compare l r))
@ -189,21 +188,23 @@ instance ( FreeVariables term
pair = (left, right) pair = (left, right)
abstract names (Subterm body _) = injValue . Closure names body . bindEnv (foldr Set.delete (freeVariables body) names) <$> askLocalEnv abstract names (Subterm body _) = do
l <- label body
injValue . Closure names l . bindEnv (foldr Set.delete (freeVariables body) names) <$> askLocalEnv
apply op params = do apply op params = do
Closure names body env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op)
bindings <- foldr (\ (name, param) rest -> do bindings <- foldr (\ (name, param) rest -> do
v <- param v <- param
a <- alloc name a <- alloc name
assign a v assign a v
envInsert name a <$> rest) (pure env) (zip names params) envInsert name a <$> rest) (pure env) (zip names params)
localEnv (mappend bindings) (evaluateTerm body) localEnv (mappend bindings) (goto label >>= evaluateTerm)
loop = fix loop = fix
-- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -- | Discard the value arguments (if any), constructing a 'Type' instead.
instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue term Type m where instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, MonadHeap Type m) => MonadValue Type m where
abstract names (Subterm _ body) = do abstract names (Subterm _ body) = do
(env, tvars) <- foldr (\ name rest -> do (env, tvars) <- foldr (\ name rest -> do
a <- alloc name a <- alloc name

View File

@ -3,30 +3,30 @@ module Data.Abstract.Cache where
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Configuration import Data.Abstract.Configuration
import Data.Abstract.Store import Data.Abstract.Heap
import Data.Map.Monoidal as Monoidal import Data.Map.Monoidal as Monoidal
import Prologue import Prologue
-- | A map of 'Configuration's to 'Set's of resulting values & 'Store's. -- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
newtype Cache l t v = Cache { unCache :: Monoidal.Map (Configuration l t v) (Set (v, Store l v)) } newtype Cache l t v = Cache { unCache :: Monoidal.Map (Configuration l t v) (Set (v, Heap l v)) }
deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Cache l t v) deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Cache l t v)
deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v)
deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Cache l t v) deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Cache l t v)
deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Semigroup (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Semigroup (Cache l t v)
deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Monoid (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Monoid (Cache l t v)
deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Reducer (Configuration l t v, (v, Store l v)) (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Reducer (Configuration l t v, (v, Heap l v)) (Cache l t v)
-- | Look up the resulting value & 'Store' for a given 'Configuration'. -- | Look up the resulting value & 'Heap' for a given 'Configuration'.
cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Store l v)) cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Heap l v))
cacheLookup key = Monoidal.lookup key . unCache cacheLookup key = Monoidal.lookup key . unCache
-- | Set the resulting value & 'Store' for a given 'Configuration', overwriting any previous entry. -- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set (v, Store l v) -> Cache l t v -> Cache l t v cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set (v, Heap l v) -> Cache l t v -> Cache l t v
cacheSet key value = Cache . Monoidal.insert key value . unCache cacheSet key value = Cache . Monoidal.insert key value . unCache
-- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry. -- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Heap l v) -> Cache l t v -> Cache l t v
cacheInsert = curry cons cacheInsert = curry cons
@ -40,7 +40,7 @@ instance (Show l, Show t, Show1 (Cell l)) => Show1 (Cache l t) where
liftShowsPrec spV slV d = showsUnaryWith (liftShowsPrec2 spKey slKey (liftShowsPrec spPair slPair) (liftShowList spPair slPair)) "Cache" d . unCache liftShowsPrec spV slV d = showsUnaryWith (liftShowsPrec2 spKey slKey (liftShowsPrec spPair slPair) (liftShowList spPair slPair)) "Cache" d . unCache
where spKey = liftShowsPrec spV slV where spKey = liftShowsPrec spV slV
slKey = liftShowList spV slV slKey = liftShowList spV slV
spPair = liftShowsPrec2 spV slV spStore slStore spPair = liftShowsPrec2 spV slV spHeap slHeap
slPair = liftShowList2 spV slV spStore slStore slPair = liftShowList2 spV slV spHeap slHeap
spStore = liftShowsPrec spV slV spHeap = liftShowsPrec spV slV
slStore = liftShowList spV slV slHeap = liftShowList spV slV

View File

@ -3,8 +3,8 @@ module Data.Abstract.Configuration where
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.Heap
import Data.Abstract.Live import Data.Abstract.Live
import Data.Abstract.Store
import Data.Abstract.Value import Data.Abstract.Value
import Prologue import Prologue
@ -17,7 +17,7 @@ data Configuration l t v
{ configurationTerm :: t -- ^ The “instruction,” i.e. the current term to evaluate. { configurationTerm :: t -- ^ The “instruction,” i.e. the current term to evaluate.
, configurationRoots :: Live l v -- ^ The set of rooted addresses. , configurationRoots :: Live l v -- ^ The set of rooted addresses.
, configurationEnvironment :: Environment l v -- ^ The environment binding any free variables in 'configurationTerm'. , configurationEnvironment :: Environment l v -- ^ The environment binding any free variables in 'configurationTerm'.
, configurationStore :: Store l v -- ^ The store of values. , configurationHeap :: Heap l v -- ^ The heap of values.
} }
deriving (Generic1) deriving (Generic1)

View File

@ -26,7 +26,7 @@ class Evaluatable constr where
eval :: ( FreeVariables term eval :: ( FreeVariables term
, MonadAddressable (LocationFor value) value m , MonadAddressable (LocationFor value) value m
, MonadAnalysis term value m , MonadAnalysis term value m
, MonadValue term value m , MonadValue value m
) )
=> SubtermAlgebra constr term (m value) => SubtermAlgebra constr term (m value)
default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value)
@ -60,6 +60,6 @@ instance MonadEnvironment value m => Semigroup (Imperative m a) where
env <- getGlobalEnv env <- getGlobalEnv
localEnv (<> env) b localEnv (<> env) b
instance MonadValue term value m => Monoid (Imperative m value) where instance (MonadEnvironment value m, MonadValue value m) => Monoid (Imperative m value) where
mempty = Imperative unit mempty = Imperative unit
mappend = (<>) mappend = (<>)

View File

@ -19,6 +19,11 @@ friendlyName :: Name -> ByteString
friendlyName xs = intercalate "." (NonEmpty.toList xs) friendlyName xs = intercalate "." (NonEmpty.toList xs)
-- | The type of labels.
-- TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels.
type Label = Int
-- | Types which can contain unbound variables. -- | Types which can contain unbound variables.
class FreeVariables term where class FreeVariables term where
-- | The set of free variables in the given value. -- | The set of free variables in the given value.

45
src/Data/Abstract/Heap.hs Normal file
View File

@ -0,0 +1,45 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-}
module Data.Abstract.Heap where
import Data.Abstract.Address
import Data.Abstract.Live
import qualified Data.Map.Monoidal as Monoidal
import Data.Semigroup.Reducer
import Prologue
-- | A map of addresses onto cells holding their values.
newtype Heap l a = Heap { unStore :: Monoidal.Map l (Cell l a) }
deriving (Generic1)
deriving instance (Eq l, Eq (Cell l a)) => Eq (Heap l a)
deriving instance (Ord l, Ord (Cell l a)) => Ord (Heap l a)
deriving instance (Show l, Show (Cell l a)) => Show (Heap l a)
instance (Eq l, Eq1 (Cell l)) => Eq1 (Heap l) where liftEq = genericLiftEq
instance (Ord l, Ord1 (Cell l)) => Ord1 (Heap l) where liftCompare = genericLiftCompare
instance (Show l, Show1 (Cell l)) => Show1 (Heap l) where liftShowsPrec = genericLiftShowsPrec
deriving instance Foldable (Cell l) => Foldable (Heap l)
deriving instance Functor (Cell l) => Functor (Heap l)
deriving instance Traversable (Cell l) => Traversable (Heap l)
deriving instance (Ord l, Semigroup (Cell l a)) => Semigroup (Heap l a)
deriving instance (Ord l, Semigroup (Cell l a)) => Monoid (Heap l a)
deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Heap l a)
-- | Look up the cell of values for an 'Address' in a 'Heap', if any.
heapLookup :: Ord l => Address l a -> Heap l a -> Maybe (Cell l a)
heapLookup (Address address) = Monoidal.lookup address . unStore
-- | Look up the list of values stored for a given address, if any.
heapLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Heap l a -> Maybe [a]
heapLookupAll address = fmap toList . heapLookup address
-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
heapInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Heap l a -> Heap l a
heapInsert (Address address) value = flip snoc (address, value)
-- | The number of addresses extant in a 'Heap'.
heapSize :: Heap l a -> Int
heapSize = Monoidal.size . unStore
-- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest).
heapRestrict :: Ord l => Heap l a -> Live l a -> Heap l a
heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m)

View File

@ -1,45 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-}
module Data.Abstract.Store where
import Data.Abstract.Address
import Data.Abstract.Live
import qualified Data.Map.Monoidal as Monoidal
import Data.Semigroup.Reducer
import Prologue
-- | A map of addresses onto cells holding their values.
newtype Store l a = Store { unStore :: Monoidal.Map l (Cell l a) }
deriving (Generic1)
deriving instance (Eq l, Eq (Cell l a)) => Eq (Store l a)
deriving instance (Ord l, Ord (Cell l a)) => Ord (Store l a)
deriving instance (Show l, Show (Cell l a)) => Show (Store l a)
instance (Eq l, Eq1 (Cell l)) => Eq1 (Store l) where liftEq = genericLiftEq
instance (Ord l, Ord1 (Cell l)) => Ord1 (Store l) where liftCompare = genericLiftCompare
instance (Show l, Show1 (Cell l)) => Show1 (Store l) where liftShowsPrec = genericLiftShowsPrec
deriving instance Foldable (Cell l) => Foldable (Store l)
deriving instance Functor (Cell l) => Functor (Store l)
deriving instance Traversable (Cell l) => Traversable (Store l)
deriving instance (Ord l, Semigroup (Cell l a)) => Semigroup (Store l a)
deriving instance (Ord l, Semigroup (Cell l a)) => Monoid (Store l a)
deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Store l a)
-- | Look up the cell of values for an 'Address' in a 'Store', if any.
storeLookup :: Ord l => Address l a -> Store l a -> Maybe (Cell l a)
storeLookup (Address address) = Monoidal.lookup address . unStore
-- | Look up the list of values stored for a given address, if any.
storeLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Store l a -> Maybe [a]
storeLookupAll address = fmap toList . storeLookup address
-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
storeInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Store l a -> Store l a
storeInsert (Address address) value = flip snoc (address, value)
-- | The number of addresses extant in a 'Store'.
storeSize :: Store l a -> Int
storeSize = Monoidal.size . unStore
-- | Restrict a 'Store' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest).
storeRestrict :: Ord l => Store l a -> Live l a -> Store l a
storeRestrict (Store m) roots = Store (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m)

View File

@ -1,10 +1,10 @@
{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-} {-# LANGUAGE DataKinds, TypeFamilies, TypeOperators #-}
module Data.Abstract.Value where module Data.Abstract.Value where
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.Store
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Heap
import Data.Abstract.Live import Data.Abstract.Live
import Data.Abstract.Number import Data.Abstract.Number
import qualified Data.Abstract.Type as Type import qualified Data.Abstract.Type as Type
@ -13,10 +13,10 @@ import Prologue
import Prelude hiding (Float, Integer, String, Rational, fail) import Prelude hiding (Float, Integer, String, Rational, fail)
import qualified Prelude import qualified Prelude
type ValueConstructors location term type ValueConstructors
= '[Array = '[Array
, Boolean , Boolean
, Closure location term , Closure
, Float , Float
, Integer , Integer
, String , String
@ -28,32 +28,32 @@ type ValueConstructors location term
-- | Open union of primitive values that terms can be evaluated to. -- | Open union of primitive values that terms can be evaluated to.
-- Fix by another name. -- Fix by another name.
newtype Value location term = Value { deValue :: Union (ValueConstructors location term) (Value location term) } newtype Value = Value { deValue :: Union ValueConstructors Value }
deriving (Eq, Show, Ord) deriving (Eq, Show, Ord)
-- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'. -- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'.
injValue :: (f :< ValueConstructors location term) => f (Value location term) -> Value location term injValue :: (f :< ValueConstructors) => f Value -> Value
injValue = Value . inj injValue = Value . inj
-- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper. -- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper.
prjValue :: (f :< ValueConstructors location term) => Value location term -> Maybe (f (Value location term)) prjValue :: (f :< ValueConstructors) => Value -> Maybe (f Value)
prjValue = prj . deValue prjValue = prj . deValue
-- | Convenience function for projecting two values. -- | Convenience function for projecting two values.
prjPair :: ( f :< ValueConstructors loc term1 , g :< ValueConstructors loc term2) prjPair :: (f :< ValueConstructors , g :< ValueConstructors)
=> (Value loc term1, Value loc term2) => (Value, Value)
-> Maybe (f (Value loc term1), g (Value loc term2)) -> Maybe (f Value, g Value)
prjPair = bitraverse prjValue prjValue prjPair = bitraverse prjValue prjValue
-- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
-- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body. -- | A function value consisting of a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body.
data Closure location term value = Closure [Name] term (Environment location value) data Closure value = Closure [Name] Label (Environment Precise value)
deriving (Eq, Generic1, Ord, Show) deriving (Eq, Generic1, Ord, Show)
instance (Eq location, Eq term) => Eq1 (Closure location term) where liftEq = genericLiftEq instance Eq1 Closure where liftEq = genericLiftEq
instance (Ord location, Ord term) => Ord1 (Closure location term) where liftCompare = genericLiftCompare instance Ord1 Closure where liftCompare = genericLiftCompare
instance (Show location, Show term) => Show1 (Closure location term) where liftShowsPrec = genericLiftShowsPrec instance Show1 Closure where liftShowsPrec = genericLiftShowsPrec
-- | The unit value. Typically used to represent the result of imperative statements. -- | The unit value. Typically used to represent the result of imperative statements.
data Unit value = Unit data Unit value = Unit
@ -134,8 +134,8 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
-- | The environment for an abstract value type. -- | The environment for an abstract value type.
type EnvironmentFor v = Environment (LocationFor v) v type EnvironmentFor v = Environment (LocationFor v) v
-- | The store for an abstract value type. -- | The 'Heap' for an abstract value type.
type StoreFor v = Store (LocationFor v) v type HeapFor value = Heap (LocationFor value) value
-- | The cell for an abstract value type. -- | The cell for an abstract value type.
type CellFor value = Cell (LocationFor value) value type CellFor value = Cell (LocationFor value) value
@ -145,7 +145,7 @@ type LiveFor value = Live (LocationFor value) value
-- | The location type (the body of 'Address'es) which should be used for an abstract value type. -- | The location type (the body of 'Address'es) which should be used for an abstract value type.
type family LocationFor value :: * type family LocationFor value :: *
type instance LocationFor (Value location term) = location type instance LocationFor Value = Precise
type instance LocationFor Type.Type = Monovariant type instance LocationFor Type.Type = Monovariant
-- | Value types, e.g. closures, which can root a set of addresses. -- | Value types, e.g. closures, which can root a set of addresses.
@ -153,10 +153,10 @@ class ValueRoots value where
-- | Compute the set of addresses rooted by a given value. -- | Compute the set of addresses rooted by a given value.
valueRoots :: value -> LiveFor value valueRoots :: value -> LiveFor value
instance Ord location => ValueRoots (Value location term) where instance ValueRoots Value where
valueRoots v valueRoots v
| Just (Closure _ body env) <- prjValue v = envAll env `const` (body :: term) | Just (Closure _ _ env) <- prjValue v = envAll env
| otherwise = mempty | otherwise = mempty
instance ValueRoots Type.Type where instance ValueRoots Type.Type where
valueRoots _ = mempty valueRoots _ = mempty

View File

@ -1,9 +1,9 @@
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
module Language.Go.Syntax where module Language.Go.Syntax where
import Prologue import Data.Abstract.Evaluatable hiding (Label)
import Data.Abstract.Evaluatable
import Diffing.Algorithm import Diffing.Algorithm
import Prologue
-- A composite literal in Go -- A composite literal in Go
data Composite a = Composite { compositeType :: !a, compositeElement :: !a } data Composite a = Composite { compositeType :: !a, compositeElement :: !a }

View File

@ -1,7 +1,8 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Prologue ( module Prologue
module X ( module X
, ) where , foldMapA
) where
import Data.Bifunctor.Join as X import Data.Bifunctor.Join as X
@ -11,6 +12,7 @@ import Data.IntMap as X (IntMap)
import Data.IntSet as X (IntSet) import Data.IntSet as X (IntSet)
import Data.Ix as X (Ix(..)) import Data.Ix as X (Ix(..))
import Data.Map as X (Map) import Data.Map as X (Map)
import Data.Monoid (Alt(..))
import Data.Maybe as X import Data.Maybe as X
import Data.Sequence as X (Seq) import Data.Sequence as X (Seq)
import Data.Set as X (Set) import Data.Set as X (Set)
@ -67,3 +69,7 @@ import Data.Hashable as X (
-- Generics -- Generics
import GHC.Generics as X hiding (moduleName) import GHC.Generics as X hiding (moduleName)
import GHC.Stack as X import GHC.Stack as X
-- | Fold a collection by mapping each element onto an 'Alternative' action.
foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a
foldMapA f = getAlt . foldMap (Alt . f)

View File

@ -14,7 +14,6 @@ import Data.Abstract.Evaluatable
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Type import Data.Abstract.Type
import Data.Abstract.Value import Data.Abstract.Value
import Data.AST
import Data.Blob import Data.Blob
import Data.Diff import Data.Diff
import Data.Range import Data.Range
@ -31,66 +30,58 @@ import Semantic.Task
import qualified Language.Go.Assignment as Go import qualified Language.Go.Assignment as Go
import qualified Language.Python.Assignment as Python import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby
import qualified Language.TypeScript.Assignment as TypeScript import qualified Language.TypeScript.Assignment as TypeScript
type PreciseValue a = Value Precise (Term (Union a) (Record Location))
type GoValue = PreciseValue Go.Syntax
type RubyValue = PreciseValue Ruby.Syntax
type PythonValue = PreciseValue Python.Syntax
type TypeScriptValue = PreciseValue TypeScript.Syntax
-- Ruby -- Ruby
evaluateRubyFile = evaluateFile @RubyValue rubyParser evaluateRubyFile = evaluateFile rubyParser
evaluateRubyFiles = evaluateFiles @RubyValue rubyParser evaluateRubyFiles = evaluateFiles rubyParser
-- Go -- Go
evaluateGoFile = evaluateFile @GoValue goParser evaluateGoFile = evaluateFile goParser
evaluateGoFiles = evaluateFiles @GoValue goParser evaluateGoFiles = evaluateFiles goParser
typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . snd <$> parseFile goParser path typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . snd <$> parseFile goParser path
-- Python -- Python
evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate . snd <$> parseFile pythonParser path
evaluatePythonFiles = evaluateFiles @PythonValue pythonParser evaluatePythonFiles = evaluateFiles pythonParser
typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path
tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path
evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path
-- TypeScript -- TypeScript
typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . snd <$> parseFile typescriptParser path typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . snd <$> parseFile typescriptParser path
evaluateTypeScriptFile = evaluateFile @TypeScriptValue typescriptParser evaluateTypeScriptFile = evaluateFile typescriptParser
evaluateTypeScriptFiles = evaluateFiles @TypeScriptValue typescriptParser evaluateTypeScriptFiles = evaluateFiles typescriptParser
-- Evalute a single file. -- Evalute a single file.
evaluateFile :: forall value term effects evaluateFile :: forall term effects
. ( Evaluatable (Base term) . ( Evaluatable (Base term)
, FreeVariables term , FreeVariables term
, effects ~ RequiredEffects term value (Evaluating term value effects) , effects ~ RequiredEffects term Value (Evaluating term Value effects)
, MonadAddressable (LocationFor value) value (Evaluating term value effects) , MonadAddressable Precise Value (Evaluating term Value effects)
, MonadValue term value (Evaluating term value effects) , MonadValue Value (Evaluating term Value effects)
, Recursive term , Recursive term
) )
=> Parser term => Parser term
-> FilePath -> FilePath
-> IO (Final effects value) -> IO (Final effects Value)
evaluateFile parser path = runAnalysis @(Evaluating term value) . evaluateModule . snd <$> parseFile parser path evaluateFile parser path = evaluate . snd <$> parseFile parser path
-- Evaluate a list of files (head of file list is considered the entry point). -- Evaluate a list of files (head of file list is considered the entry point).
evaluateFiles :: forall value term effects evaluateFiles :: forall term effects
. ( Evaluatable (Base term) . ( Evaluatable (Base term)
, FreeVariables term , FreeVariables term
, effects ~ RequiredEffects term value (Evaluating term value effects) , effects ~ RequiredEffects term Value (Evaluating term Value effects)
, MonadAddressable (LocationFor value) value (Evaluating term value effects) , MonadAddressable Precise Value (Evaluating term Value effects)
, MonadValue term value (Evaluating term value effects) , MonadValue Value (Evaluating term Value effects)
, Recursive term , Recursive term
) )
=> Parser term => Parser term
-> [FilePath] -> [FilePath]
-> IO (Final effects value) -> IO (Final effects Value)
evaluateFiles parser paths = do evaluateFiles parser paths = do
entry:xs <- traverse (parseFile parser) paths entry:xs <- traverse (parseFile parser) paths
pure $ evaluates @value xs entry pure $ evaluates @Value xs entry
-- Read and parse a file. -- Read and parse a file.
parseFile :: Parser term -> FilePath -> IO (Blob, term) parseFile :: Parser term -> FilePath -> IO (Blob, term)

View File

@ -33,8 +33,8 @@ spec = parallel $ do
where where
addr = Address . Precise addr = Address . Precise
fixtures = "test/fixtures/go/analysis/" fixtures = "test/fixtures/go/analysis/"
evaluate entry = snd . fst . fst . fst <$> evaluate entry = snd . fst . fst . fst . fst <$>
evaluateFiles @GoValue goParser evaluateFiles goParser
[ fixtures <> entry [ fixtures <> entry
, fixtures <> "foo/foo.go" , fixtures <> "foo/foo.go"
, fixtures <> "bar/bar.go" , fixtures <> "bar/bar.go"

View File

@ -37,8 +37,8 @@ spec = parallel $ do
where where
addr = Address . Precise addr = Address . Precise
fixtures = "test/fixtures/python/analysis/" fixtures = "test/fixtures/python/analysis/"
evaluate entry = snd . fst . fst . fst <$> evaluate entry = snd . fst . fst . fst . fst <$>
evaluateFiles @PythonValue pythonParser evaluateFiles pythonParser
[ fixtures <> entry [ fixtures <> entry
, fixtures <> "a.py" , fixtures <> "a.py"
, fixtures <> "b/c.py" , fixtures <> "b/c.py"

View File

@ -34,8 +34,8 @@ spec = parallel $ do
where where
addr = Address . Precise addr = Address . Precise
fixtures = "test/fixtures/typescript/analysis/" fixtures = "test/fixtures/typescript/analysis/"
evaluate entry = snd . fst . fst . fst <$> evaluate entry = snd . fst . fst . fst . fst <$>
evaluateFiles @TypeScriptValue typescriptParser evaluateFiles typescriptParser
[ fixtures <> entry [ fixtures <> entry
, fixtures <> "a.ts" , fixtures <> "a.ts"
, fixtures <> "foo.ts" , fixtures <> "foo.ts"

View File

@ -12,8 +12,8 @@ module SpecHelpers (
import Data.Abstract.Address as X import Data.Abstract.Address as X
import Data.Abstract.Environment as X import Data.Abstract.Environment as X
import Data.Abstract.FreeVariables as X import Data.Abstract.FreeVariables as X
import Data.Abstract.Heap as X
import Data.Abstract.ModuleTable as X import Data.Abstract.ModuleTable as X
import Data.Abstract.Store as X
import Data.Blob as X import Data.Blob as X
import Data.Functor.Listable as X import Data.Functor.Listable as X
import Data.Language as X import Data.Language as X