mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 10:10:23 +02:00
Code Activity

actually inline call-with-values to tree-il's <let-values>

Browse source 
* module/srfi/srfi-11.scm (let-values): In the one-clause case, avoid
  going through temporary variables.

* module/language/tree-il/inline.scm (inline!): Add another case:
  (call-with-values (lambda () ...) (lambda ... ...) -> let-values.

* module/language/tree-il/compile-glil.scm (flatten): Fix a bug
  compiling applications in "vals" context.

* module/language/tree-il/analyze.scm (analyze-lexicals): Fix a couple
  bugs with let-values and rest arguments.
This commit is contained in:
Andy Wingo 2009-08-06 11:48:16 +02:00
parent 4dcd84998f
commit bca488f186
4 changed files with 59 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/language/tree-il/analyze.scm
View file

@ -185,14 +185,14 @@
vars))
((<let-values> vars exp body)
(hashq-set! bound-vars proc
(let lp ((out (hashq-ref bound-vars proc)) (in vars))
(let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
(if (pair? in)
(lp (cons (car in) out) (cdr in))
(if (null? in) out (cons in out)))))
(if (null? in) out (cons in out))))))
(hashq-set! bound-vars proc bound)
(lset-difference eq?
(lset-union eq? (step exp) (step body))
vars))
bound)))
(else '())))
@ -309,15 +309,23 @@
((<let-values> vars exp body)
(let ((nmax (recur exp)))
(let lp ((vars vars) (n n))
(if (null? vars)
(max nmax (allocate! body proc n))
(cond
((null? vars)
(max nmax (allocate! body proc n)))
((not (pair? vars))
(hashq-set! allocation vars
(make-hashq proc
`(#t ,(hashq-ref assigned vars) . ,n)))
;; the 1+ for this var
(max nmax (allocate! body proc (1+ n))))
(else
(let ((v (if (pair? vars) (car vars) vars)))
(let ((v (car vars)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))))
(lp (cdr vars) (1+ n)))))))))
(else n)))

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

@ -391,7 +391,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)))
((vals) (emit-code src (make-glil-mv-call len LMVRA)))
((drop)
(let ((MV (make-label)) (POST (make-label)))
(emit-code src (make-glil-mv-call len MV))

33
module/language/tree-il/inline.scm
View file

@ -37,8 +37,35 @@
(post-order!
(lambda (x)
(record-case x
((<application> proc args)
(and (lambda? proc) (null? args)
(lambda-body proc)))
((<application> src proc args)
(cond
;; ((lambda () x)) => x
((and (lambda? proc) (null? args))
(lambda-body proc))
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
;;
;; Note that this is a singly-binding form of let-values. Also
;; note that Scheme's let-values expands into call-with-values,
;; then here we reduce it to tree-il's let-values.
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-values)
(= (length args) 2)
(lambda? (cadr args)))
(let ((producer (car args))
(consumer (cadr args)))
(make-let-values src
(lambda-names consumer)
(lambda-vars consumer)
(if (and (lambda? producer)
(null? (lambda-names producer)))
(lambda-body producer)
(make-application src producer '()))
(lambda-body consumer))))
(else #f)))
(else #f)))
x))

3
module/srfi/srfi-11.scm
View file

@ -67,6 +67,9 @@
(define-syntax let-values
(lambda (x)
(syntax-case x ()
((_ ((binds exp)) b0 b1 ...)
(syntax (call-with-values (lambda () exp)
(lambda binds b0 b1 ...))))
((_ (clause ...) b0 b1 ...)
(let lp ((clauses (syntax (clause ...)))
(ids '())