Skip to content

Commit 0a6b572

Browse files
owaddell-beckmandybvig
authored and
mflatt
committed
adjust cp0 to combine begin rotation and variable dropping
A follow-up to c081296, 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, c081296 should have noted the PR (cisco#789) it squashes and some author information that was lost in the squash: Co-authored-by: R. Kent Dybvig <dyb@scheme.com>
1 parent c081296 commit 0a6b572

File tree

2 files changed

+87
-16
lines changed

2 files changed

+87
-16
lines changed

‎mats/record.ms

+74-6
Original file line numberDiff line numberDiff line change
@@ -9008,10 +9008,9 @@
90089008
(new q x)))))))
90099009
(make-foo 3))))
90109010
`(let ([ctr 0])
9011-
(letrec ([g0 (lambda (new) (lambda (q) (set! ctr (#2%+ 1 xtr)) (new q ctr)))])
9011+
(letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))])
90129012
(#3%$value (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type))
9013-
(set! ctr (#2%+ 1 xtr))
9014-
(#3%$record ',record-type-descriptor? 3 ctr))))
9013+
(#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#2%+ 1 xtr)) ctr)))))
90159014
(equivalent-expansion?
90169015
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
90179016
(expand/optimize
@@ -9028,10 +9027,9 @@
90289027
(new q x)))))))
90299028
(make-foo 3))))
90309029
`(let ([ctr 0])
9031-
(letrec ([g0 (lambda (new) (lambda (q) (set! ctr (#3%+ 1 xtr)) (new q ctr)))])
9030+
(letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))])
90329031
(#3%$value (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type))
9033-
(set! ctr (#3%+ 1 xtr))
9034-
(#3%$record ',record-type-descriptor? 3 ctr))))
9032+
(#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#3%+ 1 xtr)) ctr)))))
90359033
(error? ; invalid uid
90369034
(let ()
90379035
(define useless
@@ -9051,6 +9049,76 @@
90519049
(foo-x (make-foo 3.0 y))))
90529050
#t)
90539051
(equal? ($foo 17) 3.0)
9052+
;; two regression tests as extra confirmation that `begin` rotation and let-binding
9053+
;; dropping work together ok
9054+
(equivalent-expansion?
9055+
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
9056+
(expand/optimize
9057+
'(lambda (instance)
9058+
(define-record-type instance-variable-reference
9059+
(fields inst kind))
9060+
(define (variable-reference-constant? v)
9061+
(eq? (instance-variable-reference-kind v) 'constant))
9062+
(lambda (x_1 y_2 f_3)
9063+
(begin
9064+
(set! x_1 5)
9065+
(let ([app_6 (variable-reference-constant?
9066+
(letrec* ([z_4 (let ([z (lambda () z_4)]) z)])
9067+
(begin
9068+
(f_3 z_4)
9069+
(make-instance-variable-reference
9070+
instance
9071+
'mutable))))])
9072+
(list #f #t app_6
9073+
(variable-reference-constant?
9074+
(letrec* ([z_5 (let ([z (lambda () z_5)]) intentionally-free-x)])
9075+
(begin
9076+
(f_3 z_5)
9077+
(make-instance-variable-reference
9078+
instance
9079+
'constant)))))))))))
9080+
'(lambda (instance)
9081+
(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'instance-variable-reference #f #f #f #f
9082+
'#((immutable inst) (immutable kind)) 'define-record-type)])
9083+
(lambda (x_1 y_2 f_3)
9084+
(letrec ([z_4 (lambda () z_4)])
9085+
(f_3 z_4)
9086+
(let ([z_5 intentionally-free-x])
9087+
(f_3 z_5)
9088+
(#2%list #f #t #f #t)))))))
9089+
(equivalent-expansion?
9090+
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
9091+
(expand/optimize
9092+
'(let ()
9093+
(define-record variable-reference
9094+
(inst var-or-info))
9095+
(define (variable-reference-constant? v)
9096+
(eq? (variable-reference-var-or-info v) 'constant))
9097+
(lambda (instance-variable-reference)
9098+
(lambda (x_1 y_2 f_3)
9099+
(begin
9100+
(set! x_1 5)
9101+
(let ([app_6 (variable-reference-constant?
9102+
(letrec* ([z_4 (lambda () z_4)])
9103+
(begin
9104+
(f_3 z_4)
9105+
(make-variable-reference
9106+
instance-variable-reference
9107+
'mutable))))])
9108+
(list app_4 app_5 #f #t app_6
9109+
(variable-reference-constant?
9110+
(letrec* ([z_5 (lambda () z_5)])
9111+
(begin
9112+
(f_3 z_5)
9113+
(make-variable-reference
9114+
instance-variable-reference
9115+
'constant))))))))))))
9116+
'(lambda (instance-variable-reference)
9117+
(lambda (x_1 y_2 f_3)
9118+
(letrec ([z_4 (lambda () z_4)])
9119+
(f_3 z_4)
9120+
(letrec ([z_5 (lambda () z_5)])
9121+
(#3%list app_4 app_5 #f #t #f (begin (f_3 z_5) #t)))))))
90549122
)
90559123
90569124
(mat cp0-rtd-inspection-optimizations

‎s/cp0.ss

+13-10
Original file line numberDiff line numberDiff line change
@@ -1673,6 +1673,17 @@
16731673
[(apply2) (values)]
16741674
[(apply3) (find-apply-lambda-clause exp (app-opnds ctxt))])))
16751675

1676+
(define (build-let-help lambda-preinfo id* rhs* body)
1677+
(or (and (= (length id*) 1)
1678+
(= (length rhs*) 1)
1679+
(nanopass-case (Lsrc Expr) (car rhs*)
1680+
[(seq ,e1 ,e2)
1681+
; (let ((x (begin e1 e2))) e3) => (begin e1 (let ((x e2)) e3))
1682+
; this can expose (immutable-vector ...) in e2 to optimization
1683+
`(seq ,e1 ,(build-let lambda-preinfo id* (list e2) body))]
1684+
[else #f]))
1685+
(build-let lambda-preinfo id* rhs* body)))
1686+
16761687
(define letify
16771688
(case-lambda
16781689
[(lambda-preinfo id* ctxt body) (letify lambda-preinfo id* ctxt '() body)]
@@ -1705,14 +1716,6 @@
17051716
; (let ((x e)) x) => e
17061717
; x is clearly not assigned, even if flags are polluted and say it is
17071718
(make-nontail (app-ctxt ctxt) (car rhs*))]
1708-
[(and (= (length id*) 1)
1709-
(= (length rhs*) 1)
1710-
(nanopass-case (Lsrc Expr) (car rhs*)
1711-
[(seq ,e1 ,e2)
1712-
; (let ((x (begin e1 e2))) e3) => (begin e1 (let ((x e2)) e3))
1713-
; this can expose (immutable-vector ...) in e2 to optimization
1714-
`(seq ,e1 ,(build-let lambda-preinfo id* (list e2) body))]
1715-
[else #f]))]
17161719
; we drop the RHS of a let binding into the let body when the body expression is a call
17171720
; and we can do so without violating evaluation order of bindings wrt the let body:
17181721
; * for pure, singly referenced bindings, we drop them to the variable reference site
@@ -1794,7 +1797,7 @@
17941797
(lambda (new-e* . ignore)
17951798
(let ([body (if (andmap eq? new-e* e*) body (build-body (car new-e*) (cdr new-e*)))])
17961799
(let ([alist (filter cdr alist)])
1797-
(if (null? alist) body (build-let lambda-preinfo (map car alist) (map cdr alist) body)))))))))
1800+
(if (null? alist) body (build-let-help lambda-preinfo (map car alist) (map cdr alist) body)))))))))
17981801
(nanopass-case (Lsrc Expr) body
17991802
[(call ,preinfo ,e ,e* ...)
18001803
(drop-let (cons e e*) (lambda (e e*) (build-call preinfo e e*)))]
@@ -1807,7 +1810,7 @@
18071810
[(record-type ,rtd ,e)
18081811
(drop-let (list e) (lambda (e e*) (safe-assert (null? e*)) `(record-type ,rtd ,e)))]
18091812
[else #f])))]
1810-
[else (build-let lambda-preinfo id* rhs* body)]))))]))
1813+
[else (build-let-help lambda-preinfo id* rhs* body)]))))]))
18111814

18121815
(define cp0-let
18131816
(lambda (lambda-preinfo ids body ctxt env sc wd name moi)

0 commit comments

Comments
 (0)