summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-06-17 17:08:06 +0200
committerAndy Wingo <wingo@pobox.com>2011-06-17 17:08:06 +0200
commit0083cb5ec441c2a6df8d6eb1710eb8a88cf9fc5a (patch)
tree17a44d7b35a067bcb60d414fc9e25048417ae2b9
parentad0fedbf82786988b764492aca664664da2f85ad (diff)
downloadguile-0083cb5ec441c2a6df8d6eb1710eb8a88cf9fc5a.tar.gz
fix self tail recursion to different case-lambda clauses
http://savannah.gnu.org/bugs/?33362 * module/language/tree-il/compile-glil.scm (flatten-lambda-case): Rename from flatten, as it really just takes a particular case. Instead of iteratively compiling lambda cases through `comp', tail-call through flatten-lambda-case. This allows code to see which case it's being compiled in. Take advantage of that to limit the self-tail-call optimization to self-calls to the same case -- otherwise we might be jumping to a label without having reserved the right number of locals. (flatten-lambda): Adapt the caller. * test-suite/tests/compiler.test ("case-lambda"): Add a test.
-rw-r--r--module/language/tree-il/compile-glil.scm64
-rw-r--r--test-suite/tests/compiler.test17
2 files changed, 42 insertions, 39 deletions
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index f193e9dcd..b137afacf 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -207,10 +207,12 @@
;; write source info for proc
(if src (emit-code #f (make-glil-source src)))
;; compile the body, yo
- (flatten body allocation x self-label (car (hashq-ref allocation x))
- emit-code)))))))
+ (flatten-lambda-case body allocation x self-label
+ (car (hashq-ref allocation x))
+ emit-code)))))))
-(define (flatten x allocation self self-label fix-labels emit-code)
+(define (flatten-lambda-case lcase allocation self self-label fix-labels
+ emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(define (emit-branch src inst label)
@@ -218,7 +220,7 @@
;; RA: "return address"; #f unless we're in a non-tail fix with labels
;; MVRA: "multiple-values return address"; #f unless we're in a let-values
- (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+ (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
(define (comp-tail tree) (comp tree context RA MVRA))
(define (comp-push tree) (comp tree 'push #f #f))
(define (comp-drop tree) (comp tree 'drop #f #f))
@@ -422,41 +424,26 @@
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
- ;; self-call in tail position
+ ;; call to the same lambda-case in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
- (eq? context 'tail))
- (let lp ((lcase (lambda-body self)))
- (cond
- ((and (lambda-case? lcase)
- (not (lambda-case-kw lcase))
- (not (lambda-case-rest lcase))
- (= (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
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- ((#t #t . ,index) ; boxed
- ;; new box
- (emit-code #f (make-glil-lexical #t #t 'box index)))
- (,x (error "bad lambda-case arg allocation" x))))
- (reverse (lambda-case-gensyms lcase)))
- (emit-branch src 'br (car (hashq-ref allocation lcase))))
- ((lambda-case? lcase)
- ;; no match, try next case
- (lp (lambda-case-alternate lcase)))
- (else
- ;; 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)))))))
+ (eq? context 'tail)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args)
+ (+ (length (lambda-case-req lcase))
+ (or (and=> (lambda-case-opt lcase) length) 0))))
+ (for-each comp-push args)
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index) ; boxed
+ ;; new box
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "bad lambda-case arg allocation" x))))
+ (reverse (lambda-case-gensyms lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
;; lambda, the ultimate goto
((and (lexical-ref? proc)
@@ -780,7 +767,8 @@
(if alternate-label
(begin
(emit-label alternate-label)
- (comp-tail alternate)))))
+ (flatten-lambda-case alternate allocation self self-label
+ fix-labels emit-code)))))
((<let> src names gensyms vals body)
(for-each comp-push vals)
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 6b47086be..ee688c00a 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -149,3 +149,18 @@
((y) y)
((y z) (list y z)))))))
(not (not (memv 0 (map source:addr s))))))))
+
+(with-test-prefix "case-lambda"
+ (pass-if "self recursion to different clause"
+ (equal? (with-output-to-string
+ (lambda ()
+ (let ()
+ (define t
+ (case-lambda
+ ((x)
+ (t x 'y))
+ ((x y)
+ (display (list x y))
+ (list x y))))
+ (display (t 'x)))))
+ "(x y)(x y)")))