mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

fix self tail recursion to different case-lambda clauses

Browse source 
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.
This commit is contained in:
Andy Wingo 2011-06-17 17:08:06 +02:00
parent ad0fedbf82
commit 0083cb5ec4
2 changed files with 42 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -207,10 +207,12 @@
;; write source info for proc ;; write source info for proc
(if src (emit-code #f (make-glil-source src))) (if src (emit-code #f (make-glil-source src)))
;; compile the body, yo ;; compile the body, yo
(flatten body allocation x self-label (car (hashq-ref allocation x)) (flatten-lambda-case body allocation x self-label
emit-code))))))) (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) (define (emit-label label)
(emit-code #f (make-glil-label label))) (emit-code #f (make-glil-label label)))
(define (emit-branch src inst 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 ;; 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 ;; 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-tail tree) (comp tree context RA MVRA))
(define (comp-push tree) (comp tree 'push #f #f)) (define (comp-push tree) (comp tree 'push #f #f))
(define (comp-drop tree) (comp tree 'drop #f #f)) (define (comp-drop tree) (comp tree 'drop #f #f))
@ -422,41 +424,26 @@
(error "bad primitive op: too many pushes" (error "bad primitive op: too many pushes"
op (instruction-pushes op)))))) op (instruction-pushes op))))))
;; self-call in tail position ;; call to the same lambda-case in tail position
((and (lexical-ref? proc) ((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label) self-label (eq? (lexical-ref-gensym proc) self-label)
(eq? context 'tail)) (eq? context 'tail)
(let lp ((lcase (lambda-body self))) (not (lambda-case-kw lcase))
(cond (not (lambda-case-rest lcase))
((and (lambda-case? lcase) (= (length args)
(not (lambda-case-kw lcase)) (+ (length (lambda-case-req lcase))
(not (lambda-case-rest lcase)) (or (and=> (lambda-case-opt lcase) length) 0))))
(= (length args) (for-each comp-push args)
(+ (length (lambda-case-req lcase)) (for-each (lambda (sym)
(or (and=> (lambda-case-opt lcase) length) 0)))) (pmatch (hashq-ref (hashq-ref allocation sym) self)
;; we have a case that matches the args; evaluate new ((#t #f . ,index) ; unboxed
;; values, rename variables and goto the case label (emit-code #f (make-glil-lexical #t #f 'set index)))
(for-each comp-push args) ((#t #t . ,index) ; boxed
(for-each (lambda (sym) ;; new box
(pmatch (hashq-ref (hashq-ref allocation sym) self) (emit-code #f (make-glil-lexical #t #t 'box index)))
((#t #f . ,index) ; unboxed (,x (error "bad lambda-case arg allocation" x))))
(emit-code #f (make-glil-lexical #t #f 'set index))) (reverse (lambda-case-gensyms lcase)))
((#t #t . ,index) ; boxed (emit-branch src 'br (car (hashq-ref allocation lcase))))
;; 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)))))))
;; lambda, the ultimate goto ;; lambda, the ultimate goto
((and (lexical-ref? proc) ((and (lexical-ref? proc)
@ -780,7 +767,8 @@
(if alternate-label (if alternate-label
(begin (begin
(emit-label alternate-label) (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) ((<let> src names gensyms vals body)
(for-each comp-push vals) (for-each comp-push vals)

17
test-suite/tests/compiler.test
View file

@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -149,3 +149,18 @@
((y) y) ((y) y)
((y z) (list y z))))))) ((y z) (list y z)))))))
(not (not (memv 0 (map source:addr s)))))))) (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)")))