diff options
-rw-r--r-- | module/language/tree-il/peval.scm | 98 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 29 |
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) |