mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

fix self-tail-calls for lexical procs with optional, rest, or kwargs

Browse source 
* module/language/tree-il/compile-glil.scm (flatten-lambda): Don't emit
  a self-label, because when we can't match the args for a lexical call,
  we have no space to shuffle args and jump.
  (flatten): Apply the self-tail-call optimization to optional args
  too, but only if the procedure is fix-allocated. If we can't apply the
  optimization, use the normal tail-call sequence.

* test-suite/tests/optargs.test ("lambda* inits"): Add tests.
This commit is contained in:
Andy Wingo 2010-12-10 13:02:24 +01:00
parent 3b24aee6e3
commit 84b67e1971
2 changed files with 30 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

27
module/language/tree-il/compile-glil.scm
View file

@ -204,10 +204,6 @@
(lambda (emit-code)
;; write source info for proc
(if src (emit-code #f (make-glil-source src)))
;; emit pre-prelude label for self tail calls in which the
;; number of arguments doesn't check out at compile time
(if self-label
(emit-code #f (make-glil-label self-label)))
;; compile the body, yo
(flatten body allocation x self-label (car (hashq-ref allocation x))
emit-code)))))))
@ -423,17 +419,17 @@
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
(eq? context 'tail))
;; first, evaluate new values, pushing them on the stack
(for-each comp-push args)
(let lp ((lcase (lambda-body self)))
(cond
((and (lambda-case? lcase)
(not (lambda-case-kw lcase))
(not (lambda-case-opt lcase))
(not (lambda-case-rest lcase))
(= (length args) (length (lambda-case-req lcase))))
;; we have a case that matches the args; rename variables
;; and goto the case label
(= (length args)
(+ (length (lambda-case-req lcase))
(or (and=> (lambda-case-opt lcase) length) 0))))
;; we have a case that matches the args; evaluate new
;; values, rename variables and goto the case label
(for-each comp-push args)
(for-each (lambda (sym)
(pmatch (hashq-ref (hashq-ref allocation sym) self)
((#t #f . ,index) ; unboxed
@ -448,11 +444,12 @@
;; no match, try next case
(lp (lambda-case-alternate lcase)))
(else
;; no cases left; shuffle args down and jump before the prelude.
(for-each (lambda (i)
(emit-code #f (make-glil-lexical #t #f 'set i)))
(reverse (iota (length args))))
(emit-branch src 'br self-label)))))
;; no cases left -- use the normal tail call mechanism. we
;; can't just shuffle the args down and jump back to the
;; self label, because we don't have space.
(comp-push proc)
(for-each comp-push args)
(emit-code src (make-glil-call 'tail-call (length args)))))))
;; lambda, the ultimate goto
((and (lexical-ref? proc)

19
test-suite/tests/optargs.test
View file

@ -184,7 +184,24 @@
(pass-if "testing qux"
(and (equal? (qux) 13)
(equal? (qux 1) 1)
(equal? (qux #:a 2) 2))))
(equal? (qux #:a 2) 2)))
(pass-if "nested lambda* with optional"
(begin
(define (foo x)
(define baz x)
(define* (bar #:optional (y baz))
(or (zero? y) (bar (1- y))))
(bar))
(foo 10)))
(pass-if "nested lambda* with key"
(begin
(define (foo x)
(define baz x)
(define* (bar #:key (y baz))
(or (zero? y) (bar #:y (1- y))))
(bar))
(foo 10))))
(with-test-prefix/c&e "defmacro*"
(pass-if "definition"