summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/vm-engine.c5
-rw-r--r--libguile/vm-i-system.c25
-rw-r--r--module/language/scheme/translate.scm12
-rw-r--r--module/system/il/compile.scm61
-rw-r--r--module/system/il/ghil.scm4
-rw-r--r--module/system/il/glil.scm4
-rw-r--r--module/system/vm/assemble.scm13
7 files changed, 110 insertions, 14 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 73990d041..66d821329 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -172,6 +172,11 @@ vm_run (SCM vm, SCM program, SCM args)
err_args = SCM_EOL;
goto vm_error;
+ vm_error_not_enough_values:
+ err_msg = scm_from_locale_string ("VM: Not enough values for mv-bind");
+ 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 05fc7476e..21d0d0821 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -713,6 +713,7 @@ VM_DEFINE_INSTRUCTION (goto_nargs, "goto/nargs", 0, 0, 1)
SCM x;
POP (x);
nargs = scm_to_int (x);
+ /* FIXME: should truncate values? */
goto vm_goto_args;
}
@@ -721,6 +722,7 @@ VM_DEFINE_INSTRUCTION (call_nargs, "call/nargs", 0, 0, 1)
SCM x;
POP (x);
nargs = scm_to_int (x);
+ /* FIXME: should truncate values? */
goto vm_call;
}
@@ -963,6 +965,29 @@ VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
+VM_DEFINE_INSTRUCTION (truncate_values, "truncate-values", 2, -1, -1)
+{
+ SCM x;
+ int nbinds, rest;
+ POP (x);
+ nvalues = scm_to_int (x);
+ nbinds = FETCH ();
+ rest = FETCH ();
+
+ if (rest)
+ nbinds--;
+
+ if (nvalues < nbinds)
+ goto vm_error_not_enough_values;
+
+ if (rest)
+ POP_LIST (nvalues - nbinds);
+ else
+ DROPN (nvalues - nbinds);
+
+ NEXT;
+}
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 6fed7df48..5669e047a 100644
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -25,7 +25,6 @@
#:use-module (system il ghil)
#:use-module (system il inline)
#:use-module (ice-9 receive)
- #:use-module (srfi srfi-39)
#:use-module ((system base compile) #:select (syntax-error))
#:export (translate))
@@ -332,6 +331,17 @@
((,producer ,consumer)
(make-ghil-mv-call e l (retrans producer) (retrans consumer))))
+ (receive
+ ((,formals ,producer-exp . ,body)
+ ;; Lovely, self-referential usage. Not strictly necessary, the
+ ;; macro would do the trick; but it's good to test the mv-bind
+ ;; code.
+ (receive (syms rest) (parse-formals formals)
+ (call-with-ghil-bindings e syms
+ (lambda (vars)
+ (make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
+ vars rest (trans-body e l body)))))))
+
(values
((,x) (retrans x))
(,args (make-ghil-values e l (map retrans args))))))
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index 70d3db504..21adbdd79 100644
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -35,14 +35,32 @@
;;; Stage 2: Optimization
;;;
+(define (lift-variables! env)
+ (let ((parent-env (ghil-env-parent env)))
+ (for-each (lambda (v)
+ (case (ghil-var-kind v)
+ ((argument) (set! (ghil-var-kind v) 'local)))
+ (set! (ghil-var-env v) parent-env)
+ (ghil-env-add! parent-env v))
+ (ghil-env-variables env))))
+
(define (optimize x)
(record-case x
((<ghil-set> env loc var val)
(make-ghil-set env var (optimize val)))
+ ((<ghil-define> env loc var val)
+ (make-ghil-define env var (optimize val)))
+
((<ghil-if> env loc test then else)
(make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
+ ((<ghil-and> env loc exps)
+ (make-ghil-and env loc (map optimize exps)))
+
+ ((<ghil-or> env loc exps)
+ (make-ghil-or env loc (map optimize exps)))
+
((<ghil-begin> env loc exps)
(make-ghil-begin env loc (map optimize exps)))
@@ -63,17 +81,23 @@
((<ghil-lambda> env loc vars rest meta body)
(cond
((not rest)
- (for-each (lambda (v)
- (case (ghil-var-kind v)
- ((argument) (set! (ghil-var-kind v) 'local)))
- (set! (ghil-var-env v) parent-env)
- (ghil-env-add! parent-env v))
- (ghil-env-variables env)))
+ (lift-variables! env)
+ (make-ghil-bind parent-env loc (map optimize args)))
(else
(make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
(else
(make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
+ ((<ghil-mv-call> env loc producer consumer)
+ (record-case consumer
+ ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
+ ;; (mv-let PRODUCER ARGS BODY...)
+ ((<ghil-lambda> env loc vars rest meta body)
+ (lift-variables! env)
+ (make-ghil-mv-bind producer vars rest body))
+ (else
+ (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
+
(else x)))
@@ -116,15 +140,11 @@
(define (push-code! loc code)
(set! stack (cons code stack))
(if loc (set! stack (cons (make-glil-source loc) stack))))
+ (define (var->binding var)
+ (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
(define (push-bindings! loc vars)
(if (not (null? vars))
- (push-code!
- loc
- (make-glil-bind
- (map list
- (map ghil-var-name vars)
- (map ghil-var-kind vars)
- (map ghil-var-index vars))))))
+ (push-code! loc (make-glil-bind (map var->binding vars)))))
(define (comp tree tail drop)
(define (push-label! label)
(push-code! #f (make-glil-label label)))
@@ -290,6 +310,21 @@
(comp-tail body)
(push-code! #f (make-glil-unbind)))
+ ((<ghil-mv-bind> env loc producer vars rest body)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (let ((MV (make-label)))
+ (comp-push producer)
+ (push-code! loc (make-glil-mv-call 0 MV))
+ (push-code! #f (make-glil-const #:obj 1))
+ (push-label! MV)
+ (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
+ (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
+ (reverse vars)))
+ (comp-tail body)
+ (push-code! #f (make-glil-unbind)))
+
((<ghil-lambda> env loc vars rest meta body)
(return-code! loc (codegen tree)))
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 60ec7ff86..1398bd17f 100644
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -62,6 +62,9 @@
<ghil-bind> make-ghil-bind ghil-bind?
ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
+ <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
+ ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body
+
<ghil-lambda> make-ghil-lambda ghil-lambda?
ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
ghil-lambda-meta ghil-lambda-body
@@ -117,6 +120,7 @@
(<ghil-or> env loc exps)
(<ghil-begin> env loc exps)
(<ghil-bind> env loc vars vals body)
+ (<ghil-mv-bind> env loc producer vars rest body)
(<ghil-lambda> env loc vars rest meta body)
(<ghil-call> env loc proc args)
(<ghil-mv-call> env loc producer consumer)
diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
index 7b7159c00..5c42a2a70 100644
--- a/module/system/il/glil.scm
+++ b/module/system/il/glil.scm
@@ -32,6 +32,9 @@
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
+ <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
+ glil-mv-bind-vars glil-mv-bind-rest
+
<glil-unbind> make-glil-unbind glil-unbind?
<glil-source> make-glil-source glil-source?
@@ -76,6 +79,7 @@
;; Meta operations
(<glil-asm> vars meta body)
(<glil-bind> vars)
+ (<glil-mv-bind> vars rest)
(<glil-unbind>)
(<glil-source> loc)
;; Objects
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index f354ef374..f5fac6eb0 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -139,6 +139,19 @@
(set! binding-alist
(acons (current-address) bindings binding-alist))))
+ ((<glil-mv-bind> (binds vars) rest)
+ (let ((bindings
+ (map (lambda (v)
+ (let ((name (car v)) (type (cadr v)) (i (caddr v)))
+ (case type
+ ((argument) (make-binding name #f i))
+ ((local) (make-binding name #f (+ (glil-vars-nargs vars) i)))
+ ((external) (make-binding name #t i)))))
+ binds)))
+ (set! binding-alist
+ (acons (current-address) bindings binding-alist))
+ (push-code! `(truncate-values ,(length binds) ,(if rest 1 0)))))
+
((<glil-unbind>)
(set! binding-alist (acons (current-address) #f binding-alist)))