diff options
author | Andy Wingo <wingo@pobox.com> | 2013-02-15 14:15:15 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-02-15 14:15:19 +0100 |
commit | 8598dd8d28d16fe1ec92dfc49f6517992f1598ec (patch) | |
tree | b489a1e53c810514c69b36cbefa4267feb77d362 | |
parent | d21537efb4a0edea30a7ab801909207d4bb69030 (diff) | |
download | guile-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.scm | 19 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 71 |
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) |