Retarget suspended continuations across forked SCI worlds

CHANGELOG.md

@@ -12,9 +12,17 @@ SCI is used in [babashka](https://github.com/babashka/babashka),
 
 ## Unreleased
 
+## 0.15.59
+
 - Caches resolved JVM instance methods per call site for performance
 - Fix [babashka#2030](https://github.com/babashka/babashka/issues/2030): `aset` on a primitive array was reflective and 170x slower than `aset-double`
 - Bump edamame to `1.6.43`
+- Add forkable interpreter worlds for Vars, namespaces, dynamic bindings, SCI
+  mutable values, and application-defined host resources.
+- Add explicit continuation-context capture and retargeting so an embedding can
+  resume a suspended computation independently in related forked worlds.
+- Add `with-detached-context` for recursively constructing an independent SCI
+  interpreter without inheriting the caller's execution-local world.
 
 ## 0.15.58
 

doc/forking.md

@@ -30,6 +30,13 @@ This shape combines four useful precedents:
   lineage.
 - Dynamic binding frames remain thread/evaluation scoped. A fork snapshots
   root bindings; it does not capture a running continuation or binding frame.
+- Hosts that suspend interpreted code can explicitly capture its dynamic
+  binding frame with `sci/capture-continuation-context`. After forking the SCI
+  context, `sci/retarget-continuation-context` creates an independent binding
+  frame for the child world, and `sci/continuation-context-fn` resumes a host
+  continuation with that world and frame installed. Retargeting is restricted
+  to the same SCI lineage. Ordinary `sci/fork` still does not implicitly copy
+  running continuations.
 - Interpreter bindings are scoped to their world. Managed asynchronous
   callbacks convey and restore both the selected world and binding frame.
 - Writes before the first fork have ordinary SCI/Clojure mutable behavior.
@@ -56,6 +63,13 @@ one fork and preserves aliases to its result.
 | Affine or movable authority | Reject the non-destructive fork, or keep authority outside the SCI value world |
 | Prohibited resource | Throw an explanatory exception from `fork-value` |
 
+An embedding that lets interpreted code construct a new, independent SCI
+interpreter should perform that construction through
+`sci/with-detached-context`. This temporarily leaves the caller's selected
+world and dynamic binding frame, runs the supplied host thunk, and restores the
+caller afterwards. Evaluating an existing SCI context recursively does not need
+this boundary; it is specifically for creating a separate context lineage.
+
 Only values directly stored in world cells are inspected. A host container that
 holds mutable children must implement the protocol and copy its own graph.
 Unclassified values retain the compatibility behavior of being shared, except

resources/SCI_VERSION

@@ -1 +1 @@
-0.15.58
+0.15.59

src/sci/core.cljc

@@ -15,6 +15,7 @@
    [sci.ctx-store :as store]
    [sci.fork :as fork]
    [sci.impl.callstack :as cs]
+   [sci.impl.execution :as execution]
    [sci.impl.interpreter :as i]
    [sci.impl.io :as sio]
    [sci.impl.macros :as macros]
@@ -58,11 +59,46 @@
    (let [meta (assoc meta :dynamic true :name (utils/unqualify-symbol name))]
      (sci.lang/->Var init-val name meta false false nil (:ns meta)))))
 
+(defn with-detached-context
+  "Invoke zero-argument `f` outside the currently executing SCI context.
+
+  Embeddings use this host boundary when interpreted code recursively creates
+  an independent SCI interpreter. The caller's active world and dynamic
+  binding frame are restored even when `f` throws. Ordinary nested evaluation
+  of an existing context does not need this function."
+  [f]
+  (store/with-ctx nil
+    (execution/call-with-detached-state f)))
+
 (defn set!
   "Establish thread local binding of dynamic var"
   [dynamic-var v]
   (t/setVal dynamic-var v))
 
+(defn capture-continuation-context
+  "Capture the active SCI context and dynamic bindings for later continuation
+  resumption. Must be called from managed SCI evaluation. The returned token is
+  opaque; use `continuation-context-fn` to resume through it.
+
+  The explicit `ctx` arity is for host embedding boundaries invoked through an
+  interpreted function after the top-level evaluation has returned."
+  ([]
+   (vars/capture-continuation-context))
+  ([ctx]
+   (vars/capture-continuation-context ctx)))
+
+(defn retarget-continuation-context
+  "Copy a captured continuation context for `target-ctx`, which must belong to
+  the same SCI lineage. The copy has independent dynamic binding boxes."
+  [continuation-context target-ctx]
+  (vars/retarget-continuation-context continuation-context target-ctx))
+
+(defn continuation-context-fn
+  "Return a function that invokes `f` with the SCI world and dynamic bindings
+  represented by `continuation-context`."
+  [continuation-context f]
+  (vars/continuation-context-fn continuation-context f))
+
 (defn new-macro-var
   "Same as new-var but adds :macro true to meta as well
   as :sci/macro true to meta of the fn itself."

src/sci/impl/execution.cljc

@@ -20,6 +20,26 @@
    :default
    (def current (volatile! (new-state))))
 
+(defn call-with-detached-state
+  "Invoke `f` with an empty execution-local state, restoring the caller's
+  interpreter state afterwards. This is the host boundary used when an SCI
+  program constructs an independent interpreter recursively."
+  [f]
+  #?(:clj
+     (let [previous (.get ^ThreadLocal current)]
+       (.set ^ThreadLocal current (new-state))
+       (try
+         (f)
+         (finally
+           (.set ^ThreadLocal current previous))))
+     :default
+     (let [previous @current]
+       (vreset! current (new-state))
+       (try
+         (f)
+         (finally
+           (vreset! current previous))))))
+
 (defn current-state []
   #?(:clj (.get ^ThreadLocal current)
      :default @current))

src/sci/impl/vars.cljc

@@ -36,6 +36,8 @@
 
 (deftype Frame [bindings prev scope prior-bindings])
 
+(defrecord ContinuationContext [ctx frame])
+
 (def top-frame (Frame. {} nil nil nil))
 
 #?(:cljs
@@ -85,6 +87,88 @@
             (execution/binding-scope state)
             nil)))
 
+(declare ^:private retarget-binding-frame)
+
+(defn capture-continuation-context
+  "Capture the current SCI context and its persistent dynamic-binding frame.
+
+  The returned value is an opaque host embedding token. It is intended for a
+  suspended continuation: invoke it later with `continuation-context-fn`, or
+  retarget an independent copy to a fork of the captured SCI context with
+  `retarget-continuation-context`."
+  ([]
+   (capture-continuation-context store/*ctx*))
+  ([ctx]
+   (when-not (:sci.impl/world ctx)
+     (throw (ex-info "No managed SCI context is active"
+                     {:type ::no-active-context})))
+   (let [source-scope (execution/binding-scope)
+         target-scope (:sci.impl/world ctx)]
+     ;; A suspension is a value snapshot, not an alias onto the evaluation's
+     ;; still-live binding boxes. Clone immediately; the source form may finish
+     ;; unwinding (or a host callback may choose a target later) before resume.
+     ;; An interpreted function invoked directly by its host has no ctx-store
+     ;; binding and therefore a nil binding scope; normalize that frame onto the
+     ;; explicit interpreter world supplied by the embedding boundary.
+     (->ContinuationContext
+      ctx
+      (retarget-binding-frame (get-thread-binding-frame)
+                              source-scope target-scope)))))
+
+(defn- clone-binding-map
+  [bindings box-cache]
+  (when bindings
+    (persistent!
+     (reduce-kv
+      (fn [ret var* box]
+        (let [forked-box
+              (if-let [entry (find @box-cache box)]
+                (val entry)
+                (let [copy (TBox. #?(:cljd nil
+                                     :clj (Thread/currentThread)
+                                     :cljs nil)
+                                  (t/getVal box))]
+                  (vswap! box-cache assoc box copy)
+                  copy))]
+          (assoc! ret var* forked-box)))
+      (transient {})
+      bindings))))
+
+(defn- retarget-binding-frame
+  [frame source-scope target-scope]
+  (let [box-cache (volatile! {})]
+    (letfn [(retarget [^Frame current]
+              (cond
+                (nil? current) nil
+                (identical? current top-frame) top-frame
+                :else
+                (Frame. (clone-binding-map (.-bindings current) box-cache)
+                        (retarget (.-prev current))
+                        (if (identical? source-scope (.-scope current))
+                          target-scope
+                          (.-scope current))
+                        (clone-binding-map (.-prior-bindings current)
+                                           box-cache))))]
+      (retarget frame))))
+
+(defn retarget-continuation-context
+  "Return an independent continuation context selecting `target-ctx`.
+
+  The target must be a fork in the captured context's lineage. Dynamic binding
+  boxes are copied, with aliases preserved inside the copied frame chain, and
+  binding scopes owned by the source world are moved to the target world."
+  [{source-ctx :ctx frame :frame} target-ctx]
+  (when-not (and (:sci.impl/world target-ctx)
+                 (identical? (:sci.impl/lineage source-ctx)
+                             (:sci.impl/lineage target-ctx)))
+    (throw (ex-info "Cannot retarget a continuation to an unrelated SCI context"
+                    {:type ::unrelated-context})))
+  (->ContinuationContext
+   target-ctx
+   (retarget-binding-frame frame
+                           (:sci.impl/world source-ctx)
+                           (:sci.impl/world target-ctx))))
+
 (defn reset-thread-binding-frame [frame]
   (let [state #?(:clj (.get ^ThreadLocal execution/current)
                  :default (execution/current-state))
@@ -212,6 +296,11 @@
       ([x y z & args]
        (invoke (list* x y z args))))))
 
+(defn continuation-context-fn
+  "Wrap `f` so every invocation restores a captured continuation context."
+  [{:keys [ctx frame]} f]
+  (binding-frame-fn frame ctx f))
+
 (defn binding-conveyor-fn
   "Convey the current binding values to an independent task. The shallow
   frame deliberately cannot pop scopes owned by the submitting execution."

test/sci/vars_test.cljc

@@ -209,6 +209,155 @@
                           (sci/with-bindings {1 1}
                             (sci/eval-string "*x*" {:bindings {'*x* 1}}))))))
 
+(deftest forked-continuation-context-test
+  (let [captured (atom nil)
+        parent (sci/init
+                {:bindings
+                 {'capture-continuation-context!
+                  #(reset! captured (sci/capture-continuation-context))}})]
+    (sci/eval-string*
+     parent
+     "(def state (atom 0))
+      (def ^:dynamic *outer* :root)
+      (def ^:dynamic *inner* :root)
+      (defn resume! [tag]
+        (let [before [*outer* *inner*]
+              _ (set! *inner* tag)]
+          [before [*outer* *inner*] (swap! state inc)]))
+      (defn unwind! []
+        (let [inner *inner*]
+          (pop-thread-bindings)
+          [inner *outer* *inner*]))
+      (binding [*outer* :outer]
+        (binding [*inner* :inner]
+          (capture-continuation-context!)))")
+    (let [child (sci/fork parent)
+          sibling (sci/fork parent)
+          child-context
+          (sci/retarget-continuation-context @captured child)
+          sibling-context
+          (sci/retarget-continuation-context @captured sibling)
+          parent-resume
+          (sci/continuation-context-fn
+           @captured
+           (sci/eval-string* parent "resume!"))
+          child-resume
+          (sci/continuation-context-fn
+           child-context
+           (sci/eval-string* child "resume!"))
+          sibling-resume
+          (sci/continuation-context-fn
+           sibling-context
+           (sci/eval-string* sibling "resume!"))
+          child-unwind
+          (sci/continuation-context-fn
+           child-context
+           (sci/eval-string* child "unwind!"))]
+      (is (= [[:outer :inner] [:outer :parent] 1]
+             (parent-resume :parent)))
+      (is (= [[:outer :inner] [:outer :child] 1]
+             (child-resume :child)))
+      (is (= [[:outer :inner] [:outer :sibling] 1]
+             (sibling-resume :sibling)))
+      ;; The child capsule retains its own prior `set!`, then unwinds exactly
+      ;; one nested binding frame without touching parent or sibling boxes.
+      (is (= [:child :outer :root] (child-unwind)))
+      (is (= 1 (sci/eval-string* parent "@state")))
+      (is (= 1 (sci/eval-string* child "@state")))
+      (is (= 1 (sci/eval-string* sibling "@state")))
+      (is (= [:root :root]
+             (sci/eval-string* parent "[*outer* *inner*]")))
+      (is (= [:root :root]
+             (sci/eval-string* child "[*outer* *inner*]"))))))
+
+(deftest continuation-context-rejects-unrelated-lineage-test
+  (let [captured (atom nil)
+        parent (sci/init
+                {:bindings
+                 {'capture-continuation-context!
+                  #(reset! captured (sci/capture-continuation-context))}})
+        unrelated (sci/init {})]
+    (sci/eval-string* parent "(capture-continuation-context!)")
+    (is (thrown-with-msg?
+         #?(:cljd cljd.core/ExceptionInfo :clj Exception :cljs js/Error)
+         #"unrelated SCI context"
+         (sci/retarget-continuation-context @captured unrelated)))))
+
+(deftest continuation-context-captures-binding-values-immediately-test
+  (let [captured (atom nil)
+        parent (sci/init
+                {:bindings
+                 {'capture-continuation-context!
+                  #(reset! captured (sci/capture-continuation-context))}})]
+    (sci/eval-string*
+     parent
+     "(def ^:dynamic *value* :root)
+      (defn capture-and-mutate! []
+        (binding [*value* :captured]
+          (capture-continuation-context!)
+          (set! *value* :after-capture)))")
+    (sci/eval-string* parent "(capture-and-mutate!)")
+    (let [child (sci/fork parent)
+          parent-resume
+          (sci/continuation-context-fn
+           @captured
+           (sci/eval-string* parent "(fn [] *value*)"))
+          child-resume
+          (sci/continuation-context-fn
+           (sci/retarget-continuation-context @captured child)
+           (sci/eval-string* child "(fn [] *value*)"))]
+      (is (= :captured (parent-resume)))
+      (is (= :captured (child-resume)))
+      (is (= :root (sci/eval-string* parent "*value*")))
+      (is (= :root (sci/eval-string* child "*value*"))))))
+
+(deftest explicit-context-captures-host-invoked-interpreted-function-test
+  (let [captured (atom nil)
+        context-holder (atom nil)
+        parent (sci/init
+                {:bindings
+                 {'capture-continuation-context!
+                  #(reset! captured
+                           (sci/capture-continuation-context @context-holder))}})]
+    (reset! context-holder parent)
+    (let [suspend
+          (sci/eval-string*
+           parent
+           "(def ^:dynamic *scope* :root)
+            (fn []
+              (binding [*scope* :host-invoked]
+                (capture-continuation-context!)))")]
+      ;; This interpreted closure runs after eval-string* has returned, which is
+      ;; how an embedding such as Spindel invokes an interpreted Spin body.
+      (suspend)
+      (let [child (sci/fork parent)
+            resume
+            (sci/continuation-context-fn
+             (sci/retarget-continuation-context @captured child)
+             (sci/eval-string* child "(fn [] *scope*)"))]
+        (is (= :host-invoked (resume)))
+        (is (= :root (sci/eval-string* parent "*scope*")))
+        (is (= :root (sci/eval-string* child "*scope*")))))))
+
+#?(:clj
+   (deftest independent-interpreter-can-be-created-recursively-test
+     (let [outer
+           (sci/init
+            {:bindings
+             {'create-inner!
+              #(sci/with-detached-context
+                 (fn []
+                   (let [ctx (sci/init {})]
+                     (sci/eval-string*
+                      ctx
+                      "(ns nested.runtime)
+                       (defmacro answer [] 42)")
+                     (sci/eval-string* ctx "(nested.runtime/answer)"))))}})]
+       (is (= 42
+              (sci/eval-string*
+               outer
+               "(create-inner!)"))))))
+
 (deftest binding-api-test
   (when-not tu/native?
     (let [x (sci/new-dynamic-var 'x)]