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

better inlining of `apply' with rest arguments

Browse source 
* module/language/tree-il/peval.scm (peval): Move up the find-definition
  helper.  Use it to speculatively destructure conses and lists into the
  tail position of an `apply' form.

* test-suite/tests/peval.test ("partial evaluation"): Add tests.
This commit is contained in:
Andy Wingo 2013-02-15 12:11:29 +01:00
parent 564f5e7054
commit d21537efb4
2 changed files with 87 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -703,6 +703,47 @@ top-level bindings from ENV and return the resulting expression."
((vhash-assq var env) => cdr)
(else (error "unbound var" var))))
;; Find a value referenced a specific number of times. This is a hack
;; that's used for propagating fresh data structures like rest lists and
;; prompt tags. Usually we wouldn't copy consed data, but we can do so in
;; 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.
;;
(define (find-definition x n-aliases)
(cond
((lexical-ref? x)
(cond
((lookup (lexical-ref-gensym x))
=> (lambda (op)
(let ((y (or (operand-residual-value op)
(visit-operand op counter 'value 10 10))))
(cond
((and (lexical-ref? y)
(= (lexical-refcount (lexical-ref-gensym x)) 1))
;; X is a simple alias for Y. Recurse, regardless of
;; the number of aliases we were expecting.
(find-definition y n-aliases))
((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
;; We found a definition that is aliased the right
;; number of times. We still recurse in case it is a
;; lexical.
(values (find-definition y 1)
op))
(else
;; We can't account for our aliases.
(values #f #f))))))
(else
;; A formal parameter. Can't say anything about that.
(values #f #f))))
((= n-aliases 1)
;; Not a lexical: success, but only if we are looking for an
;; unaliased value.
(values x #f))
(else (values #f #f))))
(define (visit exp ctx)
(loop exp env counter ctx))
@ -1106,15 +1147,23 @@ top-level bindings from ENV and return the resulting expression."
(make-application src (make-primitive-ref #f 'values) vals))))))
(($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply)))
(proc args ... tail))
(match (for-value tail)
(($ <const> _ (args* ...))
(let ((args* (map (lambda (x) (make-const #f x)) args*)))
(for-tail (make-application src proc (append args args*)))))
(($ <application> _ ($ <primitive-ref> _ 'list) args*)
(for-tail (make-application src proc (append args args*))))
(tail
(let ((args (append (map for-value args) (list tail))))
(make-application src apply (cons (for-value proc) args))))))
(let lp ((tail* (find-definition tail 1)) (speculative? #t))
(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))
(for-tail (make-application src apply
(cons proc
(append args (list head tail))))))
(($ <application> _ ($ <primitive-ref> _ 'list) args*)
(for-tail (make-application src proc (append args args*))))
(tail*
(if speculative?
(lp (for-value tail) #f)
(let ((args (append (map for-value args) (list tail*))))
(make-application src apply
(cons (for-value proc) args))))))))
(($ <application> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let revisit-proc ((proc (visit orig-proc 'operator)))
@ -1408,37 +1457,6 @@ top-level bindings from ENV and return the resulting expression."
(or () ((? constant-expression?))))
#t)
(_ #f)))
(define (find-definition x n-aliases)
(cond
((lexical-ref? x)
(cond
((lookup (lexical-ref-gensym x))
=> (lambda (op)
(let ((y (or (operand-residual-value op)
(visit-operand op counter 'value 10 10))))
(cond
((and (lexical-ref? y)
(= (lexical-refcount (lexical-ref-gensym x)) 1))
;; X is a simple alias for Y. Recurse, regardless of
;; the number of aliases we were expecting.
(find-definition y n-aliases))
((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
;; We found a definition that is aliased the right
;; number of times. We still recurse in case it is a
;; lexical.
(values (find-definition y 1)
op))
(else
;; We can't account for our aliases.
(values #f #f))))))
(else
;; A formal parameter. Can't say anything about that.
(values #f #f))))
((= n-aliases 1)
;; Not a lexical: success, but only if we are looking for an
;; unaliased value.
(values x #f))
(else (values #f #f))))
(let ((tag (for-value tag))
(body (for-tail body)))

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

@ -850,6 +850,35 @@
(let (z) (_) ((apply (primitive list) (const 3) (const 4)))
(apply (primitive list) (const 1) (const 2) (lexical z _))))
(pass-if-peval resolve-primitives
;; Unmutated lists can get inlined.
(let ((args (list 2 3)))
(apply (lambda (x y z w)
(list x y z w))
0 1 args))
(apply (primitive list) (const 0) (const 1) (const 2) (const 3)))
(pass-if-peval resolve-primitives
;; However if the list might have been mutated, it doesn't propagate.
(let ((args (list 2 3)))
(foo! args)
(apply (lambda (x y z w)
(list x y z w))
0 1 args))
(let (args) (_) ((apply (primitive list) (const 2) (const 3)))
(begin
(apply (toplevel foo!) (lexical args _))
(apply (primitive @apply)
(lambda ()
(lambda-case
(((x y z w) #f #f #f () (_ _ _ _))
(apply (primitive list)
(lexical x _) (lexical y _)
(lexical z _) (lexical w _)))))
(const 0)
(const 1)
(lexical args _)))))
(pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)