compile call/cc, yee ha

* libguile/vm-i-system.c (call, goto/args): Add a FIXME for handling the
  case in which a call to the interpreter returns a values object.
  (call/cc, goto/cc): Flesh out, and handle full continuations (with the
  C stack also).

* module/language/scheme/translate.scm (custom-transformer-table):
  Compile call-with-current-continuation. This is necessary so that the
  called procedure is called in tail position.

* module/system/il/compile.scm (codegen): Translate apply to goto/apply,
  call/cc to goto/cc, etc when in tail position.

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 21d0d08..f2d8b65 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -524,6 +524,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
       POP (args);
       SYNC_REGISTER ();
       *sp = scm_apply (x, args, SCM_EOL);
+      /* FIXME what if SCM_VALUESP(*sp) */
       NEXT;
     }
   /*
@@ -694,6 +695,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
       POP (args);
       SYNC_REGISTER ();
       *sp = scm_apply (x, args, SCM_EOL);
+      /* FIXME what if SCM_VALUESP(*sp) */
       goto vm_return;
     }
 
@@ -830,20 +832,67 @@ VM_DEFINE_INSTRUCTION (goto_apply, "goto/apply", 1, -1, 1)
   goto vm_goto_args;
 }
 
-VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
+VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 0, 1, 1)
 {
-  SYNC_BEFORE_GC ();
-  PUSH (capture_vm_cont (vp));
-  nargs = 1;
-  goto vm_call;
+  int first;
+  SCM proc, cont;
+  POP (proc);
+  SYNC_ALL ();
+  cont = scm_make_continuation (&first);
+  if (first) 
+    {
+      PUSH (proc);
+      PUSH (cont);
+      nargs = 1;
+      goto vm_call;
+    }
+  else if (SCM_VALUESP (cont))
+    {
+      /* multiple values returned to continuation */
+      SCM values;
+      values = scm_struct_ref (cont, SCM_INUM0);
+      if (SCM_NULLP (values))
+        goto vm_error_wrong_num_args;
+      /* non-tail context does not accept multiple values? */
+      PUSH (SCM_CAR (values));
+      NEXT;
+    }
+  else
+    {
+      PUSH (cont);
+      NEXT;
+    }
 }
 
-VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 1, 1, 1)
+VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 0, 1, 1)
 {
-  SYNC_BEFORE_GC ();
-  PUSH (capture_vm_cont (vp));
-  nargs = 1;
-  goto vm_goto_args;
+  int first;
+  SCM proc, cont;
+  POP (proc);
+  SYNC_ALL ();
+  cont = scm_make_continuation (&first);
+  if (first) 
+    {
+      PUSH (proc);
+      PUSH (cont);
+      nargs = 1;
+      goto vm_goto_args;
+    }
+  else if (SCM_VALUESP (cont))
+    {
+      /* multiple values returned to continuation */
+      SCM values;
+      values = scm_struct_ref (cont, SCM_INUM0);
+      nvalues = scm_ilength (values);
+      while (!SCM_NULLP (values))
+        PUSH (SCM_CAR (values));
+      goto vm_return_values;
+    }
+  else
+    {
+      PUSH (cont);
+      goto vm_return;
+    }
 }
 
 VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)

diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 5669e04..49f9058 100644 (file)
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -331,6 +331,17 @@
      ((,producer ,consumer)
       (make-ghil-mv-call e l (retrans producer) (retrans consumer))))
 
+    ;; FIXME: not hygienic, relies on @call-with-current-continuation
+    ;; not being shadowed
+    (call-with-current-continuation
+     ((,proc)
+      (retrans `(@call-with-current-continuation ,proc)))
+     (else #f))
+
+    (@call-with-current-continuation
+     ((,proc)
+      (make-ghil-inline e l 'call/cc (list (retrans proc)))))
+
     (receive
      ((,formals ,producer-exp . ,body)
       ;; Lovely, self-referential usage. Not strictly necessary, the

diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index 21adbdd..fee5bd5 100644 (file)
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -331,10 +331,16 @@
        ((<ghil-inline> env loc inline args)
         ;; ARGS...
         ;; (INST NARGS)
-         ;; FIXME: translate between call and goto/args, etc
-        (push-call! loc inline args)
-        (maybe-drop)
-        (maybe-return))
+         (let ((tail-table '((call . goto/args)
+                             (apply . goto/apply)
+                             (call/cc . goto/cc))))
+           (cond ((and tail (assq-ref tail-table inline))
+                  => (lambda (tail-inst)
+                       (push-call! loc tail-inst args)))
+                 (else
+                  (push-call! loc inline args)
+                  (maybe-drop)
+                  (maybe-return)))))
 
         ((<ghil-values> env loc values)
          (cond (tail ;; (lambda () (values 1 2))