with-dynamic-state compiler and VM support

* libguile/dynstack.h (SCM_DYNSTACK_TYPE_DYNAMIC_STATE):
* libguile/dynstack.c (DYNAMIC_STATE_WORDS, DYNAMIC_STATE_STATE_BOX):
  (scm_dynstack_push_dynamic_state):
  (scm_dynstack_unwind_dynamic_state): New definitions.
  (scm_dynstack_unwind_1, scm_dynstack_wind_1): Add with-dynamic-state
  cases.
* libguile/memoize.c (push_dynamic_state, pop_dynamic_state)
  (do_push_dynamic_state, do_pop_dynamic_state): New definitions.
  (memoize, scm_init_memoize): Handle push-dynamic-state and
  pop-dynamic-state.
* libguile/vm-engine.c (push-dynamic-state, pop-dynamic-state): New
  opcodes.
* module/ice-9/boot-9.scm (with-dynamic-state): New definition in Scheme
  so that the push-dynamic-state and pop-dynamic-state always run in the
  VM.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/types.scm:
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/peval.scm (peval):
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
* module/system/vm/assembler.scm: Add support for with-dynamic-state to
  the compiler.
* test-suite/tests/fluids.test ("dynamic states"): Add basic tests.
* doc/ref/vm.texi (Dynamic Environment Instructions): Update.

doc/ref/vm.texi

@@ -1204,6 +1204,18 @@ Set the value of the fluid in @var{dst} to the value in @var{src}.
 Write the value of the current thread to @var{dst}.
 @end deftypefn
 
+@deftypefn Instruction {} push-dynamic-state s24:@var{state}
+Save the current set of fluid bindings on the dynamic stack and instate
+the bindings from @var{state} instead.  @xref{Fluids and Dynamic
+States}.
+@end deftypefn
+
+@deftypefn Instruction {} pop-dynamic-state x24:@var{_}
+Restore a saved set of fluid bindings from the dynamic stack.
+@code{push-dynamic-state} should always be balanced with
+@code{pop-dynamic-state}.
+@end deftypefn
+
 
 @node Miscellaneous Instructions
 @subsubsection Miscellaneous Instructions
@@ -1237,6 +1249,17 @@ Pop the stack pointer by @var{count} words, discarding any values that
 were stored there.
 @end deftypefn
 
+@deftypefn Instruction {} handle-interrupts x24:@var{_}
+Handle pending asynchronous interrupts (asyncs).  @xref{Asyncs}.  The
+compiler inserts @code{handle-interrupts} instructions before any call,
+return, or loop back-edge.
+@end deftypefn
+
+@deftypefn Instruction {} return-from-interrupt x24:@var{_}
+A special instruction to return from a call and also pop off the stack
+frame from the call.  Used when returning from asynchronous interrupts.
+@end deftypefn
+
 
 @node Inlined Scheme Instructions
 @subsubsection Inlined Scheme Instructions

libguile/dynstack.c

@@ -53,6 +53,9 @@
 #define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
 #define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))
 
+#define DYNAMIC_STATE_WORDS 1
+#define DYNAMIC_STATE_STATE_BOX(top) (SCM_PACK ((top)[0]))
+
 
 
 
@@ -230,6 +233,22 @@ dynstack_pop (scm_t_dynstack *dynstack, scm_t_bits **words)
   return tag;
 }
   
+void
+scm_dynstack_push_dynamic_state (scm_t_dynstack *dynstack, SCM state,
+                                 scm_t_dynamic_state *dynamic_state)
+{
+  scm_t_bits *words;
+  SCM state_box;
+
+  if (SCM_UNLIKELY (scm_is_false (scm_dynamic_state_p (state))))
+    scm_wrong_type_arg ("with-dynamic-state", 0, state);
+
+  state_box = scm_make_variable (scm_set_current_dynamic_state (state));
+  words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNAMIC_STATE, 0,
+                               DYNAMIC_STATE_WORDS);
+  words[0] = SCM_UNPACK (state_box);
+}
+
 void
 scm_dynstack_pop (scm_t_dynstack *dynstack)
 {
@@ -305,6 +324,12 @@ scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item)
       scm_call_0 (DYNWIND_ENTER (item));
       break;
 
+    case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
+      scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (item),
+                          scm_set_current_dynamic_state
+                          (scm_variable_ref (DYNAMIC_STATE_STATE_BOX (item))));
+      break;
+
     case SCM_DYNSTACK_TYPE_NONE:
     default:
       abort ();
@@ -362,6 +387,13 @@ scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
       }
       break;
 
+    case SCM_DYNSTACK_TYPE_DYNAMIC_STATE:
+      scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words),
+                          scm_set_current_dynamic_state
+                          (scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words))));
+      clear_scm_t_bits (words, DYNAMIC_STATE_WORDS);
+      break;
+
     case SCM_DYNSTACK_TYPE_NONE:
     default:
       abort ();
@@ -542,6 +574,25 @@ scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack,
   clear_scm_t_bits (words, len);
 }
 
+void
+scm_dynstack_unwind_dynamic_state (scm_t_dynstack *dynstack,
+                                   scm_t_dynamic_state *dynamic_state)
+{
+  scm_t_bits tag, *words;
+  size_t len;
+
+  tag = dynstack_pop (dynstack, &words);
+  len = SCM_DYNSTACK_TAG_LEN (tag);
+
+  assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_DYNAMIC_STATE);
+  assert (len == DYNAMIC_STATE_WORDS);
+
+  scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words),
+                      scm_set_current_dynamic_state
+                      (scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words))));
+  clear_scm_t_bits (words, len);
+}
+
 
 /*
   Local Variables:

libguile/dynstack.h

@@ -81,6 +81,7 @@ typedef enum {
   SCM_DYNSTACK_TYPE_WITH_FLUID,
   SCM_DYNSTACK_TYPE_PROMPT,
   SCM_DYNSTACK_TYPE_DYNWIND,
+  SCM_DYNSTACK_TYPE_DYNAMIC_STATE,
 } scm_t_dynstack_item_type;
 
 #define SCM_DYNSTACK_TAG_TYPE_MASK 0xf
@@ -150,6 +151,8 @@ SCM_INTERNAL void scm_dynstack_push_unwinder (scm_t_dynstack *,
 SCM_INTERNAL void scm_dynstack_push_fluid (
   scm_t_dynstack *, SCM fluid, SCM value,
   scm_t_dynamic_state *dynamic_state);
+SCM_INTERNAL void scm_dynstack_push_dynamic_state (scm_t_dynstack *, SCM,
+                                                   scm_t_dynamic_state *);
 SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *,
                                             scm_t_dynstack_prompt_flags,
                                             SCM key,
@@ -188,6 +191,8 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork (scm_t_dynstack *,
 SCM_INTERNAL void scm_dynstack_unwind_frame (scm_t_dynstack *);
 SCM_INTERNAL void scm_dynstack_unwind_fluid
   (scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state);
+SCM_INTERNAL void scm_dynstack_unwind_dynamic_state
+  (scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state);
 
 SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM,
                                                    scm_t_dynstack_prompt_flags *,

libguile/memoize.c

@@ -68,6 +68,8 @@ static SCM wind;
 static SCM unwind;
 static SCM push_fluid;
 static SCM pop_fluid;
+static SCM push_dynamic_state;
+static SCM pop_dynamic_state;
 
 static SCM
 do_wind (SCM in, SCM out)
@@ -100,6 +102,24 @@ do_pop_fluid (void)
   return SCM_UNSPECIFIED;
 }
 
+static SCM
+do_push_dynamic_state (SCM state)
+{
+  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+  scm_dynstack_push_dynamic_state (&thread->dynstack, state,
+                                   thread->dynamic_state);
+  return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_pop_dynamic_state (void)
+{
+  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+  scm_dynstack_unwind_dynamic_state (&thread->dynstack,
+                                     thread->dynamic_state);
+  return SCM_UNSPECIFIED;
+}
+
 
 
 
@@ -482,6 +502,14 @@ memoize (SCM exp, SCM env)
         else if (nargs == 0
                  && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
           return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
+        else if (nargs == 1
+                 && scm_is_eq (name,
+                               scm_from_latin1_symbol ("push-dynamic-state")))
+          return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args);
+        else if (nargs == 0
+                 && scm_is_eq (name,
+                               scm_from_latin1_symbol ("pop-dynamic-state")))
+          return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL);
         else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
           return MAKMEMO_CALL (maybe_makmemo_capture_module
                                (MAKMEMO_BOX_REF
@@ -869,6 +897,10 @@ scm_init_memoize ()
   unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
   push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
   pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
+  push_dynamic_state = scm_c_make_gsubr ("push-dynamic_state", 1, 0, 0,
+                                         do_push_dynamic_state);
+  pop_dynamic_state = scm_c_make_gsubr ("pop-dynamic_state", 0, 0, 0,
+                                        do_pop_dynamic_state);
 
   list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
 }

libguile/vm-engine.c

@@ -3921,8 +3921,35 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (0);
     }
 
-  VM_DEFINE_OP (185, unused_185, NULL, NOP)
+  /* push-dynamic-state state:24
-  VM_DEFINE_OP (186, unused_186, NULL, NOP)
+   *
+   * Save the current fluid bindings on the dynamic stack, and use STATE
+   * instead.
+   */
+  VM_DEFINE_OP (185, push_dynamic_state, "push-dynamic-state", OP1 (X8_S24))
+    {
+      scm_t_uint32 state;
+
+      UNPACK_24 (op, state);
+
+      SYNC_IP ();
+      scm_dynstack_push_dynamic_state (&thread->dynstack, SP_REF (state),
+                                       thread->dynamic_state);
+      NEXT (1);
+    }
+
+  /* pop-dynamic-state _:24
+   *
+   * Restore the saved fluid bindings from the dynamic stack.
+   */
+  VM_DEFINE_OP (186, pop_dynamic_state, "pop-dynamic-state", OP1 (X32))
+    {
+      SYNC_IP ();
+      scm_dynstack_unwind_dynamic_state (&thread->dynstack,
+                                         thread->dynamic_state);
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (187, unused_187, NULL, NOP)
   VM_DEFINE_OP (188, unused_188, NULL, NOP)
   VM_DEFINE_OP (189, unused_189, NULL, NOP)

module/ice-9/boot-9.scm

@@ -154,6 +154,15 @@ a-cont
       ((@@ primitive pop-fluid))
       (apply values vals))))
 
+(define (with-dynamic-state state thunk)
+  "Call @var{proc} while @var{state} is the current dynamic state object.
+@var{thunk} must be a procedure of no arguments."
+  ((@@ primitive push-dynamic-state) state)
+  (call-with-values thunk
+    (lambda vals
+      ((@@ primitive pop-dynamic-state))
+      (apply values vals))))
+
 
 
 ;;; {Simple Debugging Tools}

module/language/cps/compile-bytecode.scm

@@ -330,6 +330,10 @@
          (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val))))
         (($ $primcall 'pop-fluid ())
          (emit-pop-fluid asm))
+        (($ $primcall 'push-dynamic-state (state))
+         (emit-push-dynamic-state asm (from-sp (slot state))))
+        (($ $primcall 'pop-dynamic-state ())
+         (emit-pop-dynamic-state asm))
         (($ $primcall 'wind (winder unwinder))
          (emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
         (($ $primcall 'bv-u8-set! (bv idx val))

module/language/cps/effects-analysis.scm

@@ -287,7 +287,9 @@ is or might be a read or a write to the same location as A."
   ((fluid-ref f)                   (&read-object &fluid)       &type-check)
   ((fluid-set! f v)                (&write-object &fluid)      &type-check)
   ((push-fluid f v)                (&write-object &fluid)      &type-check)
-  ((pop-fluid)                     (&write-object &fluid)      &type-check))
+  ((pop-fluid)                     (&write-object &fluid))
+  ((push-dynamic-state state)      (&write-object &fluid)      &type-check)
+  ((pop-dynamic-state)             (&write-object &fluid)))
 
 ;; Threads.  Calls cause &all-effects, which reflects the fact that any
 ;; call can capture a partial continuation and reinstate it on another

module/language/cps/types.scm

@@ -558,7 +558,9 @@ minimum, and maximum."
   ((fluid-ref (&fluid 1)) &all-types)
   ((fluid-set! (&fluid 0 1) &all-types))
   ((push-fluid (&fluid 0 1) &all-types))
-  ((pop-fluid)))
+  ((pop-fluid))
+  ((push-dynamic-state &all-types))
+  ((pop-dynamic-state)))
 
 
 

module/language/tree-il/effects.scm

@@ -360,6 +360,14 @@ of an expression."
           (($ <primcall> _ 'pop-fluid ())
            (logior (cause &fluid)))
 
+          (($ <primcall> _ 'push-dynamic-state (state))
+           (logior (compute-effects state)
+                   (cause &type-check)
+                   (cause &fluid)))
+
+          (($ <primcall> _ 'pop-dynamic-state ())
+           (logior (cause &fluid)))
+
           (($ <primcall> _ 'car (x))
            (logior (compute-effects x)
                    (cause &type-check)

module/language/tree-il/peval.scm

@@ -1219,6 +1219,19 @@ top-level bindings from ENV and return the resulting expression."
                                   (make-call src thunk '())
                                   (make-primcall src 'pop-fluid '()))))))))
 
+      (($ <primcall> src 'with-dynamic-state (state thunk))
+       (for-tail
+        (with-temporaries
+         src (list state thunk) 1 constant-expression?
+         (match-lambda
+          ((state thunk)
+           (make-seq src
+                     (make-primcall src 'push-dynamic-state (list state))
+                     (make-begin0 src
+                                  (make-call src thunk '())
+                                  (make-primcall src 'pop-dynamic-state
+                                                 '()))))))))
+
       (($ <primcall> src 'values exps)
        (cond
         ((null? exps)

module/language/tree-il/primitives.scm

@@ -84,7 +84,7 @@
 
     current-module define!
 
-    current-thread fluid-ref fluid-set! with-fluid*
+    current-thread fluid-ref fluid-set! with-fluid* with-dynamic-state
 
     call-with-prompt
     abort-to-prompt* abort-to-prompt

module/system/vm/assembler.scm

@@ -122,6 +122,8 @@
             emit-unwind
             emit-push-fluid
             emit-pop-fluid
+            emit-push-dynamic-state
+            emit-pop-dynamic-state
             emit-current-thread
             emit-fluid-ref
             emit-fluid-set!

test-suite/tests/fluids.test

@@ -184,3 +184,80 @@
       (catch #t
              (lambda () (fluid-ref fluid))
              (lambda (key . args) #t)))))
+
+(with-test-prefix "dynamic states"
+  (pass-if "basics"
+    (dynamic-state? (current-dynamic-state)))
+
+  (pass-if "with a fluid (basic)"
+    (let ((fluid (make-fluid #f))
+          (state (current-dynamic-state)))
+      (with-dynamic-state
+       state
+       (lambda ()
+         (eqv? (fluid-ref fluid) #f)))))
+
+  (pass-if "with a fluid (set outer)"
+    (let ((fluid (make-fluid #f))
+          (state (current-dynamic-state)))
+      (fluid-set! fluid #t)
+      (and (with-dynamic-state
+            state
+            (lambda ()
+              (eqv? (fluid-ref fluid) #f)))
+           (eqv? (fluid-ref fluid) #t))))
+
+  (pass-if "with a fluid (set inner)"
+    (let ((fluid (make-fluid #f))
+          (state (current-dynamic-state)))
+      (and (with-dynamic-state
+            state
+            (lambda ()
+              (fluid-set! fluid #t)
+              (eqv? (fluid-ref fluid) #t)))
+           (eqv? (fluid-ref fluid) #f))))
+
+  (pass-if "dynstate captured (1)"
+    (let ((fluid (make-fluid #f))
+          (state (current-dynamic-state))
+          (tag (make-prompt-tag "hey")))
+      (let ((k (call-with-prompt tag
+                 (lambda ()
+                   (with-dynamic-state
+                    state
+                    (lambda ()
+                      (abort-to-prompt tag)
+                      (fluid-ref fluid))))
+                 (lambda (k) k))))
+        (eqv? (k) #f))))
+
+  (pass-if "dynstate captured (2)"
+    (let ((fluid (make-fluid #f))
+          (state (current-dynamic-state))
+          (tag (make-prompt-tag "hey")))
+      (let ((k (call-with-prompt tag
+                 (lambda ()
+                   (with-dynamic-state
+                    state
+                    (lambda ()
+                      (abort-to-prompt tag)
+                      (fluid-ref fluid))))
+                 (lambda (k) k))))
+        (fluid-set! fluid #t)
+        (eqv? (k) #f))))
+
+  (pass-if "dynstate captured (3)"
+    (let ((fluid (make-fluid #f))
+          (state (current-dynamic-state))
+          (tag (make-prompt-tag "hey")))
+      (let ((k (call-with-prompt tag
+                 (lambda ()
+                   (with-dynamic-state
+                    state
+                    (lambda ()
+                      (fluid-set! fluid #t)
+                      (abort-to-prompt tag)
+                      (fluid-ref fluid))))
+                 (lambda (k) k))))
+        (and (eqv? (fluid-ref fluid) #f)
+             (eqv? (k) #t))))))