summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-02-15 14:15:15 +0100
committerAndy Wingo <wingo@pobox.com>2013-02-15 14:15:19 +0100
commit8598dd8d28d16fe1ec92dfc49f6517992f1598ec (patch)
treeb489a1e53c810514c69b36cbefa4267feb77d362
parentd21537efb4a0edea30a7ab801909207d4bb69030 (diff)
downloadguile-8598dd8d28d16fe1ec92dfc49f6517992f1598ec.tar.gz
more rest argument inlining improvements
* module/language/tree-il/peval.scm (peval): Correct comment on find-definition, and allow a find-definition to fall back on a source expression. Avoid copying non-constant expressions. * test-suite/tests/peval.test ("partial evaluation"): Add a test that inlining rest arguments works with complicated argument expressions, and a test that order of effects in rest args is preserved.
-rw-r--r--module/language/tree-il/peval.scm19
-rw-r--r--test-suite/tests/peval.test71
2 files changed, 85 insertions, 5 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index e25a199a8..b21aa7e7a 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -709,8 +709,9 @@ top-level bindings from ENV and return the resulting expression."
;; some special cases like `apply' or prompts if we can account
;; for all of its uses.
;;
- ;; You don't want to use this in general because it doesn't run the full
- ;; partial evaluator, so it doesn't fold constant expressions, etc.
+ ;; You don't want to use this in general because it introduces a slight
+ ;; nonlinearity by running peval again (though with a small effort and size
+ ;; counter).
;;
(define (find-definition x n-aliases)
(cond
@@ -719,7 +720,8 @@ top-level bindings from ENV and return the resulting expression."
((lookup (lexical-ref-gensym x))
=> (lambda (op)
(let ((y (or (operand-residual-value op)
- (visit-operand op counter 'value 10 10))))
+ (visit-operand op counter 'value 10 10)
+ (operand-source op))))
(cond
((and (lexical-ref? y)
(= (lexical-refcount (lexical-ref-gensym x)) 1))
@@ -1148,15 +1150,22 @@ top-level bindings from ENV and return the resulting expression."
(($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply)))
(proc args ... tail))
(let lp ((tail* (find-definition tail 1)) (speculative? #t))
+ (define (copyable? x)
+ ;; Inlining a result from find-definition effectively copies it,
+ ;; relying on the let-pruning to remove its original binding. We
+ ;; shouldn't copy non-constant expressions.
+ (or (not speculative?) (constant-expression? x)))
(match tail*
(($ <const> _ (args* ...))
(let ((args* (map (cut make-const #f <>) args*)))
(for-tail (make-application src proc (append args args*)))))
- (($ <application> _ ($ <primitive-ref> _ 'cons) (head tail))
+ (($ <application> _ ($ <primitive-ref> _ 'cons)
+ ((and head (? copyable?)) (and tail (? copyable?))))
(for-tail (make-application src apply
(cons proc
(append args (list head tail))))))
- (($ <application> _ ($ <primitive-ref> _ 'list) args*)
+ (($ <application> _ ($ <primitive-ref> _ 'list)
+ (and args* ((? copyable?) ...)))
(for-tail (make-application src proc (append args args*))))
(tail*
(if speculative?
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 01164e4cf..bbf74e35c 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -25,6 +25,7 @@
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (language glil)
+ #:use-module (rnrs bytevectors) ;; for the bytevector primitives
#:use-module (srfi srfi-13))
(define peval
@@ -879,6 +880,76 @@
(const 1)
(lexical args _)))))
+ (pass-if-peval resolve-primitives
+ ;; Here the `args' that gets built by the application of the lambda
+ ;; takes more than effort "10" to visit. Test that we fall back to
+ ;; the source expression of the operand, which is still a call to
+ ;; `list', so the inlining still happens.
+ (lambda (bv offset n)
+ (let ((x (bytevector-ieee-single-native-ref
+ bv
+ (+ offset 0)))
+ (y (bytevector-ieee-single-native-ref
+ bv
+ (+ offset 4))))
+ (let ((args (list x y)))
+ (@apply
+ (lambda (bv offset x y)
+ (bytevector-ieee-single-native-set!
+ bv
+ (+ offset 0)
+ x)
+ (bytevector-ieee-single-native-set!
+ bv
+ (+ offset 4)
+ y))
+ bv
+ offset
+ args))))
+ (lambda ()
+ (lambda-case
+ (((bv offset n) #f #f #f () (_ _ _))
+ (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref)
+ (lexical bv _)
+ (apply (primitive +)
+ (lexical offset _) (const 0)))
+ (apply (primitive bytevector-ieee-single-native-ref)
+ (lexical bv _)
+ (apply (primitive +)
+ (lexical offset _) (const 4))))
+ (begin
+ (apply (primitive bytevector-ieee-single-native-set!)
+ (lexical bv _)
+ (apply (primitive +)
+ (lexical offset _) (const 0))
+ (lexical x _))
+ (apply (primitive bytevector-ieee-single-native-set!)
+ (lexical bv _)
+ (apply (primitive +)
+ (lexical offset _) (const 4))
+ (lexical y _))))))))
+
+ (pass-if-peval resolve-primitives
+ ;; Here we ensure that non-constant expressions are not copied.
+ (lambda ()
+ (let ((args (list (foo!))))
+ (@apply
+ (lambda (z x)
+ (list z x))
+ ;; This toplevel ref might raise an unbound variable exception.
+ ;; The effects of `(foo!)' must be visible before this effect.
+ z
+ args)))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
+ (let (args) (_)
+ ((apply (primitive list) (apply (toplevel foo!))))
+ (apply (primitive @apply)
+ (lambda . _)
+ (toplevel z)
+ (lexical args _)))))))
+
(pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)