summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/vm-engine.c1
-rw-r--r--libguile/vm-i-system.c105
-rw-r--r--module/language/scheme/translate.scm26
-rw-r--r--module/system/il/compile.scm11
-rw-r--r--module/system/il/ghil.scm16
-rw-r--r--module/system/il/inline.scm9
-rw-r--r--module/system/vm/frame.scm4
7 files changed, 115 insertions, 57 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 14f444c58..48b6ae565 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -65,6 +65,7 @@ vm_run (SCM vm, SCM program, SCM args)
/* Internal variables */
int nargs = 0;
+ int nvalues = 0;
long start_time = scm_c_get_internal_run_time ();
// SCM dynwinds = SCM_EOL;
SCM err_msg;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 4e9ec4263..75642b5ba 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -55,7 +55,6 @@ 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 ();
nvalues = SCM_I_INUM (*sp--);
@@ -859,55 +858,57 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
{
+ /* nvalues declared at top level, because for some reason gcc seems to think
+ that perhaps it might be used without declaration. Fooey to that, I say. */
+ SCM *data;
+
+ nvalues = FETCH ();
+ vm_return_values:
EXIT_HOOK ();
RETURN_HOOK ();
- {
- int nvalues = FETCH ();
- SCM *data = SCM_FRAME_DATA_ADDRESS (fp);
+
+ data = SCM_FRAME_DATA_ADDRESS (fp);
#ifdef THE_GOVERNMENT_IS_AFTER_ME
- if (stack_base != data + 4)
- abort ();
+ 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]);
+ /* 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);
+ /* 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]);
+ /* 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];
+ /* 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;
-
-
- }
+ /* 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);
@@ -917,6 +918,28 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
+{
+ SCM l;
+
+ nvalues = FETCH ();
+#ifdef THE_GOVERNMENT_IS_AFTER_ME
+ if (nvalues < 1)
+ abort ();
+#endif
+
+ nvalues--;
+ POP (l);
+ while (SCM_CONSP (l))
+ {
+ PUSH (SCM_CAR (l));
+ l = SCM_CDR (l);
+ nvalues++;
+ }
+
+ goto vm_return_values;
+}
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 294690096..b812d40ce 100644
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -302,10 +302,36 @@
(start-stack
((,tag ,expr) (retrans expr)))
+ ;; FIXME: not hygienic, relies on @apply not being shadowed
+ (apply
+ (,args (retrans `(@apply ,@args))))
+
+ (@apply
+ ((,proc ,arg1 . ,args)
+ (let ((args (cons (retrans arg1) (map retrans args))))
+ (cond ((and (symbol? proc)
+ (not (ghil-lookup e proc #f))
+ (and=> (module-variable (current-module) proc)
+ (lambda (var)
+ (and (variable-bound? var)
+ (lookup-apply-transformer (variable-ref var))))))
+ ;; that is, a variable, not part of this compilation
+ ;; unit, but defined in the toplevel environment, and has
+ ;; an apply transformer registered
+ => (lambda (t) (t e l args)))
+ (else (make-ghil-inline e l 'apply
+ (cons (retrans proc) args)))))))
+
(values
((,x) (retrans x))
(,args (make-ghil-values e l (map retrans args))))))
+(define (lookup-apply-transformer proc)
+ (cond ((eq? proc values)
+ (lambda (e l args)
+ (make-ghil-values* e l args)))
+ (else #f)))
+
(define (trans-quasiquote e l x level)
(cond ((not (pair? x)) x)
((memq (car x) '(unquote unquote-splicing))
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index 66d566b33..0e410dca1 100644
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -312,6 +312,17 @@
(push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
(push-call! loc 'call values))))
+ ((<ghil-values*> env loc values)
+ (cond (tail ;; (lambda () (apply values '(1 2)))
+ (push-call! loc 'return/values* values))
+ (drop ;; (lambda () (apply values '(1 2)) 3)
+ (for-each comp-drop values))
+ (else ;; (lambda () (list (apply 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 'apply values))))
+
((<ghil-call> env loc proc args)
;; PROC
;; ARGS...
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index ae42d4f41..895d476c7 100644
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -75,6 +75,9 @@
<ghil-values> make-ghil-values ghil-values?
ghil-values-env ghil-values-loc ghil-values-values
+ <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
@@ -114,7 +117,8 @@
(<ghil-lambda> env loc vars rest meta body)
(<ghil-call> env loc proc args)
(<ghil-inline> env loc inline args)
- (<ghil-values> env loc values)))
+ (<ghil-values> env loc values)
+ (<ghil-values*> env loc values)))
;;;
@@ -168,15 +172,17 @@
;; which will be looked up at runtime with respect to the module that
;; was current when the lambda was bound, at runtime. The variable will
;; be resolved when it is first used.
-(define (ghil-lookup env sym)
+(define (ghil-lookup env sym . define?)
(let loop ((e env))
(record-case e
((<ghil-toplevel-env> table)
(let ((key (cons (module-name (current-module)) sym)))
(or (assoc-ref table key)
- (let ((var (make-ghil-var (car key) (cdr key) 'module)))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
+ (and (or (null? define?)
+ (car define?))
+ (let ((var (make-ghil-var (car key) (cdr key) 'module)))
+ (apush! key var (ghil-toplevel-env-table e))
+ var)))))
((<ghil-env> parent table variables)
(let ((found (assq-ref table sym)))
(if found
diff --git a/module/system/il/inline.scm b/module/system/il/inline.scm
index a31ae7bce..dd931f633 100644
--- a/module/system/il/inline.scm
+++ b/module/system/il/inline.scm
@@ -198,12 +198,3 @@
(x) x
(x y) (cons x y)
(x y . rest) (cons x (cons* y . rest)))
-
-(define-inline apply (proc . args)
- (apply proc . args))
-
-;; From ice-9/r4rs.scm; actually not that bad of a strategy for handling
-;; the (apply apply ...) case
-
-(define-inline @apply (proc . args)
- (apply proc . args))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 6bcbb5ffd..cb8e81371 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -46,8 +46,8 @@
(define (bootstrap-frame? frame)
(let ((code (program-bytecode (frame-program frame))))
- (and (= (uniform-vector-length code) 3)
- (= (uniform-vector-ref code 2)
+ (and (= (uniform-vector-length code) 5)
+ (= (uniform-vector-ref code 4)
(instruction->opcode 'halt)))))
(define (make-frame-chain frame addr)