Merge branch 'master' into serialize-test-queue-output

src/Analysis/Abstract/Caching.hs

@@ -92,8 +92,9 @@ convergingModules :: ( AbstractValue address value effects
 convergingModules recur m = do
   c <- getConfiguration (subterm (moduleBody m))
   -- Convergence here is predicated upon an Eq instance, not α-equivalence
-  cache <- converge lowerBound (\ prevCache -> isolateCache . raiseHandler locally $ do
+  cache <- converge lowerBound (\ prevCache -> isolateCache $ do
     TermEvaluator (putHeap (configurationHeap        c))
+    TermEvaluator (putEnv  (configurationEnvironment c))
     -- We need to reset fresh generation so that this invocation converges.
     resetFresh 0 $
     -- This is subtle: though the calling context supports nondeterminism, we want

src/Control/Abstract/Environment.hs

@@ -3,6 +3,7 @@ module Control.Abstract.Environment
 ( Environment
 , Exports
 , getEnv
+, putEnv
 , export
 , lookupEnv
 , bind
@@ -29,6 +30,10 @@ import Prologue
 getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address)
 getEnv = send GetEnv
 
+-- | Replace the environment.
+putEnv :: Member (Env address) effects => (Environment address) -> Evaluator address value effects ()
+putEnv = send . PutEnv
+
 -- | Add an export to the global export state.
 export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects ()
 export name alias addr = send (Export name alias addr)
@@ -62,6 +67,7 @@ data Env address m return where
   Close  :: Set Name        -> Env address m (Environment address)
   Locally :: m a            -> Env address m a
   GetEnv ::                    Env address m (Environment address)
+  PutEnv :: Environment address -> Env address m ()
   Export :: Name -> Name -> Maybe address -> Env address m ()
 
 instance Effect (Env address) where
@@ -70,6 +76,7 @@ instance Effect (Env address) where
   handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k)
   handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k)
   handleState c dist (Request GetEnv k) = Request GetEnv (dist . (<$ c) . k)
+  handleState c dist (Request (PutEnv e) k) = Request (PutEnv e) (dist . (<$ c) . k)
   handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k)
 
 runEnv :: Effects effects
@@ -94,6 +101,7 @@ handleEnv = \case
     a <- reinterpret2 handleEnv (raiseEff action)
     a <$ modify' (Env.pop @address)
   GetEnv -> get
+  PutEnv e -> put e
   Export name alias addr -> modify (Exports.insert name alias addr)
 
 -- | Errors involving the environment.

src/Control/Abstract/Heap.hs

@@ -53,11 +53,14 @@ putHeap = put
 modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Heap address (Cell address) value -> Heap address (Cell address) value) -> Evaluator address value effects ()
 modifyHeap = modify'
 
-box :: Member (Allocator address value) effects
+box :: ( Member (Allocator address value) effects
+       , Member Fresh effects
+       )
     => value
     -> Evaluator address value effects address
 box val = do
-  addr <- alloc "<box>"
+  name <- gensym
+  addr <- alloc name
   assign addr val
   pure addr
 

src/Control/Abstract/Primitive.hs

@@ -61,7 +61,7 @@ lambda :: (AbstractFunction address value effects, Member Fresh effects)
        => (Name -> Evaluator address value effects address)
        -> Evaluator address value effects value
 lambda body = do
-  var <- nameI <$> fresh
+  var <- gensym
   closure [var] lowerBound (body var)
 
 defineBuiltins :: ( AbstractValue address value effects

src/Control/Abstract/Value.hs

@@ -254,7 +254,9 @@ 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 value) effects
+           , Member Fresh effects
+           )
         => value
         -> Evaluator address value effects (ValueRef address)
 rvalBox val = Rval <$> box val

src/Data/Abstract/Evaluatable.hs

@@ -50,6 +50,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
           , Member (Env address) effects
           , Member (Exc (LoopControl address)) effects
           , Member (Exc (Return address)) effects
+          , Member Fresh effects
           , Member (Modules address) effects
           , Member (Reader ModuleInfo) effects
           , Member (Reader PackageInfo) effects
@@ -149,9 +150,11 @@ instance HasPrelude 'PHP
 
 builtInPrint :: ( AbstractIntro value
                 , AbstractFunction address value effects
-                , Member (Resumable (EnvironmentError address)) effects
+                , Member (Allocator address value) effects
                 , Member (Env address) effects
-                , Member (Allocator address value) effects)
+                , Member Fresh effects
+                , Member (Resumable (EnvironmentError address)) effects
+                )
              => Name
              -> Evaluator address value effects address
 builtInPrint v = do

src/Data/Abstract/Name.hs

@@ -2,11 +2,14 @@
 module Data.Abstract.Name
 ( Name
 -- * Constructors
+, gensym
 , name
 , nameI
 , formatName
 ) where
 
+import           Control.Monad.Effect
+import           Control.Monad.Effect.Fresh
 import           Data.Aeson
 import qualified Data.Char as Char
 import           Data.Text (Text)
@@ -33,6 +36,10 @@ instance Primitive Name where
   decodePrimitive = Name . LT.toStrict <$> Decode.text <|> I <$> Decode.int
   primType _ = Bytes
 
+-- | Generate a fresh (unused) name for use in synthesized variables/closures/etc.
+gensym :: (Functor (m effs), Member Fresh effs, Effectful m) => m effs Name
+gensym = I <$> fresh
+
 -- | Construct a 'Name' from a 'Text'.
 name :: Text -> Name
 name = Name

src/Data/Abstract/Value/Abstract.hs

@@ -30,6 +30,7 @@ instance AbstractIntro Abstract where
 instance ( Member (Allocator address Abstract) effects
          , Member (Env address) effects
          , Member (Exc (Return address)) effects
+         , Member Fresh effects
          )
       => AbstractFunction address Abstract effects where
   closure names _ body = do
@@ -47,6 +48,7 @@ instance ( Member (Allocator address Abstract) effects
 instance ( Member (Allocator address Abstract) effects
          , Member (Env address) effects
          , Member (Exc (Return address)) effects
+         , Member Fresh effects
          , Member NonDet effects
          )
       => AbstractValue address Abstract effects where