[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. f4aa8d53a07168d15f737
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. f4aa8d53a07168d15f737164c37da02056948d2b |
|
Date: |
Sun, 07 Jun 2009 22:39:54 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=f4aa8d53a07168d15f737164c37da02056948d2b
The branch, master has been updated
via f4aa8d53a07168d15f737164c37da02056948d2b (commit)
from c0ee32452f4babfc99526ed35d1f80d128d8658b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit f4aa8d53a07168d15f737164c37da02056948d2b
Author: Andy Wingo <address@hidden>
Date: Mon Jun 8 00:38:49 2009 +0200
call-with-values can make fewer closures
* module/language/tree-il.scm: Rename let-exp and letrec-exp to let-body
and letrec-body. Add <let-values>, a one-expression let-values that
should avoid the needless creation of two closures in many common
multiple-value cases. We'll need to add an optimization pass to the
compiler to produce this form, though, as well as rewriting lambdas
into lets, etc.
I added this form instead of adding more special cases to the
call-with-values compile code because it's a useful intermediate form
-- it will allow the optimizer to perform constant folding across more
code.
* module/language/tree-il.scm (parse-tree-il, unparse-tree-il)
(tree-il->scheme, post-order!, pre-order!): Adapt to let/letrec body
renaming, and let-values.
* module/language/tree-il/analyze.scm (analyze-lexicals): Adapt for
renaming, and add cases for let-values.
* module/language/tree-il/compile-glil.scm (flatten): Add a new context,
`vals', used by let-values code for the values producer. Code that
produces multiple values can then jump to the let-values MV return
address directly, instead of trampolining into a procedure. Add code to
compile let-values.
-----------------------------------------------------------------------
Summary of changes:
module/language/tree-il.scm | 241 ++++++++++++++----------------
module/language/tree-il/analyze.scm | 52 +++++--
module/language/tree-il/compile-glil.scm | 131 ++++++++++++-----
3 files changed, 248 insertions(+), 176 deletions(-)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 3350311..9718920 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -35,9 +35,10 @@
<application> application? make-application application-src
application-proc application-args
<sequence> sequence? make-sequence sequence-src sequence-exps
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars
lambda-meta lambda-body
- <let> let? make-let let-src let-names let-vars let-vals let-exp
- <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-exp
-
+ <let> let? make-let let-src let-names let-vars let-vals let-body
+ <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-body
+ <let-values> let-values? make-let-values let-values-src
let-values-names let-values-vars let-values-exp let-values-body
+
parse-tree-il
unparse-tree-il
tree-il->scheme
@@ -60,8 +61,9 @@
(<application> proc args)
(<sequence> exps)
(<lambda> names vars meta body)
- (<let> names vars vals exp)
- (<letrec> names vars vals exp))
+ (<let> names vars vals body)
+ (<letrec> names vars vals body)
+ (<let-values> names vars exp body))
@@ -128,11 +130,14 @@
((begin . ,exps)
(make-sequence loc (map retrans exps)))
- ((let ,names ,vars ,vals ,exp)
- (make-let loc names vars (map retrans vals) (retrans exp)))
+ ((let ,names ,vars ,vals ,body)
+ (make-let loc names vars (map retrans vals) (retrans body)))
+
+ ((letrec ,names ,vars ,vals ,body)
+ (make-letrec loc names vars (map retrans vals) (retrans body)))
- ((letrec ,names ,vars ,vals ,exp)
- (make-letrec loc names vars (map retrans vals) (retrans exp)))
+ ((let-values ,names ,vars ,exp ,body)
+ (make-let-values loc names vars (retrans exp) (retrans body)))
(else
(error "unrecognized tree-il" exp)))))
@@ -181,140 +186,120 @@
((<sequence> exps)
`(begin ,@(map unparse-tree-il exps)))
- ((<let> names vars vals exp)
- `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
+ ((<let> names vars vals body)
+ `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<letrec> names vars vals exp)
- `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il
exp)))))
+ ((<letrec> names vars vals body)
+ `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il
body)))
+
+ ((<let-values> names vars exp body)
+ `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il
body)))))
(define (tree-il->scheme e)
- (cond ((list? e)
- (map tree-il->scheme e))
- ((pair? e)
- (cons (tree-il->scheme (car e))
- (tree-il->scheme (cdr e))))
- ((record? e)
- (record-case e
- ((<void>)
- '(if #f #f))
-
- ((<application> proc args)
- `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
-
- ((<conditional> test then else)
- (if (void? else)
- `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
- `(if ,(tree-il->scheme test) ,(tree-il->scheme then)
,(tree-il->scheme else))))
-
- ((<primitive-ref> name)
- name)
-
- ((<lexical-ref> name gensym)
- gensym)
-
- ((<lexical-set> name gensym exp)
- `(set! ,gensym ,(tree-il->scheme exp)))
-
- ((<module-ref> mod name public?)
- `(,(if public? '@ '@@) ,mod ,name))
-
- ((<module-set> mod name public? exp)
- `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
-
- ((<toplevel-ref> name)
- name)
-
- ((<toplevel-set> name exp)
- `(set! ,name ,(tree-il->scheme exp)))
-
- ((<toplevel-define> name exp)
- `(define ,name ,(tree-il->scheme exp)))
-
- ((<lambda> vars meta body)
- `(lambda ,vars
- ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
- ,(tree-il->scheme body)))
-
- ((<const> exp)
- (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- (list 'quote exp)))
-
- ((<sequence> exps)
- `(begin ,@(map tree-il->scheme exps)))
-
- ((<let> vars vals exp)
- `(let ,(map list vars (map tree-il->scheme vals))
,(tree-il->scheme exp)))
-
- ((<letrec> vars vals exp)
- `(letrec ,(map list vars (map tree-il->scheme vals))
,(tree-il->scheme exp)))))
- (else e)))
+ (record-case e
+ ((<void>)
+ '(if #f #f))
+
+ ((<application> proc args)
+ `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+
+ ((<conditional> test then else)
+ (if (void? else)
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then)
,(tree-il->scheme else))))
+
+ ((<primitive-ref> name)
+ name)
+
+ ((<lexical-ref> name gensym)
+ gensym)
+
+ ((<lexical-set> name gensym exp)
+ `(set! ,gensym ,(tree-il->scheme exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
+
+ ((<toplevel-ref> name)
+ name)
+
+ ((<toplevel-set> name exp)
+ `(set! ,name ,(tree-il->scheme exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(tree-il->scheme exp)))
+
+ ((<lambda> vars meta body)
+ `(lambda ,vars
+ ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
+ ,(tree-il->scheme body)))
+
+ ((<const> exp)
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))
+
+ ((<sequence> exps)
+ `(begin ,@(map tree-il->scheme exps)))
+
+ ((<let> vars vals body)
+ `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+
+ ((<letrec> vars vals body)
+ `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+
+ ((<let-values> vars exp body)
+ `(call-with-values (lambda () ,(tree-il->scheme exp))
+ (lambda ,vars ,(tree-il->scheme body))))))
(define (post-order! f x)
(let lp ((x x))
(record-case x
- ((<void>)
- (or (f x) x))
-
((<application> proc args)
(set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args))
- (or (f x) x))
+ (set! (application-args x) (map lp args)))
((<conditional> test then else)
(set! (conditional-test x) (lp test))
(set! (conditional-then x) (lp then))
- (set! (conditional-else x) (lp else))
- (or (f x) x))
-
- ((<primitive-ref> name)
- (or (f x) x))
-
- ((<lexical-ref> name gensym)
- (or (f x) x))
-
+ (set! (conditional-else x) (lp else)))
+
((<lexical-set> name gensym exp)
- (set! (lexical-set-exp x) (lp exp))
- (or (f x) x))
-
- ((<module-ref> mod name public?)
- (or (f x) x))
-
+ (set! (lexical-set-exp x) (lp exp)))
+
((<module-set> mod name public? exp)
- (set! (module-set-exp x) (lp exp))
- (or (f x) x))
-
- ((<toplevel-ref> name)
- (or (f x) x))
-
+ (set! (module-set-exp x) (lp exp)))
+
((<toplevel-set> name exp)
- (set! (toplevel-set-exp x) (lp exp))
- (or (f x) x))
-
+ (set! (toplevel-set-exp x) (lp exp)))
+
((<toplevel-define> name exp)
- (set! (toplevel-define-exp x) (lp exp))
- (or (f x) x))
-
+ (set! (toplevel-define-exp x) (lp exp)))
+
((<lambda> vars meta body)
- (set! (lambda-body x) (lp body))
- (or (f x) x))
-
- ((<const> exp)
- (or (f x) x))
-
+ (set! (lambda-body x) (lp body)))
+
((<sequence> exps)
- (set! (sequence-exps x) (map lp exps))
- (or (f x) x))
-
- ((<let> vars vals exp)
+ (set! (sequence-exps x) (map lp exps)))
+
+ ((<let> vars vals body)
(set! (let-vals x) (map lp vals))
- (set! (let-exp x) (lp exp))
- (or (f x) x))
-
- ((<letrec> vars vals exp)
+ (set! (let-body x) (lp body)))
+
+ ((<letrec> vars vals body)
(set! (letrec-vals x) (map lp vals))
- (set! (letrec-exp x) (lp exp))
- (or (f x) x)))))
+ (set! (letrec-body x) (lp body)))
+
+ ((<let-values> vars exp body)
+ (set! (let-values-exp x) (lp exp))
+ (set! (let-values-body x) (lp body)))
+
+ (else #f))
+
+ (or (f x) x)))
(define (pre-order! f x)
(let lp ((x x))
@@ -347,13 +332,17 @@
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
- ((<let> vars vals exp)
+ ((<let> vars vals body)
(set! (let-vals x) (map lp vals))
- (set! (let-exp x) (lp exp)))
+ (set! (let-body x) (lp body)))
- ((<letrec> vars vals exp)
+ ((<letrec> vars vals body)
(set! (letrec-vals x) (map lp vals))
- (set! (letrec-exp x) (lp exp)))
+ (set! (letrec-body x) (lp body)))
+
+ ((<let-values> vars exp body)
+ (set! (let-values-exp x) (lp exp))
+ (set! (let-values-body x) (lp body)))
(else #f))
x)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 477f1fc..90843f7 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -116,17 +116,26 @@
(recur body x)
(hashq-set! bindings x (reverse! (hashq-ref bindings x))))
- ((<let> vars vals exp)
+ ((<let> vars vals body)
(for-each step vals)
(hashq-set! bindings parent
(append (reverse vars) (hashq-ref bindings parent)))
- (step exp))
+ (step body))
- ((<letrec> vars vals exp)
+ ((<letrec> vars vals body)
(hashq-set! bindings parent
(append (reverse vars) (hashq-ref bindings parent)))
(for-each step vals)
- (step exp))
+ (step body))
+
+ ((<let-values> vars exp body)
+ (hashq-set! bindings parent
+ (let lp ((out (hashq-ref bindings parent)) (in vars))
+ (if (pair? in)
+ (lp (cons (car in) out) (cdr in))
+ (if (null? in) out (cons in out)))))
+ (step exp)
+ (step body))
(else #f)))
@@ -174,26 +183,26 @@
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
n)
- ((<let> vars vals exp)
+ ((<let> vars vals body)
(let ((nmax (apply max (map recur vals))))
(cond
;; the `or' hack
- ((and (conditional? exp)
+ ((and (conditional? body)
(= (length vars) 1)
(let ((v (car vars)))
(and (not (hashq-ref heaps v))
(= (hashq-ref refcounts v 0) 2)
- (lexical-ref? (conditional-test exp))
- (eq? (lexical-ref-gensym (conditional-test exp)) v)
- (lexical-ref? (conditional-then exp))
- (eq? (lexical-ref-gensym (conditional-then exp)) v))))
+ (lexical-ref? (conditional-test body))
+ (eq? (lexical-ref-gensym (conditional-test body)) v)
+ (lexical-ref? (conditional-then body))
+ (eq? (lexical-ref-gensym (conditional-then body))
v))))
(hashq-set! allocation (car vars) (cons 'stack n))
;; the 1+ for this var
- (max nmax (1+ n) (allocate! (conditional-else exp) level n)))
+ (max nmax (1+ n) (allocate! (conditional-else body) level n)))
(else
(let lp ((vars vars) (n n))
(if (null? vars)
- (max nmax (allocate! exp level n))
+ (max nmax (allocate! body level n))
(let ((v (car vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
@@ -203,14 +212,14 @@
(cons 'stack n)))
(lp (cdr vars) (if binder n (1+ n)))))))))))
- ((<letrec> vars vals exp)
+ ((<letrec> vars vals body)
(let lp ((vars vars) (n n))
(if (null? vars)
(let ((nmax (apply max
(map (lambda (x)
(allocate! x level n))
vals))))
- (max nmax (allocate! exp level n)))
+ (max nmax (allocate! body level n)))
(let ((v (car vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
@@ -220,6 +229,21 @@
(cons 'stack n)))
(lp (cdr vars) (if binder n (1+ n))))))))
+ ((<let-values> vars exp body)
+ (let ((nmax (recur exp)))
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (max nmax (allocate! body level n))
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap level (allocate-heap! binder))
+ (cons 'stack n)))
+ (lp (if (pair? vars) (cdr vars) '())
+ (if binder n (1+ n)))))))))
+
(else n)))
(define parents (make-hash-table))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 94ace7e..78a841d 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -150,22 +150,24 @@
(define (emit-branch src inst label)
(emit-code src (make-glil-branch inst label)))
- (let comp ((x x) (context 'tail))
- (define (comp-tail tree) (comp tree context))
- (define (comp-push tree) (comp tree 'push))
- (define (comp-drop tree) (comp tree 'drop))
+ ;; LMVRA == "let-values MV return address"
+ (let comp ((x x) (context 'tail) (LMVRA #f))
+ (define (comp-tail tree) (comp tree context LMVRA))
+ (define (comp-push tree) (comp tree 'push #f))
+ (define (comp-drop tree) (comp tree 'drop #f))
+ (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
(record-case x
((<void>)
(case context
- ((push) (emit-code #f (make-glil-void)))
+ ((push vals) (emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<const> src exp)
(case context
- ((push) (emit-code src (make-glil-const exp)))
+ ((push vals) (emit-code src (make-glil-const exp)))
((tail)
(emit-code src (make-glil-const exp))
(emit-code #f (make-glil-call 'return 1)))))
@@ -189,7 +191,7 @@
(args (cdr args)))
(cond
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)))
+ (not (eq? context 'push)) (not (eq? context 'vals)))
;; tail: (lambda () (apply values '(1 2)))
;; drop: (lambda () (apply values '(1 2)) 3)
;; push: (lambda () (list (apply values '(10 12)) 1))
@@ -209,6 +211,11 @@
(comp-push proc)
(for-each comp-push args)
(emit-code src (make-glil-call 'apply (1+ (length args)))))
+ ((vals)
+ (comp-vals
+ (make-application src (make-primitive-ref #f 'apply)
+ (cons proc args))
+ LMVRA))
((drop)
;; Well, shit. The proc might return any number of
;; values (including 0), since it's in a drop context,
@@ -223,11 +230,17 @@
;; tail: (lambda () (values '(1 2)))
;; drop: (lambda () (values '(1 2)) 3)
;; push: (lambda () (list (values '(10 12)) 1))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
(case context
((drop) (for-each comp-drop args))
+ ((vals)
+ (for-each comp-push args)
+ (emit-code #f (make-glil-const (length args)))
+ (emit-branch src 'br LMVRA))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values (length args))))))
+
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-values)
(= (length args) 2))
@@ -238,22 +251,30 @@
;; goto POST
;; MV: [tail-]call/nargs
;; POST: (maybe-drop)
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (comp-push consumer)
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'goto/args 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))))))
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-vals
+ (make-application src (make-primitive-ref #f 'call-with-values)
+ args)
+ LMVRA))
+ (else
+ (let ((MV (make-label)) (POST (make-label))
+ (producer (car args)) (consumer (cadr args)))
+ (comp-push consumer)
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/args 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))))))))
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-current-continuation)
@@ -262,6 +283,12 @@
((tail)
(comp-push (car args))
(emit-code src (make-glil-call 'goto/cc 1)))
+ ((vals)
+ (comp-vals
+ (make-application
+ src (make-primitive-ref #f 'call-with-current-continuation)
+ args)
+ LMVRA))
((push)
(comp-push (car args))
(emit-code src (make-glil-call 'call/cc 1)))
@@ -282,6 +309,7 @@
(case context
((tail) (emit-code #f (make-glil-call 'return 1)))
((drop) (emit-code #f (make-glil-call 'drop 1))))))
+
(else
(comp-push proc)
(for-each comp-push args)
@@ -289,6 +317,7 @@
(case context
((tail) (emit-code src (make-glil-call 'goto/args len)))
((push) (emit-code src (make-glil-call 'call len)))
+ ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA)))
((drop)
(let ((MV (make-label)) (POST (make-label)))
(emit-code src (make-glil-mv-call len MV))
@@ -322,7 +351,7 @@
((eq? (module-variable (fluid-ref *comp-module*) name)
(module-variable the-root-module name))
(case context
- ((push)
+ ((push vals)
(emit-code src (make-glil-toplevel 'ref name)))
((tail)
(emit-code src (make-glil-toplevel 'ref name))
@@ -330,7 +359,7 @@
(else
(pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
(case context
- ((push)
+ ((push vals)
(emit-code src (make-glil-module 'ref '(guile) name #f)))
((tail)
(emit-code src (make-glil-module 'ref '(guile) name #f))
@@ -338,7 +367,7 @@
((<lexical-ref> src name gensym)
(case context
- ((push tail)
+ ((push vals tail)
(let ((loc (hashq-ref allocation gensym)))
(case (car loc)
((stack)
@@ -361,7 +390,7 @@
'set (- level (cadr loc)) (cddr loc))))
(else (error "badness" x loc))))
(case context
- ((push)
+ ((push vals)
(emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
@@ -377,7 +406,7 @@
(comp-push exp)
(emit-code src (make-glil-module 'set mod name public?))
(case context
- ((push)
+ ((push vals)
(emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
@@ -393,7 +422,7 @@
(comp-push exp)
(emit-code src (make-glil-toplevel 'set name))
(case context
- ((push)
+ ((push vals)
(emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
@@ -403,7 +432,7 @@
(comp-push exp)
(emit-code src (make-glil-toplevel 'define name))
(case context
- ((push)
+ ((push vals)
(emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
@@ -411,13 +440,13 @@
((<lambda>)
(case context
- ((push)
+ ((push vals)
(emit-code #f (flatten-lambda x level allocation)))
((tail)
(emit-code #f (flatten-lambda x level allocation))
(emit-code #f (make-glil-call 'return 1)))))
- ((<let> src names vars vals exp)
+ ((<let> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v)
@@ -429,10 +458,10 @@
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(reverse vars))
- (comp-tail exp)
+ (comp-tail body)
(emit-code #f (make-glil-unbind)))
- ((<letrec> src names vars vals exp)
+ ((<letrec> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v)
@@ -444,5 +473,35 @@
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(reverse vars))
- (comp-tail exp)
- (emit-code #f (make-glil-unbind))))))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<let-values> src names vars exp body)
+ (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
+ (cond
+ ((pair? inames)
+ (lp (cons (car inames) names) (cons (car ivars) vars)
+ (cdr inames) (cdr ivars) #f))
+ ((not (null? inames))
+ (lp (cons inames names) (cons ivars vars) '() '() #t))
+ (else
+ (let ((names (reverse! names))
+ (vars (reverse! vars))
+ (MV (make-label)))
+ (comp-vals exp MV)
+ (emit-code #f (make-glil-const 1))
+ (emit-label MV)
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list names vars allocation)
+ rest?))
+ (for-each (lambda (v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external 'set 0 (cddr
loc))))
+ (else (error "badness" x loc)))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind))))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. f4aa8d53a07168d15f737164c37da02056948d2b,
Andy Wingo <=