[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-97-gea9f4f4

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ea9f4f4b1551b4a82d4726f2833070f1fb3e2cd5

The branch, master has been updated
       via  ea9f4f4b1551b4a82d4726f2833070f1fb3e2cd5 (commit)
      from  864e7d424e077518decbe6fd59cf4cca4037418a (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit ea9f4f4b1551b4a82d4726f2833070f1fb3e2cd5
Author: Andy Wingo <address@hidden>
Date:   Mon Sep 27 21:06:24 2010 +0200

    add call-with-vm; remove thread-vm bits; remove vm-apply; engines settable.
    
    * libguile/vm.h (scm_c_vm_run): Make internal.
    * libguile/vm.c (vm_default_engine): New static global variable.
      (make_vm): Set vp->engine based on
      (scm_vm_apply): Remove in favor of call-with-vm.
      (scm_thread_vm, scm_set_thread_vm_x): Remove these, as they did not
      have a well-defined meaning, and were dangerous to call on other
      threads.
      (scm_the_vm): Reinstate previous definition.
      (symbol_to_vm_engine, vm_engine_to_symbol)
      (vm_has_pending_computation): New helpers.
      (scm_vm_engine, scm_set_vm_engine_x, scm_c_set_vm_engine_x): New
      accessors for VM engines.
      (scm_c_set_default_vm_engine_x, scm_set_default_vm_engine_x): New
      setters for the default VM engine.
      (scm_call_with_vm): New function, applies a procedure to arguments in
      a context in which a given VM is current.
    
    * libguile/eval.c (eval, scm_apply): VM dispatch goes through
      scm_call_with_vm.
    
    * test-suite/tests/control.test ("the-vm"):
    * module/system/vm/coverage.scm (with-code-coverage): Use call-with-vm.
    
    * module/system/vm/vm.scm: Update exports.
    
    * test-suite/vm/run-vm-tests.scm (run-vm-program):
    * test-suite/tests/compiler.test ("current-reader"): Just rely on the
      result of make-program being an applicable.
    
    * test-suite/tests/eval.test ("stack overflow"): Add a note that this
      test does not test what it should.

-----------------------------------------------------------------------

Summary of changes:
 libguile/eval.c                |    6 +-
 libguile/vm.c                  |  255 ++++++++++++++++++++++++++++------------
 libguile/vm.h                  |   13 ++-
 module/system/vm/coverage.scm  |   12 +-
 module/system/vm/vm.scm        |    9 +-
 test-suite/tests/compiler.test |    3 +-
 test-suite/tests/control.test  |   10 +--
 test-suite/tests/eval.test     |    5 +-
 test-suite/vm/run-vm-tests.scm |    2 +-
 9 files changed, 205 insertions(+), 110 deletions(-)

diff --git a/libguile/eval.c b/libguile/eval.c
index 07233aa..21cb550 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -287,7 +287,7 @@ eval (SCM x, SCM env)
           goto loop;
         }
       else
-        return scm_vm_apply (scm_the_vm (), proc, args);
+        return scm_call_with_vm (scm_the_vm (), proc, args);
 
     case SCM_M_CALL:
       /* Evaluate the procedure to be applied.  */
@@ -322,7 +322,7 @@ eval (SCM x, SCM env)
 
         producer = eval (CAR (mx), env);
         proc = eval (CDR (mx), env);  /* proc is the consumer. */
-        v = scm_vm_apply (scm_the_vm (), producer, SCM_EOL);
+        v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
         if (SCM_VALUESP (v))
           args = scm_struct_ref (v, SCM_INUM0);
         else
@@ -824,7 +824,7 @@ scm_apply (SCM proc, SCM arg1, SCM args)
   else
     args = scm_cons_star (arg1, args);
 
-  return scm_vm_apply (scm_the_vm (), proc, args);
+  return scm_call_with_vm (scm_the_vm (), proc, args);
 }
 
 static void
diff --git a/libguile/vm.c b/libguile/vm.c
index 17ad96d..05e1f71 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -36,12 +36,15 @@
 #include "programs.h"
 #include "vm.h"
 
-/* I sometimes use this for debugging. */
-#define vm_puts(OBJ)                           \
-{                                              \
-  scm_display (OBJ, scm_current_error_port ()); \
-  scm_newline (scm_current_error_port ());      \
-}
+static int vm_default_engine = SCM_VM_DEBUG_ENGINE;
+
+/* Unfortunately we can't snarf these: snarfed things are only loaded up from
+   (system vm vm), which might not be loaded before an error happens. */
+static SCM sym_vm_run;
+static SCM sym_vm_error;
+static SCM sym_keyword_argument_error;
+static SCM sym_regular;
+static SCM sym_debug;
 
 /* The VM has a number of internal assertions that shouldn't normally be
    necessary, but might be if you think you found a bug in the VM. */
@@ -340,10 +343,6 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM 
intwinds,
  * VM Internal functions
  */
 
-/* Unfortunately we can't snarf these: snarfed things are only loaded up from
-   (system vm vm), which might not be loaded before an error happens. */
-static SCM sym_vm_run, sym_vm_error, sym_keyword_argument_error, sym_debug;
-
 void
 scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
 {
@@ -517,7 +516,7 @@ make_vm (void)
   vp->ip         = NULL;
   vp->sp         = vp->stack_base - 1;
   vp->fp         = NULL;
-  vp->engine      = SCM_VM_DEBUG_ENGINE;
+  vp->engine      = vm_default_engine;
   vp->trace_level = 0;
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
     vp->hooks[i] = SCM_BOOL_F;
@@ -564,80 +563,19 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
   return vm_engines[vp->engine](vm, program, argv, nargs);
 }
 
-SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
-            (SCM vm, SCM program, SCM args),
-            "")
-#define FUNC_NAME s_scm_vm_apply
-{
-  SCM *argv;
-  int i, nargs;
-  
-  SCM_VALIDATE_VM (1, vm);
-  SCM_VALIDATE_PROC (2, program);
-
-  nargs = scm_ilength (args);
-  if (SCM_UNLIKELY (nargs < 0))
-    scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
-  
-  argv = alloca(nargs * sizeof(SCM));
-  for (i = 0; i < nargs; i++)
-    {
-      argv[i] = SCM_CAR (args);
-      args = SCM_CDR (args);
-    }
-
-  return scm_c_vm_run (vm, program, argv, nargs);
-}
-#undef FUNC_NAME
-
 /* Scheme interface */
 
-/* Return T's VM.  */
-static inline SCM
-thread_vm (scm_i_thread *t)
-{
-  if (SCM_UNLIKELY (scm_is_false (t->vm)))
-    t->vm = make_vm ();
-
-  return t->vm;
-}
-
-SCM_DEFINE (scm_thread_vm, "thread-vm", 1, 0, 0,
-           (SCM thread),
-           "Return @var{thread}'s VM.")
-#define FUNC_NAME s_scm_thread_vm
-{
-  SCM_VALIDATE_THREAD (1, thread);
-
-  return thread_vm (SCM_I_THREAD_DATA (thread));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_set_thread_vm_x, "set-thread-vm!", 2, 0, 0,
-           (SCM thread, SCM vm),
-           "Set @var{thread}'s VM to @var{vm}.  Warning: Code being\n"
-           "executed by @var{thread}'s current VM won't automatically\n"
-           "switch to @var{vm}.")
-#define FUNC_NAME s_scm_set_thread_vm_x
-{
-  scm_i_thread *t;
-
-  SCM_VALIDATE_THREAD (1, thread);
-  SCM_VALIDATE_VM (2, vm);
-
-  t = SCM_I_THREAD_DATA (thread);
-  t->vm = vm;
-
-  return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
            (void),
            "Return the current thread's VM.")
 #define FUNC_NAME s_scm_the_vm
 {
-  return thread_vm (SCM_I_CURRENT_THREAD);
+  scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+  if (SCM_UNLIKELY (scm_is_false (t->vm)))
+    t->vm = make_vm ();
+
+  return t->vm;
 }
 #undef FUNC_NAME
 
@@ -777,6 +715,166 @@ SCM_DEFINE (scm_set_vm_trace_level_x, 
"set-vm-trace-level!", 2, 0, 0,
 
 
 /*
+ * VM engines
+ */
+
+static int
+symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
+{
+  if (scm_is_eq (engine, sym_regular))
+    return SCM_VM_REGULAR_ENGINE;
+  else if (scm_is_eq (engine, sym_debug))
+    return SCM_VM_DEBUG_ENGINE;
+  else
+    SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
+}
+  
+static SCM
+vm_engine_to_symbol (int engine, const char *FUNC_NAME)
+{
+  switch (engine)
+    {
+    case SCM_VM_REGULAR_ENGINE:
+      return sym_regular;
+    case SCM_VM_DEBUG_ENGINE:
+      return sym_debug;
+    default:
+      /* ? */
+      SCM_MISC_ERROR ("Unknown VM engine: ~a",
+                      scm_list_1 (scm_from_int (engine)));
+    }
+}
+  
+static int
+vm_has_pending_computation (SCM vm)
+{
+  struct scm_vm *vp = SCM_VM_DATA (vm);
+  return vp->sp >= vp->stack_base;
+}
+
+SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
+           (SCM vm),
+           "")
+#define FUNC_NAME s_scm_vm_engine
+{
+  SCM_VALIDATE_VM (1, vm);
+  return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
+}
+#undef FUNC_NAME
+
+void
+scm_c_set_vm_engine_x (SCM vm, int engine)
+#define FUNC_NAME "set-vm-engine!"
+{
+  SCM_VALIDATE_VM (1, vm);
+
+  if (vm_has_pending_computation (vm))
+    SCM_MISC_ERROR ("VM engine may only be changed while there are no "
+                    "pending computations.",
+                    SCM_EOL);
+
+  if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
+    SCM_MISC_ERROR ("Unknown VM engine: ~a",
+                    scm_list_1 (scm_from_int (engine)));
+    
+  SCM_VM_DATA (vm)->engine = engine;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
+           (SCM vm, SCM engine),
+           "")
+#define FUNC_NAME s_scm_set_vm_engine_x
+{
+  scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_c_set_default_vm_engine_x (int engine)
+#define FUNC_NAME "set-default-vm-engine!"
+{
+  if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
+    SCM_MISC_ERROR ("Unknown VM engine: ~a",
+                    scm_list_1 (scm_from_int (engine)));
+    
+  vm_default_engine = engine;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
+           (SCM engine),
+           "")
+#define FUNC_NAME s_scm_set_default_vm_engine_x
+{
+  scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void reinstate_vm (SCM vm)
+{
+  scm_i_thread *t = SCM_I_CURRENT_THREAD;
+  t->vm = vm;
+}
+
+SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
+           (SCM vm, SCM proc, SCM args),
+           "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
+            "@var{vm} is the current VM.\n\n"
+            "As an implementation restriction, if @var{vm} is not the same\n"
+            "as the current thread's VM, continuations captured within the\n"
+            "call to @var{proc} may not be reinstated once control leaves\n"
+            "@var{proc}.")
+#define FUNC_NAME s_scm_call_with_vm
+{
+  SCM prev_vm, ret;
+  SCM *argv;
+  int i, nargs;
+  scm_t_wind_flags flags;
+  scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+  SCM_VALIDATE_VM (1, vm);
+  SCM_VALIDATE_PROC (2, proc);
+
+  nargs = scm_ilength (args);
+  if (SCM_UNLIKELY (nargs < 0))
+    scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
+  
+  argv = alloca (nargs * sizeof(SCM));
+  for (i = 0; i < nargs; i++)
+    {
+      argv[i] = SCM_CAR (args);
+      args = SCM_CDR (args);
+    }
+
+  prev_vm = t->vm;
+
+  /* Reentry can happen via invokation of a saved continuation, but
+     continuations only save the state of the VM that they are in at
+     capture-time, which might be different from this one.  So, in the
+     case that the VMs are different, set up a non-rewindable frame to
+     prevent reinstating an incomplete continuation.  */
+  flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
+  if (flags)
+    {
+      scm_dynwind_begin (0);
+      scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
+      t->vm = vm;
+    }
+
+  ret = scm_c_vm_run (vm, proc, argv, nargs);
+
+  if (flags)
+    scm_dynwind_end ();
+  
+  return ret;
+}
+#undef FUNC_NAME
+
+
+/*
  * Initialize
  */
 
@@ -798,6 +896,7 @@ scm_bootstrap_vm (void)
   sym_vm_run = scm_from_locale_symbol ("vm-run");
   sym_vm_error = scm_from_locale_symbol ("vm-error");
   sym_keyword_argument_error = scm_from_locale_symbol 
("keyword-argument-error");
+  sym_regular = scm_from_locale_symbol ("regular");
   sym_debug = scm_from_locale_symbol ("debug");
 
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
diff --git a/libguile/vm.h b/libguile/vm.h
index 36dc1dc..bb7a7df 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -61,12 +61,10 @@ SCM_API SCM scm_the_vm_fluid;
 
 SCM_API SCM scm_the_vm ();
 SCM_API SCM scm_make_vm (void);
-SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
-SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
 
-SCM_API SCM scm_thread_vm (SCM t);
-SCM_API SCM scm_set_thread_vm_x (SCM t, SCM vm);
 SCM_API SCM scm_the_vm (void);
+SCM_API SCM scm_call_with_vm (SCM vm, SCM proc, SCM args);
+
 SCM_API SCM scm_vm_p (SCM obj);
 SCM_API SCM scm_vm_ip (SCM vm);
 SCM_API SCM scm_vm_sp (SCM vm);
@@ -79,6 +77,11 @@ SCM_API SCM scm_vm_restore_continuation_hook (SCM vm);
 SCM_API SCM scm_vm_next_hook (SCM vm);
 SCM_API SCM scm_vm_trace_level (SCM vm);
 SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
+SCM_API SCM scm_vm_engine (SCM vm);
+SCM_API SCM scm_set_vm_engine_x (SCM vm, SCM engine);
+SCM_API SCM scm_set_default_vm_engine_x (SCM engine);
+SCM_API void scm_c_set_vm_engine_x (SCM vm, int engine);
+SCM_API void scm_c_set_default_vm_engine_x (int engine);
 
 #define SCM_F_VM_CONT_PARTIAL 0x1
 #define SCM_F_VM_CONT_REWINDABLE 0x2
@@ -100,6 +103,8 @@ struct scm_vm_cont {
 
 SCM_API SCM scm_load_compiled_with_vm (SCM file);
 
+SCM_INTERNAL SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+
 SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
                                   scm_print_state *pstate);
 SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index 17e2f40..7554631 100644
--- a/module/system/vm/coverage.scm
+++ b/module/system/vm/coverage.scm
@@ -84,19 +84,19 @@ coverage data.  Return code coverage data and the values 
returned by THUNK."
               (set-cdr! proc-entry (make-hash-table))
               (loop))))))
 
+  ;; FIXME: It's unclear what the dynamic-wind is for, given that if the
+  ;; VM is different from the current one, continuations will not be
+  ;; resumable.
   (call-with-values (lambda ()
                       (let ((level   (vm-trace-level vm))
-                            (hook    (vm-next-hook vm))
-                            (prev-vm (thread-vm (current-thread))))
+                            (hook    (vm-next-hook vm)))
                         (dynamic-wind
                           (lambda ()
                             (set-vm-trace-level! vm (+ level 1))
-                            (add-hook! hook collect!)
-                            (set-thread-vm! (current-thread) vm))
+                            (add-hook! hook collect!))
                           (lambda ()
-                            (vm-apply vm thunk '()))
+                            (call-with-vm vm thunk))
                           (lambda ()
-                            (set-thread-vm! (current-thread) prev-vm)
                             (set-vm-trace-level! vm level)
                             (remove-hook! hook collect!)))))
     (lambda args
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index 874d5c8..0d6f5cc 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -19,13 +19,12 @@
 ;;; Code:
 
 (define-module (system vm vm)
-  #:use-module (system vm frame)
-  #:use-module (system vm program)
-  #:export (vm? make-vm vm-version vm-apply
-            the-vm thread-vm set-thread-vm!
-            vm:ip vm:sp vm:fp vm:last-ip
+  #:export (vm?
+            make-vm the-vm call-with-vm
+            vm:ip vm:sp vm:fp
 
             vm-trace-level set-vm-trace-level!
+            vm-engine set-vm-engine! set-default-vm-engine!
             vm-push-continuation-hook vm-pop-continuation-hook
             vm-apply-hook
             vm-next-hook
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index f600fe2..6b47086 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -19,7 +19,6 @@
   #:use-module (test-suite lib)
   #:use-module (test-suite guile-test)
   #:use-module (system base compile)
-  #:use-module ((system vm vm) #:select (the-vm vm-apply))
   #:use-module ((system vm program) #:select (make-program
                                               program-sources source:addr)))
 
@@ -98,7 +97,7 @@
                      #f)
                    (install-reader!)
                    this-should-be-ignored")))
-      (and (eq? (vm-apply (the-vm) (make-program (read-and-compile input)) '())
+      (and (eq? ((make-program (read-and-compile input)))
                 'ok)
            (eq? r (fluid-ref current-reader)))))
 
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index a4173ff..682c69f 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -238,15 +238,7 @@
                      (p x y))))
       (catch 'foo
         (lambda ()
-          (dynamic-wind
-            (lambda ()
-              (set-thread-vm! (current-thread) new-vm))
-            (lambda ()
-              (vm-apply new-vm
-                        (lambda () (throw 'foo (the-vm)))
-                        '()))
-            (lambda ()
-              (set-thread-vm! (current-thread) prev-vm))))
+          (call-with-vm new-vm (lambda () (throw 'foo (the-vm)))))
         (lambda (key vm)
           (and (eq? key 'foo)
                (eq? vm new-vm)
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 4d37f7b..7eb19eb 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -18,7 +18,7 @@
 (define-module (test-suite test-eval)
   :use-module (test-suite lib)
   :use-module ((srfi srfi-1) :select (unfold count))
-  :use-module ((system vm vm) :select (make-vm vm-apply))
+  :use-module ((system vm vm) :select (make-vm call-with-vm))
   :use-module (ice-9 documentation))
 
 
@@ -439,10 +439,11 @@
 
 (with-test-prefix "stack overflow"
 
+  ;; FIXME: this test does not test what it is intending to test
   (pass-if-exception "exception raised"
     exception:vm-error
     (let ((vm    (make-vm))
           (thunk (let loop () (cons 's (loop)))))
-      (vm-apply vm thunk))))
+      (call-with-vm vm thunk))))
 
 ;;; eval.test ends here
diff --git a/test-suite/vm/run-vm-tests.scm b/test-suite/vm/run-vm-tests.scm
index f699fdf..f23dff6 100644
--- a/test-suite/vm/run-vm-tests.scm
+++ b/test-suite/vm/run-vm-tests.scm
@@ -42,7 +42,7 @@
 
 (define (run-vm-program objcode)
   "Run VM program contained into @var{objcode}."
-  (vm-apply (the-vm) (make-program objcode) '()))
+  ((make-program objcode)))
 
 (define (compile/run-test-from-file file)
   "Run test from source file @var{file} and return a value indicating whether


hooks/post-receive
-- 
GNU Guile