diff options
author | Andy Wingo <wingo@pobox.com> | 2011-06-17 19:30:31 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-06-17 19:42:55 +0200 |
commit | b88fef5519fab447c6c5405928c248f9f0966148 (patch) | |
tree | 0252cd8f1b31c733f62486a1f5852ba206248ab6 | |
parent | f86f748db26eba15ca71e65b3e084a2fcbf8c3ac (diff) | |
download | guile-b88fef5519fab447c6c5405928c248f9f0966148.tar.gz |
fix invalid transformation of (values x) -> x, (+ x) -> x, etc
* module/language/tree-il/primitives.scm (+, *, cons*): In the case of
just one argument (the identity case), expand to (values x) instead of
just x. Fixes values truncation in that case.
(values): Likewise remove (values x) -> x translation, as the compiler
will do it for us, and this fixes (values (values 1 2)).
* module/language/tree-il/compile-glil.scm (flatten-lambda-case): Handle
`values' in a push context here.
* test-suite/tests/tree-il.test ("values"): Add some tests.
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 24 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 10 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 20 |
3 files changed, 45 insertions, 9 deletions
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index b137afacf..518823d11 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -305,21 +305,39 @@ (cons proc args))) (maybe-emit-return))))))) - ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) - (not (eq? context 'push))) + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)) ;; 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) (maybe-emit-return)) + ((push) + (case (length args) + ((0) + ;; FIXME: This is surely an error. We need to add a + ;; values-mismatch warning pass. + (emit-code src (make-glil-call 'new-frame 0)) + (comp-push proc) + (emit-code src (make-glil-call 'call 0)) + (maybe-emit-return)) + ((1) + (comp-push (car args))) + (else + ;; Taking advantage of unspecified order of evaluation of + ;; arguments. + (for-each comp-drop (cdr args)) + (comp-push (car args))))) ((vals) (for-each comp-push args) (emit-code #f (make-glil-const (length args))) (emit-branch src 'br MVRA)) ((tail) (for-each comp-push args) - (emit-code src (make-glil-call 'return/values (length args)))))) + (emit-code src (let ((len (length args))) + (if (= len 1) + (make-glil-call 'return 1) + (make-glil-call 'return/values len))))))) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) '@call-with-values) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 316a4628e..d21fc734d 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -1,6 +1,6 @@ ;;; open-coding primitive procedures -;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -248,7 +248,7 @@ (define-primitive-expander + () 0 - (x) x + (x) (values x) (x y) (if (and (const? y) (let ((y (const-exp y))) (and (number? y) (exact? y) (= y 1)))) @@ -266,7 +266,7 @@ (define-primitive-expander * () 1 - (x) x + (x) (values x) (x y z . rest) (* x (* y z . rest))) (define-primitive-expander - @@ -312,7 +312,7 @@ (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) (define-primitive-expander cons* - (x) x + (x) (values x) (x y) (cons x y) (x y . rest) (cons x (cons* y . rest))) @@ -331,8 +331,6 @@ (define-primitive-expander call/cc (proc) (@call-with-current-continuation proc)) -(define-primitive-expander values (x) x) - (define-primitive-expander make-struct (vtable tail-size . args) (if (and (const? tail-size) (let ((n (const-exp tail-size))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 1b86b99fc..2dce471b5 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -474,6 +474,26 @@ (program () (std-prelude 0 0 #f) (label _) (const 2) (call null? 1) (call return 1)))) +(with-test-prefix "values" + (assert-tree-il->glil + (apply (primitive values) + (apply (primitive values) (const 1) (const 2))) + (program () (std-prelude 0 0 #f) (label _) + (const 1) (call return 1))) + + (assert-tree-il->glil + (apply (primitive values) + (apply (primitive values) (const 1) (const 2)) + (const 3)) + (program () (std-prelude 0 0 #f) (label _) + (const 1) (const 3) (call return/values 2))) + + (assert-tree-il->glil + (apply (primitive +) + (apply (primitive values) (const 1) (const 2))) + (program () (std-prelude 0 0 #f) (label _) + (const 1) (call return 1)))) + ;; FIXME: binding info for or-hacked locals might bork the disassembler, ;; and could be tightened in any case (with-test-prefix "the or hack" |