mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
Code Activity

Improve tail recursion in compiler

Browse source 
* module/language/tree-il/compile-bytecode.scm (compile-closure): Make
  it so that for-tail is actually tail-recursive.  Likewise improve tail
  recursion for the other helpers.
This commit is contained in:
Andy Wingo 2020-05-11 14:48:45 +02:00
parent 35160ade03
commit 7f4bbc3dba
1 changed files with 6 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

18
module/language/tree-il/compile-bytecode.scm
View file

@ -1023,9 +1023,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <seq>) (visit-seq exp env 'effect)) (($ <seq>) (visit-seq exp env 'effect))
(($ <let>) (visit-let exp env 'effect)) (($ <let>) (visit-let exp env 'effect))
(($ <fix>) (visit-fix exp env 'effect)) (($ <fix>) (visit-fix exp env 'effect))
(($ <let-values>) (visit-let-values exp env 'effect))) (($ <let-values>) (visit-let-values exp env 'effect))))
(values))
(define (for-value-at exp env base) (define (for-value-at exp env base)
;; The baseline compiler follows a stack discipline: compiling ;; The baseline compiler follows a stack discipline: compiling
@ -1182,8 +1180,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <seq>) (visit-seq exp env `(value-at . ,base))) (($ <seq>) (visit-seq exp env `(value-at . ,base)))
(($ <let>) (visit-let exp env `(value-at . ,base))) (($ <let>) (visit-let exp env `(value-at . ,base)))
(($ <fix>) (visit-fix exp env `(value-at . ,base))) (($ <fix>) (visit-fix exp env `(value-at . ,base)))
(($ <let-values>) (visit-let-values exp env `(value-at . ,base)))) (($ <let-values>) (visit-let-values exp env `(value-at . ,base)))))
dst-env)
(define (for-value exp env) (define (for-value exp env)
(match (and (lexical-ref? exp) (match (and (lexical-ref? exp)
@ -1194,7 +1191,8 @@ in the frame with for the lambda-case clause @var{clause}."
(for-push exp env)))) (for-push exp env))))
(define (for-push exp env) (define (for-push exp env)
(for-value-at exp env env)) (for-value-at exp env env)
(push-temp env))
(define (for-init sym init env) (define (for-init sym init env)
(match (lookup-lexical sym env) (match (lookup-lexical sym env)
@ -1237,9 +1235,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <seq>) (visit-seq exp env `(values-at . ,base))) (($ <seq>) (visit-seq exp env `(values-at . ,base)))
(($ <let>) (visit-let exp env `(values-at . ,base))) (($ <let>) (visit-let exp env `(values-at . ,base)))
(($ <fix>) (visit-fix exp env `(values-at . ,base))) (($ <fix>) (visit-fix exp env `(values-at . ,base)))
(($ <let-values>) (visit-let-values exp env `(values-at . ,base)))) (($ <let-values>) (visit-let-values exp env `(values-at . ,base)))))
(values))
(define (for-values exp env) (define (for-values exp env)
(for-values-at exp env env)) (for-values-at exp env env))
@ -1274,9 +1270,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <seq>) (visit-seq exp env 'tail)) (($ <seq>) (visit-seq exp env 'tail))
(($ <let>) (visit-let exp env 'tail)) (($ <let>) (visit-let exp env 'tail))
(($ <fix>) (visit-fix exp env 'tail)) (($ <fix>) (visit-fix exp env 'tail))
(($ <let-values>) (visit-let-values exp env 'tail))) (($ <let-values>) (visit-let-values exp env 'tail))))
(values))
(match clause (match clause
(($ <lambda-case> src req opt rest kw inits syms body alt) (($ <lambda-case> src req opt rest kw inits syms body alt)