summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/vm-engine.c9
-rw-r--r--libguile/vm-i-system.c134
-rw-r--r--module/language/scheme/translate.scm6
-rw-r--r--module/system/il/compile.scm11
-rw-r--r--module/system/il/ghil.scm6
5 files changed, 161 insertions, 5 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index def7e807b..14f444c58 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -100,9 +100,9 @@ vm_run (SCM vm, SCM program, SCM args)
SCM prog = program;
/* Boot program */
- scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
+ scm_byte_t bytes[5] = {scm_op_mv_call, 0, 1, scm_op_make_int8_1, scm_op_halt};
bytes[1] = scm_ilength (args); /* FIXME: argument overflow */
- program = scm_c_make_program (bytes, 3, SCM_BOOL_F);
+ program = scm_c_make_program (bytes, 5, SCM_BOOL_F);
/* Initial frame */
CACHE_REGISTER ();
@@ -166,6 +166,11 @@ vm_run (SCM vm, SCM program, SCM args)
err_args = SCM_EOL;
goto vm_error;
+ vm_error_no_values:
+ err_msg = scm_from_locale_string ("VM: 0-valued return");
+ err_args = SCM_EOL;
+ goto vm_error;
+
#if VM_CHECK_IP
vm_error_invalid_address:
err_msg = scm_from_locale_string ("VM: Invalid program address");
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 86e65787b..4e9ec4263 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -55,9 +55,19 @@ VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
{
SCM ret;
+ int nvalues;
vp->time += scm_c_get_internal_run_time () - start_time;
HALT_HOOK ();
- POP (ret);
+ nvalues = SCM_I_INUM (*sp--);
+ if (nvalues == 1)
+ POP (ret);
+ else
+ {
+ POP_LIST (nvalues);
+ POP (ret);
+ ret = scm_values (ret);
+ }
+
{
#ifdef THE_GOVERNMENT_IS_AFTER_ME
if (sp != stack_base)
@@ -692,6 +702,68 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
+VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 2, -1, 1)
+{
+ SCM x;
+ int offset;
+
+ nargs = FETCH ();
+ offset = FETCH ();
+
+ x = sp[-nargs];
+
+ /*
+ * Subprogram call
+ */
+ if (SCM_PROGRAM_P (x))
+ {
+ program = x;
+ CACHE_PROGRAM ();
+ INIT_ARGS ();
+ NEW_FRAME ();
+ SCM_FRAME_DATA_ADDRESS (fp)[3] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
+ ENTER_HOOK ();
+ APPLY_HOOK ();
+ NEXT;
+ }
+ /*
+ * Other interpreted or compiled call
+ */
+ if (!SCM_FALSEP (scm_procedure_p (x)))
+ {
+ /* At this point, the stack contains the procedure and each one of its
+ arguments. */
+ SCM args;
+ POP_LIST (nargs);
+ POP (args);
+ SYNC_REGISTER ();
+ *sp = scm_apply (x, args, SCM_EOL);
+ if (SCM_VALUESP (*sp))
+ {
+ SCM values, len;
+ POP (values);
+ values = scm_struct_ref (values, SCM_INUM0);
+ len = scm_length (values);
+ while (!SCM_NULLP (values))
+ PUSH (SCM_CAR (values));
+ PUSH (len);
+ ip += offset;
+ }
+ NEXT;
+ }
+ /*
+ * Continuation call
+ */
+ if (SCM_VM_CONT_P (x))
+ {
+ program = x;
+ goto vm_call_continuation;
+ }
+
+ program = x;
+ goto vm_error_wrong_type_apply;
+}
+
VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
{
int len;
@@ -785,6 +857,66 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
+{
+ EXIT_HOOK ();
+ RETURN_HOOK ();
+ {
+ int nvalues = FETCH ();
+ SCM *data = SCM_FRAME_DATA_ADDRESS (fp);
+#ifdef THE_GOVERNMENT_IS_AFTER_ME
+ if (stack_base != data + 4)
+ abort ();
+#endif
+
+ /* data[3] is the mv return address */
+ if (nvalues != 1 && data[3])
+ {
+ int i;
+ /* Restore registers */
+ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
+ ip = SCM_FRAME_BYTE_CAST (data[3]); /* multiple value ra */
+ fp = SCM_FRAME_STACK_CAST (data[2]);
+
+ /* Push return values, and the number of values */
+ for (i = 0; i < nvalues; i++)
+ *++sp = stack_base[1+i];
+ *++sp = SCM_I_MAKINUM (nvalues);
+
+ /* Finally set new stack_base */
+ stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ }
+ else if (nvalues >= 1)
+ {
+ /* Multiple values for a single-valued continuation -- here's where I
+ break with guile tradition and try and do something sensible. (Also,
+ this block handles the single-valued return to an mv
+ continuation.) */
+ /* Restore registers */
+ sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
+ ip = SCM_FRAME_BYTE_CAST (data[4]); /* single value ra */
+ fp = SCM_FRAME_STACK_CAST (data[2]);
+
+ /* Push first value */
+ *++sp = stack_base[1];
+
+ /* Finally set new stack_base */
+ stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ }
+ else
+ goto vm_error_no_values;
+
+
+ }
+
+ /* Restore the last program */
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ CACHE_EXTERNAL ();
+ CHECK_IP ();
+ NEXT;
+}
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 493ce819d..294690096 100644
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -300,7 +300,11 @@
;; FIXME: make this actually do something
(start-stack
- ((,tag ,expr) (retrans expr)))))
+ ((,tag ,expr) (retrans expr)))
+
+ (values
+ ((,x) (retrans x))
+ (,args (make-ghil-values e l (map retrans args))))))
(define (trans-quasiquote e l x level)
(cond ((not (pair? x)) x)
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index ffc51810a..66d566b33 100644
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -301,6 +301,17 @@
(maybe-drop)
(maybe-return))
+ ((<ghil-values> env loc values)
+ (cond (tail ;; (lambda () (values 1 2))
+ (push-call! loc 'return/values values))
+ (drop ;; (lambda () (values 1 2) 3)
+ (for-each comp-drop values))
+ (else ;; (lambda () (list (values 10 12) 1))
+ (push-code! #f (make-glil-const #:obj 'values))
+ (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
+ (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
+ (push-call! loc 'call values))))
+
((<ghil-call> env loc proc args)
;; PROC
;; ARGS...
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 2a031094c..ae42d4f41 100644
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -72,6 +72,9 @@
<ghil-call> make-ghil-call ghil-call?
ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
+ <ghil-values> make-ghil-values ghil-values?
+ ghil-values-env ghil-values-loc ghil-values-values
+
<ghil-var> make-ghil-var ghil-var?
ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value
ghil-var-index
@@ -110,7 +113,8 @@
(<ghil-bind> env loc vars vals body)
(<ghil-lambda> env loc vars rest meta body)
(<ghil-call> env loc proc args)
- (<ghil-inline> env loc inline args)))
+ (<ghil-inline> env loc inline args)
+ (<ghil-values> env loc values)))
;;;