github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-27 00:44:57 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #2130 from github/parameterize-evaluate-with-deref-and-allocator-handlers

Browse Source 
Specialize Allocator/Deref handlers for the address types
This commit is contained in:
Rob Rix 2018-08-13 15:16:55 -04:00 committed by GitHub
commit e0c100f8e9
28 changed files with 386 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
semantic.cabal
View File

@ -35,7 +35,6 @@ library
, Assigning.Assignment.Table
-- Control structures & interfaces for abstract interpretation
, Control.Abstract
, Control.Abstract.Addressable
, Control.Abstract.Context
, Control.Abstract.Environment
, Control.Abstract.Evaluator
@ -48,7 +47,10 @@ library
, Control.Abstract.TermEvaluator
, Control.Abstract.Value
-- Datatypes for abstract interpretation
, Data.Abstract.Address
, Data.Abstract.Address.Hole
, Data.Abstract.Address.Located
, Data.Abstract.Address.Monovariant
, Data.Abstract.Address.Precise
, Data.Abstract.BaseError
, Data.Abstract.Cache
, Data.Abstract.Configuration

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

@ -9,7 +9,7 @@ import Prologue
-- | An analysis performing GC after every instruction.
collectingTerms :: ( Member (Reader (Live address)) effects
, Member (Allocator address value) effects
, Member (State (Heap address value)) effects
, Ord address
, ValueRoots address value
)

3
src/Analysis/Abstract/Graph.hs
View File

@ -18,7 +18,8 @@ module Analysis.Abstract.Graph
import Algebra.Graph.Export.Dot hiding (vertexName)
import Control.Abstract hiding (Function(..))
import Data.Abstract.Address
import Data.Abstract.Address.Hole
import Data.Abstract.Address.Located
import Data.Abstract.BaseError
import Data.Abstract.Ref
import Data.Abstract.Declarations

1
src/Control/Abstract.hs
View File

@ -2,7 +2,6 @@ module Control.Abstract
( module X
) where
import Control.Abstract.Addressable as X
import Control.Abstract.Context as X
import Control.Abstract.Environment as X hiding (Lookup)
import Control.Abstract.Evaluator as X

62
src/Control/Abstract/Addressable.hs
View File

@ -1,62 +0,0 @@
{-# LANGUAGE UndecidableInstances #-}
module Control.Abstract.Addressable
( Allocatable(..)
, Derefable(..)
) where
import Control.Abstract.Context
import Control.Abstract.Evaluator
import Control.Abstract.Hole
import Data.Abstract.Address
import Data.Abstract.Name
import qualified Data.Set as Set
import Prologue
class (Ord address, Show address) => Allocatable address effects where
allocCell :: Name -> Evaluator address value effects address
assignCell :: Ord value => address -> value -> Set value -> Evaluator address value effects (Set value)
class (Ord address, Show address) => Derefable address effects where
derefCell :: address -> Set value -> Evaluator address value effects (Maybe value)
instance Member Fresh effects => Allocatable Precise effects where
allocCell _ = Precise <$> fresh
assignCell _ value _ = pure (Set.singleton value)
instance Derefable Precise effects where
derefCell _ = pure . fmap fst . Set.minView
instance Allocatable Monovariant effects where
allocCell = pure . Monovariant
assignCell _ value values = pure (Set.insert value values)
instance Member NonDet effects => Derefable Monovariant effects where
derefCell _ = traverse (foldMapA pure) . nonEmpty . toList
instance (Allocatable address effects, Member (Reader ModuleInfo) effects, Member (Reader PackageInfo) effects, Member (Reader Span) effects) => Allocatable (Located address) effects where
allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule <*> pure name <*> ask)
assignCell (Located loc _ _ _ _) value = relocate . assignCell loc value
instance Derefable address effects => Derefable (Located address) effects where
derefCell (Located loc _ _ _ _) = relocate . derefCell loc
instance (Allocatable address effects, Ord context, Show context) => Allocatable (Hole context address) effects where
allocCell name = relocate (Total <$> allocCell name)
assignCell (Total loc) value = relocate . assignCell loc value
assignCell (Partial _) _ = pure
instance (Derefable address effects, Ord context, Show context) => Derefable (Hole context address) effects where
derefCell (Total loc) = relocate . derefCell loc
derefCell (Partial _) = const (pure Nothing)
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
relocate = raiseEff . lowerEff

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

@ -17,16 +17,13 @@ module Control.Abstract.Heap
-- * Garbage collection
, gc
-- * Effects
, Allocator
, runAllocator
, Allocator(..)
, Deref(..)
, runDeref
, AddressError(..)
, runAddressError
, runAddressErrorWith
) where
import Control.Abstract.Addressable
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Roots
@ -57,8 +54,11 @@ putHeap = put
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
box :: ( Member (Allocator address) effects
, Member (Deref value) effects
, Member Fresh effects
, Member (State (Heap address value)) effects
, Ord address
)
=> value
-> Evaluator address value effects address
@ -68,27 +68,41 @@ box val = do
assign addr val
pure addr
alloc :: Member (Allocator address value) effects => Name -> Evaluator address value effects address
alloc = sendAllocator . Alloc
alloc :: Member (Allocator address) effects => Name -> Evaluator address value effects address
alloc = send . Alloc
dealloc :: Member (Allocator address value) effects => address -> Evaluator address value effects ()
dealloc = sendAllocator . Delete
dealloc :: (Member (State (Heap address value)) effects, Ord address) => address -> Evaluator address value effects ()
dealloc addr = modifyHeap (heapDelete addr)
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
deref :: Member (Deref address value) effects => address -> Evaluator address value effects value
deref = send . Deref
deref :: ( Member (Deref value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> address
-> Evaluator address value effects value
deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . DerefCell >>= maybeM (throwAddressError (UninitializedAddress addr))
-- | Write a value to the given address in the 'Allocator'.
assign :: Member (Allocator address value) effects
assign :: ( Member (Deref value) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> address
-> value
-> Evaluator address value effects ()
assign address = send . Assign address
assign addr value = do
heap <- getHeap
cell <- send (AssignCell value (fromMaybe lowerBound (heapLookup addr heap)))
putHeap (heapInit addr cell heap)
-- | Look up or allocate an address for a 'Name'.
lookupOrAlloc :: ( Member (Allocator address value) effects
lookupOrAlloc :: ( Member (Allocator address) effects
, Member (Env address) effects
)
=> Name
@ -96,8 +110,11 @@ lookupOrAlloc :: ( Member (Allocator address value) effects
lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
letrec :: ( Member (Allocator address value) effects
letrec :: ( Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> Evaluator address value effects value
@ -109,7 +126,7 @@ letrec name body = do
pure (v, addr)
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
letrec' :: ( Member (Allocator address value) effects
letrec' :: ( Member (Allocator address) effects
, Member (Env address) effects
)
=> Name
@ -135,10 +152,13 @@ variable name = lookupEnv name >>= maybeM (freeVariableError name)
-- Garbage collection
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
gc :: Member (Allocator address value) effects
gc :: ( Member (State (Heap address value)) effects
, Ord address
, ValueRoots address value
)
=> Live address -- ^ The set of addresses to consider rooted.
-> Evaluator address value effects ()
gc roots = sendAllocator (GC roots)
gc roots = modifyHeap (heapRestrict <*> reachable roots)
-- | Compute the set of addresses reachable from a given root set in a given heap.
reachable :: ( Ord address
@ -157,59 +177,23 @@ reachable roots heap = go mempty roots
-- Effects
sendAllocator :: Member (Allocator address value) effects => Allocator address value (Eff effects) return -> Evaluator address value effects return
sendAllocator = send
data Allocator address (m :: * -> *) return where
Alloc :: Name -> Allocator address m address
data Allocator address value (m :: * -> *) return where
Alloc :: Name -> Allocator address value m address
Assign :: address -> value -> Allocator address value m ()
GC :: Live address -> Allocator address value m ()
Delete :: address -> Allocator address value m ()
data Deref value (m :: * -> *) return where
DerefCell :: Set value -> Deref value m (Maybe value)
AssignCell :: value -> Set value -> Deref value m (Set value)
data Deref address value (m :: * -> *) return where
Deref :: address -> Deref address value m value
instance PureEffect (Allocator address)
runAllocator :: ( Allocatable address effects
, Member (State (Heap address value)) effects
, Ord value
, PureEffects effects
, ValueRoots address value
)
=> Evaluator address value (Allocator address value ': effects) a
-> Evaluator address value effects a
runAllocator = interpret $ \ eff -> case eff of
Alloc name -> allocCell name
Assign addr value -> do
heap <- getHeap
cell <- assignCell addr value (fromMaybe mempty (heapLookup addr heap))
putHeap (heapInit addr cell heap)
GC roots -> modifyHeap (heapRestrict <*> reachable roots)
Delete addr -> modifyHeap (heapDelete addr)
runDeref :: ( Derefable address effects
, PureEffects effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address value)) effects
)
=> Evaluator address value (Deref address value ': effects) a
-> Evaluator address value effects a
runDeref = interpret $ \ eff -> case eff of
Deref addr -> heapLookup addr <$> get >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwAddressError (UninitializedAddress addr))
instance PureEffect (Allocator address value)
instance Effect (Allocator address value) where
instance Effect (Allocator address) where
handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k)
handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (dist . (<$ c) . k)
handleState c dist (Request (GC roots) k) = Request (GC roots) (dist . (<$ c) . k)
handleState c dist (Request (Delete addr) k) = Request (Delete addr) (dist . (<$ c) . k)
instance PureEffect (Deref address value)
instance PureEffect (Deref value)
instance Effect (Deref address value) where
handleState c dist (Request (Deref addr) k) = Request (Deref addr) (dist . (<$ c) . k)
instance Effect (Deref value) where
handleState c dist (Request (DerefCell cell) k) = Request (DerefCell cell) (dist . (<$ c) . k)
handleState c dist (Request (AssignCell value cell) k) = Request (AssignCell value cell) (dist . (<$ c) . k)
data AddressError address value resume where
UnallocatedAddress :: address -> AddressError address value (Set value)

15
src/Control/Abstract/Hole.hs
View File

@ -1,21 +1,6 @@
module Control.Abstract.Hole
( AbstractHole (..)
, Hole (..)
, toMaybe
) where
import Prologue
class AbstractHole a where
hole :: a
data Hole context a = Partial context | Total a
deriving (Foldable, Functor, Eq, Ord, Show, Traversable)
instance Lower context => AbstractHole (Hole context a) where
hole = Partial lowerBound
toMaybe :: Hole context a -> Maybe a
toMaybe (Partial _) = Nothing
toMaybe (Total a) = Just a

6
src/Control/Abstract/Modules.hs
View File

@ -127,9 +127,9 @@ throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (Modu
-- | An error thrown when we can't resolve a module from a qualified name.
data ResolutionError resume where
NotFoundError :: String -- ^ The path that was not found.
-> [String] -- ^ List of paths searched that shows where semantic looked for this module.
-> Language -- ^ Language.
NotFoundError :: String -- The path that was not found.
-> [String] -- List of paths searched that shows where semantic looked for this module.
-> Language -- Language.
-> ResolutionError ModulePath
GoImportError :: FilePath -> ResolutionError [ModulePath]

29
src/Control/Abstract/Primitive.hs
View File

@ -21,10 +21,13 @@ import Data.Text (unpack)
import Prologue
define :: ( HasCallStack
, Member (Allocator address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> Evaluator address value effects value
@ -36,10 +39,13 @@ define name def = withCurrentCallStack callStack $ do
defineClass :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> [address]
@ -51,10 +57,13 @@ defineClass name superclasses body = define name $ do
defineNamespace :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> Evaluator address value effects a
@ -93,29 +102,35 @@ instance Member (Function address value) effects => Lambda address value effects
builtInPrint :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Deref address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> Evaluator address value effects value
builtInPrint = lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)
builtInExport :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Deref address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Evaluator address value effects value
builtInExport = lambda (\ v -> do

19
src/Control/Abstract/Value.hs
View File

@ -200,8 +200,10 @@ doWhile body cond = loop $ \ continue -> body *> do
ifthenelse this continue (pure unit)
makeNamespace :: ( AbstractValue address value effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Allocator address value) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> address
@ -229,11 +231,14 @@ evaluateInScopedEnv receiver term = do
-- | Evaluates a 'Value' returning the referenced value
value :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> ValueRef address
-> Evaluator address value effects value
@ -241,11 +246,14 @@ value = deref <=< address
-- | Evaluates a 'Subterm' to its rval
subtermValue :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> Evaluator address value effects value
@ -276,8 +284,11 @@ subtermAddress :: ( AbstractValue address value effects
subtermAddress = address <=< subtermRef
-- | Convenience function for boxing a raw value and wrapping it in an Rval
rvalBox :: ( Member (Allocator address value) effects
rvalBox :: ( Member (Allocator address) effects
, Member (Deref value) effects
, Member Fresh effects
, Member (State (Heap address value)) effects
, Ord address
)
=> value
-> Evaluator address value effects (ValueRef address)

36
src/Data/Abstract/Address.hs
View File

@ -1,36 +0,0 @@
module Data.Abstract.Address
( Precise (..)
, Located (..)
, Monovariant (..)
) where
import Data.Abstract.Module (ModuleInfo)
import Data.Abstract.Name
import Data.Abstract.Package (PackageInfo)
import Data.Span
import Prologue
-- | '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)
instance Show Precise where
showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
-- | '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)
instance Show Monovariant where
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
data Located address = Located
{ address :: address
, addressPackage :: {-# UNPACK #-} !PackageInfo
, addressModule :: !ModuleInfo
, addressName :: Name
, addressSpan :: Span
}
deriving (Eq, Ord, Show)

50
src/Data/Abstract/Address/Hole.hs Normal file
View File

@ -0,0 +1,50 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
module Data.Abstract.Address.Hole
( Hole(..)
, toMaybe
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Prologue
data Hole context a = Partial context | Total a
deriving (Foldable, Functor, Eq, Ord, Show, Traversable)
instance Lower context => AbstractHole (Hole context a) where
hole = Partial lowerBound
toMaybe :: Hole context a -> Maybe a
toMaybe (Partial _) = Nothing
toMaybe (Total a) = Just a
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
relocate = raiseEff . lowerEff
runAllocator :: PureEffects effects
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Hole context address) value (Allocator (Hole context address) ': effects) a
-> Evaluator (Hole context address) value effects a
runAllocator handler = interpret (handleAllocator handler)
handleAllocator :: (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Allocator (Hole context address) (Eff (Allocator (Hole context address) ': effects)) a
-> Evaluator (Hole context address) value effects a
handleAllocator handler (Alloc name) = relocate (Total <$> handler (Alloc name))
runDeref :: PureEffects effects
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Hole context address) value (Deref value ': effects) a
-> Evaluator (Hole context address) value effects a
runDeref handler = interpret (handleDeref handler)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Deref value (Eff (Deref value ': effects)) a
-> Evaluator (Hole context address) value effects a
handleDeref handler (DerefCell cell) = relocate (handler (DerefCell cell))
handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))

58
src/Data/Abstract/Address/Located.hs Normal file
View File

@ -0,0 +1,58 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Located
( Located(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Data.Abstract.Module (ModuleInfo)
import Data.Abstract.Name
import Data.Abstract.Package (PackageInfo)
data Located address = Located
{ address :: address
, addressPackage :: {-# UNPACK #-} !PackageInfo
, addressModule :: !ModuleInfo
, addressName :: Name
, addressSpan :: Span
}
deriving (Eq, Ord, Show)
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
relocate = raiseEff . lowerEff
runAllocator :: ( Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, PureEffects effects
)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Located address) value (Allocator (Located address) ': effects) a
-> Evaluator (Located address) value effects a
runAllocator handler = interpret (handleAllocator handler)
handleAllocator :: ( Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
)
=> (forall x. Allocator address (Eff (Allocator address ': effects)) x -> Evaluator address value effects x)
-> Allocator (Located address) (Eff (Allocator (Located address) ': effects)) a
-> Evaluator (Located address) value effects a
handleAllocator handler (Alloc name) = relocate (Located <$> handler (Alloc name) <*> currentPackage <*> currentModule <*> pure name <*> ask)
runDeref :: PureEffects effects
=> (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Evaluator (Located address) value (Deref value ': effects) a
-> Evaluator (Located address) value effects a
runDeref handler = interpret (handleDeref handler)
handleDeref :: (forall x. Deref value (Eff (Deref value ': effects)) x -> Evaluator address value effects x)
-> Deref value (Eff (Deref value ': effects)) a
-> Evaluator (Located address) value effects a
handleDeref handler (DerefCell cell) = relocate (handler (DerefCell cell))
handleDeref handler (AssignCell value cell) = relocate (handler (AssignCell value cell))

45
src/Data/Abstract/Address/Monovariant.hs Normal file
View File

@ -0,0 +1,45 @@
{-# LANGUAGE GADTs, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Monovariant
( Monovariant(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import Data.Abstract.Name
import qualified Data.Set as Set
import Prologue
-- | '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)
instance Show Monovariant where
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
runAllocator :: PureEffects effects
=> Evaluator Monovariant value (Allocator Monovariant ': effects) a
-> Evaluator Monovariant value effects a
runAllocator = interpret handleAllocator
handleAllocator :: Allocator Monovariant (Eff (Allocator Monovariant ': effects)) a -> Evaluator Monovariant value effects a
handleAllocator (Alloc name) = pure (Monovariant name)
runDeref :: ( Member NonDet effects
, Ord value
, PureEffects effects
)
=> Evaluator Monovariant value (Deref value ': effects) a
-> Evaluator Monovariant value effects a
runDeref = interpret handleDeref
handleDeref :: ( Member NonDet effects
, Ord value
)
=> Deref value (Eff (Deref value ': effects)) a
-> Evaluator Monovariant value effects a
handleDeref (DerefCell cell) = traverse (foldMapA pure) (nonEmpty (toList cell))
handleDeref (AssignCell value cell) = pure (Set.insert value cell)

39
src/Data/Abstract/Address/Precise.hs Normal file
View File

@ -0,0 +1,39 @@
{-# LANGUAGE GADTs, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Address.Precise
( Precise(..)
, runAllocator
, handleAllocator
, runDeref
, handleDeref
) where
import Control.Abstract
import qualified Data.Set as Set
import Prologue
-- | '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)
instance Show Precise where
showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
runAllocator :: ( Member Fresh effects
, PureEffects effects
)
=> Evaluator Precise value (Allocator Precise ': effects) a
-> Evaluator Precise value effects a
runAllocator = interpret handleAllocator
handleAllocator :: Member Fresh effects => Allocator Precise (Eff (Allocator Precise ': effects)) a -> Evaluator Precise value effects a
handleAllocator (Alloc _) = Precise <$> fresh
runDeref :: PureEffects effects
=> Evaluator Precise value (Deref value ': effects) a
-> Evaluator Precise value effects a
runDeref = interpret handleDeref
handleDeref :: Deref value (Eff (Deref value ': effects)) a -> Evaluator Precise value effects a
handleDeref (DerefCell cell) = pure (fst <$> Set.minView cell)
handleDeref (AssignCell value _) = pure (Set.singleton value)

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

@ -31,7 +31,7 @@ import Prelude hiding (head, lookup)
import Prologue
-- $setup
-- >>> import Data.Abstract.Address
-- >>> import Data.Abstract.Address.Precise
-- >>> let bright = push (insertEnv (name "foo") (Precise 0) lowerBound)
-- >>> let shadowed = insertEnv (name "foo") (Precise 1) bright

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

@ -23,7 +23,7 @@ import Control.Abstract hiding (Load)
import Control.Abstract.Context as X
import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith)
import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn)
import Control.Abstract.Heap as X hiding (AddressError(..), runAddressError, runAddressErrorWith)
import Control.Abstract.Heap as X hiding (runAddressError, runAddressErrorWith)
import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError)
import Control.Abstract.Value as X hiding (Function(..))
import Data.Abstract.Declarations as X
@ -48,22 +48,25 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
eval :: ( AbstractValue address value effects
, Declarations term
, FreeVariables term
, Member (Allocator address value) effects
, Member (Deref address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (Resumable (BaseError EvalError)) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Fresh effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
eval expr = do
@ -73,8 +76,6 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
evaluate :: ( AbstractValue address value valueEffects
, Allocatable address (Reader ModuleInfo ': effects)
, Derefable address (Allocator address value ': Reader ModuleInfo ': effects)
, Declarations term
, Effects effects
, Evaluatable (Base term)
@ -93,19 +94,19 @@ evaluate :: ( AbstractValue address value valueEffects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord value
, Ord address
, Recursive term
, ValueRoots address value
, moduleEffects ~ (Exc (LoopControl address) ': Exc (Return address) ': Env address ': Deref address value ': Allocator address value ': Reader ModuleInfo ': effects)
, moduleEffects ~ (Exc (LoopControl address) ': Exc (Return address) ': Env address ': Deref value ': Allocator address ': Reader ModuleInfo ': effects)
, valueEffects ~ (Function address value ': moduleEffects)
)
=> proxy lang
-> (SubtermAlgebra Module term (TermEvaluator term address value moduleEffects address) -> SubtermAlgebra Module term (TermEvaluator term address value moduleEffects address))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value valueEffects (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value valueEffects (ValueRef address)))
-> (forall x . Evaluator address value (Deref value ': Allocator address ': Reader ModuleInfo ': effects) x -> Evaluator address value (Reader ModuleInfo ': effects) x)
-> (forall x . Evaluator address value valueEffects x -> Evaluator address value moduleEffects x)
-> [Module term]
-> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
evaluate lang analyzeModule analyzeTerm runValue modules = do
evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
(preludeBinds, _) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack . runValue $ do
definePrelude lang
box unit
@ -124,8 +125,7 @@ evaluate lang analyzeModule analyzeTerm runValue modules = do
runInModule preludeBinds info
= runReader info
. runAllocator
. runDeref
. runAllocDeref
. runEnv (EvalContext Nothing (X.push (newEnv preludeBinds)))
. runReturn
. runLoopControl
@ -140,15 +140,18 @@ traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
class HasPrelude (language :: Language) where
definePrelude :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Deref address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> proxy language
-> Evaluator address value effects ()
@ -185,8 +188,8 @@ instance HasPrelude 'JavaScript where
class HasPostlude (language :: Language) where
postlude :: ( AbstractValue address value effects
, HasCallStack
, Member (Allocator address value) effects
, Member (Deref address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects

17
src/Data/Abstract/Value/Abstract.hs
View File

@ -5,6 +5,7 @@ module Data.Abstract.Value.Abstract
) where
import Control.Abstract as Abstract
import Data.Abstract.BaseError
import Data.Abstract.Environment as Env
import Prologue
@ -12,11 +13,16 @@ data Abstract = Abstract
deriving (Eq, Ord, Show)
runFunction :: ( Member (Allocator address Abstract) effects
, Member (Deref address Abstract) effects
runFunction :: ( Member (Allocator address) effects
, Member (Deref Abstract) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address Abstract))) effects
, Member (State (Heap address Abstract)) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Abstract (Function address Abstract ': effects) a
@ -53,9 +59,12 @@ instance AbstractIntro Abstract where
kvPair _ _ = Abstract
null = Abstract
instance ( Member (Allocator address Abstract) effects
, Member NonDet effects
instance ( Member (Allocator address) effects
, Member (Deref Abstract) effects
, Member Fresh effects
, Member NonDet effects
, Member (State (Heap address Abstract)) effects
, Ord address
)
=> AbstractValue address Abstract effects where
array _ = pure Abstract

20
src/Data/Abstract/Value/Concrete.hs
View File

@ -61,14 +61,18 @@ instance Ord address => ValueRoots address (Value address body) where
| otherwise = mempty
runFunction :: ( Member (Allocator address (Value address body)) effects
runFunction :: ( Member (Allocator address) effects
, Member (Deref (Value address body)) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (State (Heap address (Value address body))) effects
, Ord address
, PureEffects effects
)
=> (body address -> Evaluator address (Value address body) (Abstract.Function address (Value address body) ': effects) address)
@ -111,7 +115,12 @@ instance Show address => AbstractIntro (Value address body) where
null = Null
materializeEnvironment :: ( Member (Deref address (Value address body)) effects
materializeEnvironment :: ( Member (Deref (Value address body)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (State (Heap address (Value address body))) effects
, Ord address
)
=> Value address body
-> Evaluator address (Value address body) effects (Maybe (Environment address))
@ -135,8 +144,8 @@ materializeEnvironment val = do
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Coercible body (Eff effects)
, Member (Allocator address (Value address body)) effects
, Member (Deref address (Value address body)) effects
, Member (Allocator address) effects
, Member (Deref (Value address body)) effects
, Member (Env address) effects
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
@ -145,6 +154,9 @@ instance ( Coercible body (Eff effects)
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (State (Heap address (Value address body))) effects
, Ord address
, Show address
)
=> AbstractValue address (Value address body) effects where

14
src/Data/Abstract/Value/Type.hs
View File

@ -228,15 +228,18 @@ instance Ord address => ValueRoots address Type where
valueRoots _ = mempty
runFunction :: ( Member (Allocator address Type) effects
, Member (Deref address Type) effects
runFunction :: ( Member (Allocator address) effects
, Member (Deref Type) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (State (Heap address Type)) effects
, Member (State TypeMap) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Type (Abstract.Function address Type ': effects) a
@ -277,14 +280,17 @@ instance AbstractIntro Type where
null = Null
-- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Member (Allocator address Type) effects
, Member (Deref address Type) effects
instance ( Member (Allocator address) effects
, Member (Deref Type) effects
, Member Fresh effects
, Member NonDet effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State (Heap address Type)) effects
, Member (State TypeMap) effects
, Ord address
)
=> AbstractValue address Type effects where
array fields = do

5
src/Language/PHP/Syntax.hs
View File

@ -51,14 +51,17 @@ resolvePHPName n = do
toName = T.unpack . dropRelativePrefix . stripQuotes
include :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> (ModulePath -> Evaluator address value effects (ModuleResult address))

5
src/Language/Python/Syntax.hs
View File

@ -147,9 +147,12 @@ instance Evaluatable Import where
-- Evaluate a qualified import
evalQualifiedImport :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name -> ModulePath -> Evaluator address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do

5
src/Language/TypeScript/Resolution.hs
View File

@ -164,9 +164,12 @@ javascriptExtensions :: [String]
javascriptExtensions = ["js"]
evalRequire :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Allocator address) effects
, Member (Deref value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> M.ModulePath
-> Name

19
src/Semantic/Graph.hs
View File

@ -29,7 +29,10 @@ import Analysis.Abstract.Caching
import Analysis.Abstract.Collecting
import Analysis.Abstract.Graph as Graph
import Control.Abstract
import Data.Abstract.Address
import Data.Abstract.Address.Hole as Hole
import Data.Abstract.Address.Located as Located
import Data.Abstract.Address.Monovariant as Monovariant
import Data.Abstract.Address.Precise as Precise
import Data.Abstract.BaseError (BaseError(..))
import Data.Abstract.Evaluatable
import Data.Abstract.Module
@ -114,7 +117,10 @@ runCallGraph lang includePackages modules package = do
. providingLiveSet
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) (Located Monovariant)))))))
. raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm Abstract.runFunction modules))
runAddressEffects
= Hole.runAllocator (Located.handleAllocator Monovariant.handleAllocator)
. Hole.runDeref (Located.handleDeref Monovariant.handleDeref)
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects Abstract.runFunction modules))
runImportGraphToModuleInfos :: forall effs lang term.
( Declarations term
@ -181,15 +187,18 @@ runImportGraph lang (package :: Package term) f =
. runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ImportGraphEff (Hole (Maybe Name) Precise) effs))
. runReader (packageInfo package)
. runReader lowerBound
in extractGraph <$> runEvaluator (runImportGraphAnalysis (evaluate lang analyzeModule id (Concrete.runFunction coerce coerce) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
runAddressEffects
= Hole.runAllocator Precise.handleAllocator
. Hole.runDeref Precise.handleDeref
in extractGraph <$> runEvaluator (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (Concrete.runFunction coerce coerce) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
newtype ImportGraphEff address outerEffects a = ImportGraphEff
{ runImportGraphEff :: Eff ( Function address (Value address (ImportGraphEff address outerEffects))
': Exc (LoopControl address)
': Exc (Return address)
': Env address
': Deref address (Value address (ImportGraphEff address outerEffects))
': Allocator address (Value address (ImportGraphEff address outerEffects))
': Deref (Value address (ImportGraphEff address outerEffects))
': Allocator address
': Reader ModuleInfo
': Reader Span
': Reader PackageInfo

11
src/Semantic/Util.hs
View File

@ -9,7 +9,8 @@ import Analysis.Abstract.Collecting
import Control.Abstract
import Control.Exception (displayException)
import Control.Monad.Effect.Trace (runPrintingTrace)
import Data.Abstract.Address
import Data.Abstract.Address.Monovariant as Monovariant
import Data.Abstract.Address.Precise as Precise
import Data.Abstract.BaseError (BaseError(..))
import Data.Abstract.Evaluatable
import Data.Abstract.Module
@ -57,8 +58,8 @@ newtype UtilEff a = UtilEff
, Exc (LoopControl Precise)
, Exc (Return Precise)
, Env Precise
, Deref Precise (Value Precise UtilEff)
, Allocator Precise (Value Precise UtilEff)
, Deref (Value Precise UtilEff)
, Allocator Precise
, Reader ModuleInfo
, Modules Precise
, Reader (ModuleTable (NonEmpty (Module (ModuleResult Precise))))
@ -130,7 +131,7 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
(runReader (lowerBound @Span)
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(evaluate proxy id withTermSpans (Concrete.runFunction coerce coerce) modules))))))
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runFunction coerce coerce) modules))))))
evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do
@ -141,7 +142,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $
(runReader (lowerBound @Span)
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(evaluate proxy id withTermSpans Type.runFunction modules)))))
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) Type.runFunction modules)))))
parseFile :: Parser term -> FilePath -> IO term

9
test/Control/Abstract/Evaluator/Spec.hs
View File

@ -5,6 +5,7 @@ module Control.Abstract.Evaluator.Spec
) where
import Control.Abstract
import Data.Abstract.Address.Precise as Precise
import Data.Abstract.BaseError
import Data.Abstract.Module
import qualified Data.Abstract.Number as Number
@ -42,8 +43,8 @@ evaluate
. runValueError
. runEnvironmentError
. runAddressError
. runDeref
. runAllocator @Precise @_ @Val
. Precise.runDeref @_ @Val
. Precise.runAllocator
. (>>= deref . snd)
. runEnv lowerBound
. runReturn
@ -59,8 +60,8 @@ newtype SpecEff a = SpecEff
, Exc (LoopControl Precise)
, Exc (Return Precise)
, Env Precise
, Allocator Precise Val
, Deref Precise Val
, Allocator Precise
, Deref Val
, Resumable (BaseError (AddressError Precise Val))
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (ValueError Precise SpecEff))

2
test/Doctests.hs
View File

@ -6,7 +6,7 @@ import System.Environment
import Test.DocTest
defaultFiles =
[ "src/Data/Abstract/Address.hs"
[ "src/Data/Abstract/Address/Precise.hs"
, "src/Data/Abstract/Environment.hs"
, "src/Data/Abstract/Name.hs"
, "src/Data/Graph.hs"

2
test/SpecHelpers.hs
View File

@ -22,7 +22,7 @@ import Control.Abstract
import Control.Arrow ((&&&))
import Control.Monad.Effect.Trace as X (runIgnoringTrace, runReturningTrace)
import Control.Monad ((>=>))
import Data.Abstract.Address as X
import Data.Abstract.Address.Precise as X
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables as X