From ef24c01bffb41a9855fe1aea36c4444742aba660 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 15 Sep 2008 00:04:34 +0200 Subject: [PATCH] add special case for (apply values ...) * libguile/vm-engine.c (vm_run): Move nvalues to the top level, to avoid (spurious, it seems) gcc warnings about it being used uninitialized. * libguile/vm-i-system.c (halt, return/values): Adapt to gcc silliness. Deindent some of return/values. (return/values*): New instruction, does what (apply values . args) would do. * module/language/scheme/translate.scm (custom-transformer-table): Move the apply and @apply cases here from inline.scm, because we need some more cleverness when dealing with cases like (apply values . args). (lookup-apply-transformer): Define an eval transformer for `values', turning it into ghil-values*. * module/system/il/compile.scm (codegen): Compile into return/values*. * module/system/il/ghil.scm: Add and accessors. (ghil-lookup): Add optional argument, define?, which if false tells us not to actually cache the binding if it is not found in the toplevel. * module/system/il/inline.scm: Remove apply clauses. * module/system/vm/frame.scm (bootstrap-frame?): Update heuristic for bootstrap-frame?, as the bootstrap frame is now 5 bytes since it accepts multiple values. --- libguile/vm-engine.c | 1 + libguile/vm-i-system.c | 105 ++++++++++++++++----------- module/language/scheme/translate.scm | 26 +++++++ module/system/il/compile.scm | 11 +++ module/system/il/ghil.scm | 16 ++-- module/system/il/inline.scm | 9 --- module/system/vm/frame.scm | 4 +- 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)))) + (( 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)))) + (( 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 @@ make-ghil-values ghil-values? ghil-values-env ghil-values-loc ghil-values-values + make-ghil-values* ghil-values*? + ghil-values*-env ghil-values*-loc ghil-values*-values + 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 @@ ( env loc vars rest meta body) ( env loc proc args) ( env loc inline args) - ( env loc values))) + ( env loc 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 (( 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))))) (( 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)