Merge pull request #1848 from github/allocator-effect

Allocator effect

src/Analysis/Abstract/Caching.hs

@@ -79,9 +79,9 @@ cachingTerms recur term = do
       cachingConfiguration c pairs (recur term)
 
 convergingModules :: ( AbstractValue location value effects
-                     , Addressable location effects
                      , Cacheable term location (Cell location) value
-                     , Members '[ Fresh
+                     , Members '[ Allocator location value
+                                , Fresh
                                 , NonDet
                                 , Reader (Cache term location (Cell location) value)
                                 , Reader (Environment location value)

src/Control/Abstract/Addressable.hs

@@ -1,129 +1,43 @@
-{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
-module Control.Abstract.Addressable where
+{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
+module Control.Abstract.Addressable
+( Addressable(..)
+) where
 
 import Control.Abstract.Context
-import Control.Abstract.Environment
 import Control.Abstract.Evaluator
-import Control.Abstract.Heap
 import Data.Abstract.Address
-import Data.Abstract.Environment (insert)
 import Data.Abstract.FreeVariables
-import Data.Semigroup.Reducer
 import Prologue
 
--- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap.
+-- | Defines allocation and dereferencing of 'Address'es in a 'Heap'.
 class (Ord location, Show location) => Addressable location effects where
+  -- | The type into which stored values will be written for a given location type.
+  type family Cell location :: * -> *
+
+  allocCell :: Name -> Evaluator location value effects location
   derefCell :: Address location value -> Cell location value -> Evaluator location value effects (Maybe value)
 
-  allocLoc :: Name -> Evaluator location value effects location
 
--- | Look up or allocate an address for a 'Name'.
-lookupOrAlloc :: ( Addressable location effects
-                 , Members '[ Reader (Environment location value)
-                            , State (Environment location value)
-                            ] effects
-                 )
-              => Name
-              -> Evaluator location value effects (Address location value)
-lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
-
-
-letrec :: ( Addressable location effects
-          , Members '[ Reader (Environment location value)
-                     , State (Environment location value)
-                     , State (Heap location (Cell location) value)
-                     ] effects
-          , Reducer value (Cell location value)
-          )
-       => Name
-       -> Evaluator location value effects value
-       -> Evaluator location value effects (value, Address location value)
-letrec name body = do
-  addr <- lookupOrAlloc name
-  v <- localEnv (insert name addr) body
-  assign addr v
-  pure (v, addr)
-
--- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
-letrec' :: ( Addressable location effects
-           , Members '[ Reader (Environment location value)
-                      , State (Environment location value)
-                      ] effects
-           )
-        => Name
-        -> (Address location value -> Evaluator location value effects value)
-        -> Evaluator location value effects value
-letrec' name body = do
-  addr <- lookupOrAlloc name
-  v <- localEnv id (body addr)
-  v <$ modifyEnv (insert name addr)
-
-
--- | Look up and dereference the given 'Name', throwing an exception for free variables.
-variable :: ( Addressable location effects
-            , Members '[ Reader (Environment location value)
-                       , Resumable (AddressError location value)
-                       , Resumable (EnvironmentError value)
-                       , State (Environment location value)
-                       , State (Heap location (Cell location) value)
-                       ] effects
-            )
-         => Name
-         -> Evaluator location value effects value
-variable name = lookupEnv name >>= maybe (freeVariableError name) deref
-
--- Instances
-
--- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
+-- | 'Precise' locations are always allocated a fresh 'Address', and dereference to the 'Latest' value written.
 instance Member Fresh effects => Addressable Precise effects where
+  type Cell Precise = Latest
+
+  allocCell _ = Precise <$> fresh
   derefCell _ = pure . getLast . unLatest
-  allocLoc _ = Precise <$> fresh
 
--- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
+-- | 'Monovariant' locations allocate one 'Address' per unique variable name, and dereference once per stored value, nondeterministically.
 instance Member NonDet effects => Addressable Monovariant effects where
-  derefCell _ cell | null cell = pure Nothing
-                   | otherwise = foldMapA (pure . Just) cell
-  allocLoc = pure . Monovariant
+  type Cell Monovariant = All
 
-instance ( Addressable location effects
-         , Members '[ Reader ModuleInfo
-                    , Reader PackageInfo
-                    ] effects
-         )
-      => Addressable (Located location) effects where
-  derefCell (Address (Located loc _ _)) = raiseEff . lowerEff . derefCell (Address loc)
+  allocCell = pure . Monovariant
+  derefCell _ = traverse (foldMapA pure) . nonEmpty . toList
 
-  allocLoc name = raiseEff (lowerEff (Located <$> allocLoc name <*> currentPackage <*> currentModule))
+-- | 'Located' locations allocate & dereference using the underlying location, contextualizing locations with the current 'PackageInfo' & 'ModuleInfo'.
+instance (Addressable location effects, Members '[Reader ModuleInfo, Reader PackageInfo] effects) => Addressable (Located location) effects where
+  type Cell (Located location) = Cell location
 
--- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
-deref :: (Addressable location effects, Members '[Resumable (AddressError location value), State (Heap location (Cell location) value)] effects) => Address location value -> Evaluator location value effects value
-deref addr = do
-  cell <- lookupHeap addr >>= maybeM (throwAddressError (UnallocatedAddress addr))
-  derefed <- derefCell addr cell
-  maybeM (throwAddressError (UninitializedAddress addr)) derefed
+  allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule)
+  derefCell (Address (Located loc _ _)) = relocate . derefCell (Address loc)
 
-alloc :: Addressable location effects => Name -> Evaluator location value effects (Address location value)
-alloc = fmap Address . allocLoc
-
-data AddressError location value resume where
-  UnallocatedAddress :: Address location value -> AddressError location value (Cell location value)
-  UninitializedAddress :: Address location value -> AddressError location value value
-
-deriving instance Eq location => Eq (AddressError location value resume)
-deriving instance Show location => Show (AddressError location value resume)
-instance Show location => Show1 (AddressError location value) where
-  liftShowsPrec _ _ = showsPrec
-instance Eq location => Eq1 (AddressError location value) where
-  liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
-  liftEq _ (UnallocatedAddress a)   (UnallocatedAddress b)   = a == b
-  liftEq _ _                        _                        = False
-
-
-throwAddressError :: Member (Resumable (AddressError location value)) effects => AddressError location value resume -> Evaluator location value effects resume
-throwAddressError = throwResumable
-
-runAddressError :: Effectful (m location value) => m location value (Resumable (AddressError location value) ': effects) a -> m location value effects (Either (SomeExc (AddressError location value)) a)
-runAddressError = runResumable
-
-runAddressErrorWith :: Effectful (m location value) => (forall resume . AddressError location value resume -> m location value effects resume) -> m location value (Resumable (AddressError location value) ': effects) a -> m location value effects a
-runAddressErrorWith = runResumableWith
+relocate :: Evaluator location value effects a -> Evaluator (Located location) value effects a
+relocate = raiseEff . lowerEff

src/Control/Abstract/Configuration.hs

@@ -4,6 +4,7 @@ module Control.Abstract.Configuration
 , getConfiguration
 ) where
 
+import Control.Abstract.Addressable
 import Control.Abstract.Environment
 import Control.Abstract.Heap
 import Control.Abstract.Roots

src/Control/Abstract/Heap.hs

@@ -1,17 +1,33 @@
+{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Heap
 ( Heap
-, Cell
 , getHeap
 , putHeap
 , modifyHeap
-, lookupHeap
+, alloc
+, deref
 , assign
+, lookupOrAlloc
+, letrec
+, letrec'
+, variable
+-- * Effects
+, Allocator(..)
+, runAllocator
+, AddressError(..)
+, runAddressError
+, runAddressErrorWith
 ) where
 
+import Control.Abstract.Addressable
+import Control.Abstract.Environment
 import Control.Abstract.Evaluator
 import Data.Abstract.Address
+import Data.Abstract.Environment
+import Data.Abstract.FreeVariables
 import Data.Abstract.Heap
 import Data.Semigroup.Reducer
+import Prologue
 
 -- | Retrieve the heap.
 getHeap :: Member (State (Heap location (Cell location) value)) effects => Evaluator location value effects (Heap location (Cell location) value)
@@ -25,9 +41,14 @@ putHeap = put
 modifyHeap :: Member (State (Heap location (Cell location) value)) effects => (Heap location (Cell location) value -> Heap location (Cell location) value) -> Evaluator location value effects ()
 modifyHeap = modify'
 
--- | Look up the cell for the given 'Address' in the 'Heap'.
-lookupHeap :: (Member (State (Heap location (Cell location) value)) effects, Ord location) => Address location value -> Evaluator location value effects (Maybe (Cell location value))
-lookupHeap = flip fmap getHeap . heapLookup
+
+alloc :: Member (Allocator location value) effects => Name -> Evaluator location value effects (Address location value)
+alloc = send . Alloc
+
+-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
+deref :: Member (Allocator location value) effects => Address location value -> Evaluator location value effects value
+deref = send . Deref
+
 
 -- | Write a value to the given 'Address' in the 'Store'.
 assign :: ( Member (State (Heap location (Cell location) value)) effects
@@ -38,3 +59,89 @@ assign :: ( Member (State (Heap location (Cell location) value)) effects
        -> value
        -> Evaluator location value effects ()
 assign address = modifyHeap . heapInsert address
+
+
+-- | Look up or allocate an address for a 'Name'.
+lookupOrAlloc :: Members '[ Allocator location value
+                          , Reader (Environment location value)
+                          , State (Environment location value)
+                          ] effects
+              => Name
+              -> Evaluator location value effects (Address location value)
+lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
+
+
+letrec :: ( Members '[ Allocator location value
+                     , Reader (Environment location value)
+                     , State (Environment location value)
+                     , State (Heap location (Cell location) value)
+                     ] effects
+          , Ord location
+          , Reducer value (Cell location value)
+          )
+       => Name
+       -> Evaluator location value effects value
+       -> Evaluator location value effects (value, Address location value)
+letrec name body = do
+  addr <- lookupOrAlloc name
+  v <- localEnv (insert name addr) body
+  assign addr v
+  pure (v, addr)
+
+-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
+letrec' :: Members '[ Allocator location value
+                    , Reader (Environment location value)
+                    , State (Environment location value)
+                    ] effects
+        => Name
+        -> (Address location value -> Evaluator location value effects value)
+        -> Evaluator location value effects value
+letrec' name body = do
+  addr <- lookupOrAlloc name
+  v <- localEnv id (body addr)
+  v <$ modifyEnv (insert name addr)
+
+
+-- | Look up and dereference the given 'Name', throwing an exception for free variables.
+variable :: Members '[ Allocator location value
+                     , Reader (Environment location value)
+                     , Resumable (EnvironmentError value)
+                     , State (Environment location value)
+                     , State (Heap location (Cell location) value)
+                     ] effects
+         => Name
+         -> Evaluator location value effects value
+variable name = lookupEnv name >>= maybe (freeVariableError name) deref
+
+
+-- Effects
+
+data Allocator location value return where
+  Alloc :: Name                   -> Allocator location value (Address location value)
+  Deref :: Address location value -> Allocator location value value
+
+runAllocator :: (Addressable location effects, Members '[Resumable (AddressError location value), State (Heap location (Cell location) value)] effects) => Evaluator location value (Allocator location value ': effects) a -> Evaluator location value effects a
+runAllocator = interpret (\ eff -> case eff of
+  Alloc name -> Address <$> allocCell name
+  Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)))
+
+
+data AddressError location value resume where
+  UnallocatedAddress   :: Address location value -> AddressError location value (Cell location value)
+  UninitializedAddress :: Address location value -> AddressError location value value
+
+deriving instance Eq location => Eq (AddressError location value resume)
+deriving instance Show location => Show (AddressError location value resume)
+instance Show location => Show1 (AddressError location value) where
+  liftShowsPrec _ _ = showsPrec
+instance Eq location => Eq1 (AddressError location value) where
+  liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
+  liftEq _ (UnallocatedAddress a)   (UnallocatedAddress b)   = a == b
+  liftEq _ _                        _                        = False
+
+
+runAddressError :: Effectful (m location value) => m location value (Resumable (AddressError location value) ': effects) a -> m location value effects (Either (SomeExc (AddressError location value)) a)
+runAddressError = runResumable
+
+runAddressErrorWith :: Effectful (m location value) => (forall resume . AddressError location value resume -> m location value effects resume) -> m location value (Resumable (AddressError location value) ': effects) a -> m location value effects a
+runAddressErrorWith = runResumableWith

src/Control/Abstract/Value.hs

@@ -10,10 +10,11 @@ module Control.Abstract.Value
 , ValueRoots(..)
 ) where
 
+import Control.Abstract.Addressable
 import Control.Abstract.Environment
 import Control.Abstract.Evaluator
 import Control.Abstract.Heap
-import Data.Abstract.Address (Address, Cell)
+import Data.Abstract.Address (Address)
 import Data.Abstract.Environment as Env
 import Data.Abstract.FreeVariables
 import Data.Abstract.Live (Live)

src/Data/Abstract/Address.hs

@@ -22,18 +22,10 @@ instance Show location => Show (Address location value) where
   showsPrec d = showsPrec d . unAddress
 
 
-class Location location where
-  -- | The type into which stored values will be written for a given location type.
-  type family Cell location :: * -> *
-
-
 -- | '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 Location Precise where
-  type Cell Precise = Latest
-
 instance Show Precise where
   showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise
 
@@ -42,9 +34,6 @@ instance Show Precise where
 newtype Monovariant = Monovariant { unMonovariant :: Name }
   deriving (Eq, Ord)
 
-instance Location Monovariant where
-  type Cell Monovariant = All
-
 instance Show Monovariant where
   showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unName . unMonovariant
 
@@ -56,9 +45,6 @@ data Located location = Located
   }
   deriving (Eq, Ord, Show)
 
-instance Location (Located location) where
-  type Cell (Located location) = Cell location
-
 
 -- | A cell holding a single value. Writes will replace any prior value.
 --

src/Data/Abstract/Environment.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE TypeFamilies #-}
 module Data.Abstract.Environment
   ( Environment(..)
   , addresses
@@ -19,16 +18,15 @@ module Data.Abstract.Environment
   , roots
   ) where
 
-import           Prelude hiding (head, lookup)
 import           Data.Abstract.Address
 import           Data.Abstract.FreeVariables
 import           Data.Abstract.Live
 import           Data.Align
+import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map as Map
 import           Data.Semilattice.Lower
-import           GHC.Exts (IsList (..))
+import           Prelude hiding (head, lookup)
 import           Prologue
-import qualified Data.List.NonEmpty as NonEmpty
 
 -- $setup
 -- >>> let bright = push (insert (name "foo") (Address (Precise 0)) emptyEnv)
@@ -37,21 +35,13 @@ import qualified Data.List.NonEmpty as NonEmpty
 -- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
 --   All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
 --   scope for "a", then the next, and so on.
-newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name location) }
+newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name (Address location value)) }
   deriving (Eq, Ord)
 
-instance Eq   location => Eq1   (Environment location) where liftEq      _ (Environment a) (Environment b) = a == b
-instance Ord  location => Ord1  (Environment location) where liftCompare _ (Environment a) (Environment b) = a `compare` b
+instance Eq location   => Eq1   (Environment location) where liftEq      eq      (Environment a) (Environment b) = liftEq      (liftEq      (liftEq      eq))      a b
+instance Ord location  => Ord1  (Environment location) where liftCompare compare (Environment a) (Environment b) = liftCompare (liftCompare (liftCompare compare)) a b
 instance Show location => Show1 (Environment location) where liftShowsPrec _ _ = showsPrec
 
--- | The provided list will be put into an Environment with one member, so fromList is total
---   (despite NonEmpty's instance being partial). Don't pass in multiple Addresses for the
---   same Name or you violate the axiom that toList . fromList == id.
-instance IsList (Environment location value) where
-  type Item (Environment location value) = (Name, Address location value)
-  fromList xs                   = Environment (Map.fromList (second unAddress <$> xs) :| [])
-  toList (Environment (x :| _)) = second Address <$> Map.toList x
-
 mergeEnvs :: Environment location value -> Environment location value -> Environment location value
 mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
   Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
@@ -79,29 +69,29 @@ mergeNewer (Environment a) (Environment b) =
     Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs))
     where
       combine = Map.unionWith (flip const)
-      as = NonEmpty.toList a
-      bs = NonEmpty.toList b
+      as = toList a
+      bs = toList b
 
 -- | Extract an association list of bindings from an 'Environment'.
 --
 -- >>> pairs shadowed
 -- [("foo",Precise 1)]
 pairs :: Environment location value -> [(Name, Address location value)]
-pairs = map (second Address) . Map.toList . fold . unEnvironment
+pairs = Map.toList . fold . unEnvironment
 
 unpairs :: [(Name, Address location value)] -> Environment location value
-unpairs = fromList
+unpairs = Environment . pure . Map.fromList
 
 -- | Lookup a 'Name' in the environment.
 --
 -- >>> lookup (name "foo") shadowed
 -- Just (Precise 1)
 lookup :: Name -> Environment location value -> Maybe (Address location value)
-lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment
+lookup k = foldMapA (Map.lookup k) . unEnvironment
 
 -- | Insert a 'Name' in the environment.
 insert :: Name -> Address location value -> Environment location value -> Environment location value
-insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as)
+insert name address (Environment (a :| as)) = Environment (Map.insert name address a :| as)
 
 -- | Remove a 'Name' from the environment.
 --
@@ -115,7 +105,7 @@ trim (Environment (a :| as)) = Environment (a :| filtered)
   where filtered = filter (not . Map.null) as
 
 bind :: Foldable t => t Name -> Environment location value -> Environment location value
-bind names env = fromList (mapMaybe lookupName (Prologue.toList names))
+bind names env = unpairs (mapMaybe lookupName (toList names))
   where
     lookupName name = (,) name <$> lookup name env
 
@@ -125,7 +115,7 @@ names = fmap fst . pairs
 
 -- | Lookup and alias name-value bindings from an environment.
 overwrite :: [(Name, Name)] -> Environment location value -> Environment location value
-overwrite pairs env = fromList $ mapMaybe lookupAndAlias pairs
+overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
   where
     lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
 

src/Data/Abstract/Evaluatable.hs

@@ -52,16 +52,15 @@ class Evaluatable constr where
 
 type EvaluatableConstraints location term value effects =
   ( AbstractValue location value effects
-  , Addressable location effects
   , Declarations term
   , FreeVariables term
-  , Members '[ LoopControl value
+  , Members '[ Allocator location value
+             , LoopControl value
              , Modules location value
              , Reader (Environment location value)
              , Reader ModuleInfo
              , Reader PackageInfo
              , Reader Span
-             , Resumable (AddressError location value)
              , Resumable (EnvironmentError value)
              , Resumable (EvalError value)
              , Resumable ResolutionError
@@ -72,6 +71,7 @@ type EvaluatableConstraints location term value effects =
              , State (Heap location (Cell location) value)
              , Trace
              ] effects
+  , Ord location
   , Reducer value (Cell location value)
   )
 
@@ -139,10 +139,9 @@ instance Show1 (Unspecialized a) where
   liftShowsPrec _ _ = showsPrec
 
 -- | Evaluates a 'Value' returning the referenced value
-value :: ( Addressable location effects
-         , AbstractValue location value effects
-         , Members '[ Reader (Environment location value)
-                    , Resumable (AddressError location value)
+value :: ( AbstractValue location value effects
+         , Members '[ Allocator location value
+                    , Reader (Environment location value)
                     , Resumable (EnvironmentError value)
                     , Resumable (EvalError value)
                     , State (Environment location value)
@@ -156,10 +155,9 @@ value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
 value (Rval val) = pure val
 
 -- | Evaluates a 'Subterm' to its rval
-subtermValue :: ( Addressable location effects
-                , AbstractValue location value effects
-                , Members '[ Reader (Environment location value)
-                           , Resumable (AddressError location value)
+subtermValue :: ( AbstractValue location value effects
+                , Members '[ Allocator location value
+                           , Reader (Environment location value)
                            , Resumable (EnvironmentError value)
                            , Resumable (EvalError value)
                            , State (Environment location value)
@@ -200,14 +198,15 @@ traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator lo
 traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
 
 
-builtin :: ( Addressable location effects
-           , HasCallStack
-           , Members '[ Reader (Environment location value)
+builtin :: ( HasCallStack
+           , Members '[ Allocator location value
+                      , Reader (Environment location value)
                       , Reader ModuleInfo
                       , Reader Span
                       , State (Environment location value)
                       , State (Heap location (Cell location) value)
                       ] effects
+           , Ord location
            , Reducer value (Cell location value)
            )
         => String
@@ -221,20 +220,24 @@ builtin n def = withCurrentCallStack callStack $ do
 
 -- | Evaluate a given package.
 evaluatePackageWith :: forall location term value inner inner' outer
-                    .  ( Evaluatable (Base term)
+                    -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out?
+                    .  ( Addressable location (Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
+                       , Evaluatable (Base term)
                        , EvaluatableConstraints location term value inner
                        , Members '[ Fail
                                   , Fresh
                                   , Reader (Environment location value)
+                                  , Resumable (AddressError location value)
                                   , Resumable (LoadError location value)
                                   , State (Environment location value)
                                   , State (Exports location value)
+                                  , State (Heap location (Cell location) value)
                                   , State (ModuleTable (Maybe (Environment location value, value)))
                                   , Trace
                                   ] outer
                        , Recursive term
                        , inner ~ (Goto inner' value ': inner')
-                       , inner' ~ (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
+                       , inner' ~ (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
                        )
                     => (SubtermAlgebra Module      term (TermEvaluator term location value inner value) -> SubtermAlgebra Module      term (TermEvaluator term location value inner value))
                     -> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)))
@@ -259,6 +262,7 @@ evaluatePackageWith analyzeModule analyzeTerm package
 
         runInModule info
           = runReader info
+          . raiseHandler runAllocator
           . raiseHandler runReturn
           . raiseHandler runLoopControl
           . raiseHandler (runGoto Gotos getGotos)
@@ -287,7 +291,7 @@ evaluatePackageWith analyzeModule analyzeTerm package
           | otherwise          = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
         pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv)
 
-newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value outer) ': outer) value }
+newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value outer) ': outer) value }
   deriving (Lower)
 
 

src/Data/Abstract/Heap.hs

@@ -12,8 +12,6 @@ import Prologue
 newtype Heap location cell value = Heap { unHeap :: Monoidal.Map location (cell value) }
   deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable)
 
-deriving instance (Ord location, Reducer value (cell value)) => Reducer (location, value) (Heap location cell value)
-
 -- | Look up the cell of values for an 'Address' in a 'Heap', if any.
 heapLookup :: Ord location => Address location value -> Heap location cell value -> Maybe (cell value)
 heapLookup (Address address) = Monoidal.lookup address . unHeap
@@ -24,7 +22,7 @@ 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 location, Reducer value (cell value)) => Address location value -> value -> Heap location cell value -> Heap location cell value
-heapInsert (Address address) value = flip snoc (address, value)
+heapInsert address value = flip snoc (address, value)
 
 -- | Manually insert a cell into the heap at a given address.
 heapInit :: Ord location => Address location value -> cell value -> Heap location cell value -> Heap location cell value
@@ -39,6 +37,10 @@ heapRestrict :: Ord location => Heap location cell value -> Live location value
 heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m)
 
 
+instance (Ord location, Reducer value (cell value)) => Reducer (Address location value, value) (Heap location cell value) where
+  unit = Heap . unit . first unAddress
+  cons (Address key, a) (Heap heap) = Heap (cons (key, a) heap)
+  snoc (Heap heap) (Address key, a) = Heap (snoc heap (key, a))
 
 instance (Show location, Show (cell value)) => Show (Heap location cell value) where
   showsPrec d = showsUnaryWith showsPrec "Heap" d . Monoidal.pairs . unHeap

src/Data/Abstract/Type.hs

@@ -103,8 +103,8 @@ instance AbstractHole Type where
   hole = Hole
 
 -- | Discard the value arguments (if any), constructing a 'Type' instead.
-instance ( Addressable location effects
-         , Members '[ Fresh
+instance ( Members '[ Allocator location Type
+                    , Fresh
                     , NonDet
                     , Reader (Environment location Type)
                     , Resumable (AddressError location Type)
@@ -114,6 +114,7 @@ instance ( Addressable location effects
                     , State (Environment location Type)
                     , State (Heap location (Cell location) Type)
                     ] effects
+         , Ord location
          , Reducer Type (Cell location Type)
          )
       => AbstractValue location Type effects where

src/Data/Abstract/Value.hs

@@ -205,18 +205,18 @@ instance AbstractHole (Value location) where
   hole = injValue Hole
 
 -- | Construct a 'Value' wrapping the value arguments (if any).
-instance ( Addressable location (Goto effects (Value location) ': effects)
-         , Members '[ Fail
+instance ( Members '[ Allocator location (Value location)
+                    , Fail
                     , LoopControl (Value location)
                     , Reader (Environment location (Value location))
                     , Reader ModuleInfo
                     , Reader PackageInfo
-                    , Resumable (AddressError location (Value location))
                     , Resumable (ValueError location)
                     , Return (Value location)
                     , State (Environment location (Value location))
                     , State (Heap location (Cell location) (Value location))
                     ] effects
+         , Ord location
          , Reducer (Value location) (Cell location (Value location))
          , Show location
          )

src/Data/Map/Monoidal.hs

@@ -18,12 +18,9 @@ import Data.Semilattice.Lower
 import Prelude hiding (lookup)
 import Prologue hiding (Map)
 
-newtype Map key value = Map (Map.Map key value)
+newtype Map key value = Map { unMap :: Map.Map key value }
   deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, ToJSON, Traversable)
 
-unMap :: Map key value -> Map.Map key value
-unMap (Map map) = map
-
 
 singleton :: key -> value -> Map key value
 singleton k v = Map (Map.singleton k v)

src/Language/PHP/Syntax.hs

@@ -52,12 +52,11 @@ resolvePHPName n = do
   where name = toName n
         toName = BC.unpack . dropRelativePrefix . stripQuotes
 
-include :: ( Addressable location effects
-           , AbstractValue location value effects
-           , Members '[ Modules location value
+include :: ( AbstractValue location value effects
+           , Members '[ Allocator location value
+                      , Modules location value
                       , Reader (Environment location value)
                       , Resumable ResolutionError
-                      , Resumable (AddressError location value)
                       , Resumable (EnvironmentError value)
                       , Resumable (EvalError value)
                       , State (Environment location value)

src/Language/Python/Syntax.hs

@@ -128,17 +128,18 @@ instance Evaluatable Import where
 
 
 -- Evaluate a qualified import
-evalQualifiedImport :: ( AbstractValue location a effects
-                       , Addressable location effects
-                       , Reducer.Reducer a (Cell location a)
-                       , Members '[ (State (Exports location a))
-                                  , (State (Environment location a))
-                                  , (State (Heap location (Cell location) a))
-                                  , (Reader (Environment location a))
-                                  , (Modules location a)
+evalQualifiedImport :: ( AbstractValue location value effects
+                       , Members '[ Allocator location value
+                                  , Modules location value
+                                  , Reader (Environment location value)
+                                  , State (Environment location value)
+                                  , State (Exports location value)
+                                  , State (Heap location (Cell location) value)
                                   ] effects
+                       , Ord location
+                       , Reducer.Reducer value (Cell location value)
                        )
-                    => Name -> ModulePath -> Evaluator location a effects a
+                    => Name -> ModulePath -> Evaluator location value effects value
 evalQualifiedImport name path = letrec' name $ \addr -> do
   importedEnv <- maybe emptyEnv fst <$> isolate (require path)
   modifyEnv (mergeEnvs importedEnv)

src/Language/TypeScript/Syntax.hs

@@ -134,14 +134,15 @@ javascriptExtensions :: [String]
 javascriptExtensions = ["js"]
 
 evalRequire :: ( AbstractValue location value effects
-               , Addressable location effects
-               , Members '[ Modules location value
+               , Members '[ Allocator location value
+                          , Modules location value
                           , Reader (Environment location value)
                           , State (Environment location value)
                           , State (Exports location value)
                           , State (Heap location (Cell location) value)
                           , Trace
                           ] effects
+               , Ord location
                , Reducer value (Cell location value)
                )
             => M.ModulePath

test/Control/Abstract/Evaluator/Spec.hs

@@ -37,6 +37,7 @@ evaluate
   . Value.runValueError
   . runEnvironmentError
   . runAddressError
+  . runAllocator
   . runReturn
   . runLoopControl
   . fmap fst