push and pop dynamic state via intrinsics

* libguile/intrinsics.c (push_dynamic_state, pop_dynamic_state): New
  intrinsics.
  (scm_bootstrap_intrinsics): Add new intrinsics.
* libguile/intrinsics.h: Declare new intrinsics.
* libguile/vm-engine.c (call-thread-scm): New intrinsic caller.
  (push-dynamic-state, pop-dynamic-state): Disable.
* module/language/cps/reify-primitives.scm (compute-known-primitives):
  Add new intrinsics.
* module/system/vm/assembler.scm (push-dynamic-state)
  (pop-dynamic-state): Emit as intrinsics.

libguile/intrinsics.c

@@ -148,6 +148,20 @@ fluid_set_x (scm_i_thread *thread, SCM fluid, SCM value)
     scm_fluid_set_x (fluid, value);
 }
 
+static void
+push_dynamic_state (scm_i_thread *thread, SCM state)
+{
+  scm_dynstack_push_dynamic_state (&thread->dynstack, state,
+                                   thread->dynamic_state);
+}
+
+static void
+pop_dynamic_state (scm_i_thread *thread)
+{
+  scm_dynstack_unwind_dynamic_state (&thread->dynstack,
+                                     thread->dynamic_state);
+}
+
 void
 scm_bootstrap_intrinsics (void)
 {
@@ -181,6 +195,8 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.pop_fluid = pop_fluid;
   scm_vm_intrinsics.fluid_ref = fluid_ref;
   scm_vm_intrinsics.fluid_set_x = fluid_set_x;
+  scm_vm_intrinsics.push_dynamic_state = push_dynamic_state;
+  scm_vm_intrinsics.pop_dynamic_state = pop_dynamic_state;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",

libguile/intrinsics.h

@@ -32,8 +32,9 @@ typedef scm_t_uint64 (*scm_t_u64_from_scm_intrinsic) (SCM);
 typedef scm_t_int64 (*scm_t_s64_from_scm_intrinsic) (SCM);
 typedef SCM (*scm_t_scm_from_u64_intrinsic) (scm_t_uint64);
 typedef SCM (*scm_t_scm_from_s64_intrinsic) (scm_t_int64);
-typedef void (*scm_t_thread_scm_scm_intrinsic) (scm_i_thread*, SCM, SCM);
 typedef void (*scm_t_thread_intrinsic) (scm_i_thread*);
+typedef void (*scm_t_thread_scm_intrinsic) (scm_i_thread*, SCM);
+typedef void (*scm_t_thread_scm_scm_intrinsic) (scm_i_thread*, SCM, SCM);
 typedef SCM (*scm_t_scm_from_thread_scm_intrinsic) (scm_i_thread*, SCM);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
@@ -67,6 +68,8 @@ typedef SCM (*scm_t_scm_from_thread_scm_intrinsic) (scm_i_thread*, SCM);
   M(thread, pop_fluid, "pop-fluid", POP_FLUID) \
   M(scm_from_thread_scm, fluid_ref, "fluid-ref", FLUID_REF) \
   M(thread_scm_scm, fluid_set_x, "fluid-set!", FLUID_SET_X) \
+  M(thread_scm, push_dynamic_state, "push-dynamic-state", PUSH_DYNAMIC_STATE) \
+  M(thread, pop_dynamic_state, "pop-dynamic-state", POP_DYNAMIC_STATE) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic

libguile/vm-engine.c

@@ -2271,7 +2271,21 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (2);
     }
 
-  VM_DEFINE_OP (90, unused_90, NULL, NOP)
+  VM_DEFINE_OP (90, call_thread_scm, "call-thread-scm", OP2 (X8_S24, C32))
+    {
+      scm_t_uint32 a;
+      scm_t_thread_scm_intrinsic intrinsic;
+
+      UNPACK_24 (op, a);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      intrinsic (thread, SP_REF (a));
+      CACHE_SP ();
+
+      NEXT (2);
+    }
+
   VM_DEFINE_OP (91, unused_91, NULL, NOP)
   VM_DEFINE_OP (92, unused_92, NULL, NOP)
   VM_DEFINE_OP (93, unused_93, NULL, NOP)
@@ -2808,12 +2822,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (0);
     }
 
-  /* push-dynamic-state state:24
-   *
-   * 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))
+  VM_DEFINE_OP (185, unused_185, NULL, NOP)
     {
       scm_t_uint32 state;
 
@@ -2825,11 +2834,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       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))
+  VM_DEFINE_OP (186, unused_186, NULL, NOP)
     {
       SYNC_IP ();
       scm_dynstack_unwind_dynamic_state (&thread->dynstack,

module/language/cps/reify-primitives.scm

@@ -237,7 +237,8 @@
       cached-toplevel-box
       cached-module-box
       wind unwind
-      push-fluid pop-fluid fluid-ref fluid-set!))
+      push-fluid pop-fluid fluid-ref fluid-set!
+      push-dynamic-state pop-dynamic-state))
   (let ((table (make-hash-table)))
     (for-each
      (match-lambda ((inst . _) (hashq-set! table inst #t)))

module/system/vm/assembler.scm

@@ -218,6 +218,8 @@
             emit-pop-fluid
             emit-fluid-ref
             emit-fluid-set!
+            emit-push-dynamic-state
+            emit-pop-dynamic-state
 
             emit-call
             emit-call-label
@@ -244,8 +246,6 @@
             emit-toplevel-box
             emit-module-box
             emit-prompt
-            emit-push-dynamic-state
-            emit-pop-dynamic-state
             emit-current-thread
             emit-lsh
             emit-rsh
@@ -1321,12 +1321,15 @@ returned instead."
 (define-syntax-rule (define-scm<-s64-intrinsic name)
   (define-macro-assembler (name asm dst src)
     (emit-call-scm<-s64 asm dst src (intrinsic-name->index 'name))))
-(define-syntax-rule (define-thread-scm-scm-intrinsic name)
-  (define-macro-assembler (name asm a b)
-    (emit-call-thread-scm-scm asm a b (intrinsic-name->index 'name))))
 (define-syntax-rule (define-thread-intrinsic name)
   (define-macro-assembler (name asm)
     (emit-call-thread asm (intrinsic-name->index 'name))))
+(define-syntax-rule (define-thread-scm-intrinsic name)
+  (define-macro-assembler (name asm a)
+    (emit-call-thread-scm asm a (intrinsic-name->index 'name))))
+(define-syntax-rule (define-thread-scm-scm-intrinsic name)
+  (define-macro-assembler (name asm a b)
+    (emit-call-thread-scm-scm asm a b (intrinsic-name->index 'name))))
 (define-syntax-rule (define-scm<-thread-scm-intrinsic name)
   (define-macro-assembler (name asm dst src)
     (emit-call-scm<-thread-scm asm dst src (intrinsic-name->index 'name))))
@@ -1361,6 +1364,8 @@ returned instead."
 (define-thread-intrinsic pop-fluid)
 (define-scm<-thread-scm-intrinsic fluid-ref)
 (define-thread-scm-scm-intrinsic fluid-set!)
+(define-thread-scm-intrinsic push-dynamic-state)
+(define-thread-intrinsic pop-dynamic-state)
 
 (define-macro-assembler (begin-program asm label properties)
   (emit-label asm label)