summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-06-17 19:30:31 +0200
committerAndy Wingo <wingo@pobox.com>2011-06-17 19:42:55 +0200
commitb88fef5519fab447c6c5405928c248f9f0966148 (patch)
tree0252cd8f1b31c733f62486a1f5852ba206248ab6
parentf86f748db26eba15ca71e65b3e084a2fcbf8c3ac (diff)
downloadguile-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.scm24
-rw-r--r--module/language/tree-il/primitives.scm10
-rw-r--r--test-suite/tests/tree-il.test20
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"