diff options
author | Andy Wingo <wingo@pobox.com> | 2008-09-18 22:49:55 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-09-18 22:49:55 +0200 |
commit | d51406fe875ae5040324da19459c3e867df434a3 (patch) | |
tree | 7996c92a31164bd3424c5b84e6ded8617df756f0 | |
parent | 87e7228ff6b76d44ecf63e092fadb5754557e5eb (diff) | |
download | guile-d51406fe875ae5040324da19459c3e867df434a3.tar.gz |
lambda-lifting for (lambda () ...) as consumer of call-with-values
* libguile/vm-engine.c (vm_run): Add new error case,
vm_error_not_enough_values.
* libguile/vm-i-system.c (goto/nargs, call/nargs): So, in these cases, if
we get too many values, we don't truncate the values like we do in the
single-value continuation case, or in the mvbind case. What to do? I
guess we either truncate them here, or only allow the correct number of
values. Dunno. Mark the code as a fixme.
(truncate-values): New instruction, for mv-bind: checks that the number
of values on the stack is compatible with the number of bindings we
have arranged for them, truncating if necessary.
* module/language/scheme/translate.scm (custom-transformer-table):
Compile receive as a primary form -- not so much because it is a
primary form, but more to test the mv-bind machinery. Also it's more
efficient, I think.
* module/system/il/compile.scm (lift-variables!): New helper, factored
out of `optimize'.
(optimize): Add a few more cases. Adapt `lambda' optimization, which
isn't much. I'm not happy with ghil as a mungeable language.
Add a case for call-with-values with the second argument is
a lambda: lift the lambda. Untested.
(codegen): Refactor the push-bindings! code. Compile mv-bind.
* module/system/il/ghil.scm (<ghil-mv-bind>): Add mv-bind construct,
along with its procedures.
* module/system/il/glil.scm (<glil-mv-bind>): Add mv-bind construct,
different from the high-level one. It makes sense in the source, I
think.
* module/system/vm/assemble.scm (codegen): Assemble glil-mv-bind by
pushing onto the bindings list, and actually push some code to truncate
the values.
-rw-r--r-- | libguile/vm-engine.c | 5 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 25 | ||||
-rw-r--r-- | module/language/scheme/translate.scm | 12 | ||||
-rw-r--r-- | module/system/il/compile.scm | 61 | ||||
-rw-r--r-- | module/system/il/ghil.scm | 4 | ||||
-rw-r--r-- | module/system/il/glil.scm | 4 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 13 |
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))) |