From 822d815965da538faade8a5508c54b4bd8497d1a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Jan 2024 20:11:34 -0700 Subject: [PATCH] adjust cp0 to combine `begin` rotation and variable dropping (#796) A follow-up to c081296367, this commit adjusts the cp0 change to avoid skipping the variable-dropping rewrite when the `begin` rotation applies. This combination passes the new test, passes old tests with small adjustments, and allows Racket to pass some tests that are similar to "cp0.ms" tests. Meanwhile, c081296367 should have noted the PR (#789) it squashes and some author information that was lost in the squash: Co-authored-by: R. Kent Dybvig Co-authored-by: Oscar Waddell --- mats/record.ms | 80 ++++++++++++++++++++++++++++++++++++++++++++++---- s/cp0.ss | 23 ++++++++------- 2 files changed, 87 insertions(+), 16 deletions(-) diff --git a/mats/record.ms b/mats/record.ms index 6dbc1bc6c..08b34aff5 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -9008,10 +9008,9 @@ (new q x))))))) (make-foo 3)))) `(let ([ctr 0]) - (letrec ([g0 (lambda (new) (lambda (q) (set! ctr (#2%+ 1 xtr)) (new q ctr)))]) + (letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))]) (#3%$value (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)) - (set! ctr (#2%+ 1 xtr)) - (#3%$record ',record-type-descriptor? 3 ctr)))) + (#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#2%+ 1 xtr)) ctr))))) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize @@ -9028,10 +9027,9 @@ (new q x))))))) (make-foo 3)))) `(let ([ctr 0]) - (letrec ([g0 (lambda (new) (lambda (q) (set! ctr (#3%+ 1 xtr)) (new q ctr)))]) + (letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))]) (#3%$value (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)) - (set! ctr (#3%+ 1 xtr)) - (#3%$record ',record-type-descriptor? 3 ctr)))) + (#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#3%+ 1 xtr)) ctr))))) (error? ; invalid uid (let () (define useless @@ -9051,6 +9049,76 @@ (foo-x (make-foo 3.0 y)))) #t) (equal? ($foo 17) 3.0) + ;; two regression tests as extra confirmation that `begin` rotation and let-binding + ;; dropping work together ok + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(lambda (instance) + (define-record-type instance-variable-reference + (fields inst kind)) + (define (variable-reference-constant? v) + (eq? (instance-variable-reference-kind v) 'constant)) + (lambda (x_1 y_2 f_3) + (begin + (set! x_1 5) + (let ([app_6 (variable-reference-constant? + (letrec* ([z_4 (let ([z (lambda () z_4)]) z)]) + (begin + (f_3 z_4) + (make-instance-variable-reference + instance + 'mutable))))]) + (list #f #t app_6 + (variable-reference-constant? + (letrec* ([z_5 (let ([z (lambda () z_5)]) intentionally-free-x)]) + (begin + (f_3 z_5) + (make-instance-variable-reference + instance + 'constant))))))))))) + '(lambda (instance) + (let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'instance-variable-reference #f #f #f #f + '#((immutable inst) (immutable kind)) 'define-record-type)]) + (lambda (x_1 y_2 f_3) + (letrec ([z_4 (lambda () z_4)]) + (f_3 z_4) + (let ([z_5 intentionally-free-x]) + (f_3 z_5) + (#2%list #f #t #f #t))))))) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record variable-reference + (inst var-or-info)) + (define (variable-reference-constant? v) + (eq? (variable-reference-var-or-info v) 'constant)) + (lambda (instance-variable-reference) + (lambda (x_1 y_2 f_3) + (begin + (set! x_1 5) + (let ([app_6 (variable-reference-constant? + (letrec* ([z_4 (lambda () z_4)]) + (begin + (f_3 z_4) + (make-variable-reference + instance-variable-reference + 'mutable))))]) + (list app_4 app_5 #f #t app_6 + (variable-reference-constant? + (letrec* ([z_5 (lambda () z_5)]) + (begin + (f_3 z_5) + (make-variable-reference + instance-variable-reference + 'constant)))))))))))) + '(lambda (instance-variable-reference) + (lambda (x_1 y_2 f_3) + (letrec ([z_4 (lambda () z_4)]) + (f_3 z_4) + (letrec ([z_5 (lambda () z_5)]) + (#3%list app_4 app_5 #f #t #f (begin (f_3 z_5) #t))))))) ) (mat cp0-rtd-inspection-optimizations diff --git a/s/cp0.ss b/s/cp0.ss index a27908c67..672a5a654 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -1673,6 +1673,17 @@ [(apply2) (values)] [(apply3) (find-apply-lambda-clause exp (app-opnds ctxt))]))) + (define (build-let-help lambda-preinfo id* rhs* body) + (or (and (= (length id*) 1) + (= (length rhs*) 1) + (nanopass-case (Lsrc Expr) (car rhs*) + [(seq ,e1 ,e2) + ; (let ((x (begin e1 e2))) e3) => (begin e1 (let ((x e2)) e3)) + ; this can expose (immutable-vector ...) in e2 to optimization + `(seq ,e1 ,(build-let lambda-preinfo id* (list e2) body))] + [else #f])) + (build-let lambda-preinfo id* rhs* body))) + (define letify (case-lambda [(lambda-preinfo id* ctxt body) (letify lambda-preinfo id* ctxt '() body)] @@ -1705,14 +1716,6 @@ ; (let ((x e)) x) => e ; x is clearly not assigned, even if flags are polluted and say it is (make-nontail (app-ctxt ctxt) (car rhs*))] - [(and (= (length id*) 1) - (= (length rhs*) 1) - (nanopass-case (Lsrc Expr) (car rhs*) - [(seq ,e1 ,e2) - ; (let ((x (begin e1 e2))) e3) => (begin e1 (let ((x e2)) e3)) - ; this can expose (immutable-vector ...) in e2 to optimization - `(seq ,e1 ,(build-let lambda-preinfo id* (list e2) body))] - [else #f]))] ; we drop the RHS of a let binding into the let body when the body expression is a call ; and we can do so without violating evaluation order of bindings wrt the let body: ; * for pure, singly referenced bindings, we drop them to the variable reference site @@ -1794,7 +1797,7 @@ (lambda (new-e* . ignore) (let ([body (if (andmap eq? new-e* e*) body (build-body (car new-e*) (cdr new-e*)))]) (let ([alist (filter cdr alist)]) - (if (null? alist) body (build-let lambda-preinfo (map car alist) (map cdr alist) body))))))))) + (if (null? alist) body (build-let-help lambda-preinfo (map car alist) (map cdr alist) body))))))))) (nanopass-case (Lsrc Expr) body [(call ,preinfo ,e ,e* ...) (drop-let (cons e e*) (lambda (e e*) (build-call preinfo e e*)))] @@ -1807,7 +1810,7 @@ [(record-type ,rtd ,e) (drop-let (list e) (lambda (e e*) (safe-assert (null? e*)) `(record-type ,rtd ,e)))] [else #f])))] - [else (build-let lambda-preinfo id* rhs* body)]))))])) + [else (build-let-help lambda-preinfo id* rhs* body)]))))])) (define cp0-let (lambda (lambda-preinfo ids body ctxt env sc wd name moi)