Skip to content

Commit

Permalink
adjust cp0 to combine begin rotation and variable dropping (#796)
Browse files Browse the repository at this point in the history 
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 (#789) it squashes and
some author information that was lost in the squash:
Co-authored-by: R. Kent Dybvig <dyb@scheme.com>

Co-authored-by: Oscar Waddell <owaddell@beckman.com>
  • Loading branch information
@mflatt @owaddell-beckman
mflatt and owaddell-beckman authored Jan 31, 2024
1 parent c081296 commit 822d815
Show file tree
Hide file tree
Showing 2 changed files with 87 additions and 16 deletions.
80 changes: 74 additions & 6 deletions mats/record.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
23 changes: 13 additions & 10 deletions s/cp0.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)]
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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*)))]
Expand All @@ -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)
Expand Down

0 comments on commit 822d815

Please sign in to comment.