summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/peval.scm98
-rw-r--r--test-suite/tests/peval.test29
2 files changed, 87 insertions, 40 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 6773dff4a..e25a199a8 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -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)))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index fdae7b10a..01164e4cf 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -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)