summaryrefslogtreecommitdiff
path: root/module/language/tree-il/compile-glil.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/tree-il/compile-glil.scm')
-rw-r--r--module/language/tree-il/compile-glil.scm64
1 files changed, 26 insertions, 38 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)