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.

1 files changed, 77 insertions, 0 deletions

diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index ce7e62578..c043d94d3 100644
--- a/test-suite/tests/fluids.test
+++ b/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))))))