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

more rest argument inlining improvements

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-02-15 14:15:15 +01:00
parent d21537efb4
commit 8598dd8d28
2 changed files with 85 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

19
module/language/tree-il/peval.scm
View file

@ -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?

71
test-suite/tests/peval.test
View file

@ -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)