diff --git a/mats/record.ms b/mats/record.ms index 2cb281024e..1794153a62 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -9044,3 +9044,114 @@ (#2%list #t #t) (#2%list #f (#2%record-type-sealed? rtd)))))) ) + +(mat cp0-kar-kons-$record-ref-optimizations + (eq? (let () + (define-record kons (kar kdr)) + (#3%$record-ref (make-kons 'a 'b) 0)) + 'a) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (#3%$record-ref (make-kons 'a 'b) 0)))) + ''a) + (eq? (let () + (define-record kons (kar kdr)) + (#3%$record-ref (make-kons 'a 'b) 1)) + 'b) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (#3%$record-ref (make-kons 'a 'b) 1)))) + ''b) + + (equal? + (with-output-to-string + (lambda () + (define-record kons (kar kdr)) + (display (#3%$record-ref (make-kons (begin (display 1) (display 2) 3) + (begin (display 4) (display 5) 6)) + 0)))) + "45123") ;"12453" is also correct + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (display (#3%$record-ref (make-kons (begin (display 1) (display 2) 3) + (begin (display 4) (display 5) 6)) + 0))))) + '(#2%display + (begin + (#2%display 4) + (#2%display 5) + (#2%display 1) + (#2%display 2) + 3))) + (equal? + (with-output-to-string + (lambda () + (define-record kons (kar kdr)) + (display (#3%$record-ref (make-kons (begin (display 1) (display 2) 3) + (begin (display 4) (display 5) 6)) + 1)))) + "45126") ;"12456" is also correct + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (display (#3%$record-ref (make-kons (begin (display 1) (display 2) 3) + (begin (display 4) (display 5) 6)) + 1))))) + '(#2%display + (begin + (#2%display 4) + (#2%display 5) + (#2%display 1) + (#2%display 2) + 6))) + + (equal? + (with-output-to-string + (lambda () + (define-record kons (kar kdr)) + (display (#3%$record-ref (begin (display 1) (make-kons 2 3)) + (begin (display 4) 0))))) + "412") ;"142" is also correct + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (display (#3%$record-ref (begin (display 1) (make-kons 2 3)) + (begin (display 4) 0)))))) + '(#2%display + (begin + (#2%display 4) + (#2%display 1) + 2))) + (equal? + (with-output-to-string + (lambda () + (define-record kons (kar kdr)) + (display (#3%$record-ref (begin (display 1) (make-kons 2 3)) + (begin (display 4) 1))))) + "413") ;"143" is also correct + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (display (#3%$record-ref (begin (display 1) (make-kons 2 3)) + (begin (display 4) 1)))))) + '(#2%display + (begin + (#2%display 4) + (#2%display 1) + 3))) +) diff --git a/s/cp0.ss b/s/cp0.ss index 6bfc7b5e02..1218af40ed 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3828,6 +3828,32 @@ `(record ,rtd ,rtd-expr ,(map value-visit-operand! ?e*) ...))] [else #f]))]) + (define-inline 3 $record-ref + [(?r ?i) + (let ([i-expr (value-visit-operand! ?i)]) + (nanopass-case (Lsrc Expr) (result-exp i-expr) + [(quote ,d) + (guard (and (fixnum? d) (fx>= d 0))) + (let ([r-expr (value-visit-operand! ?r)]) + (nanopass-case (Lsrc Expr) (result-exp r-expr) + [(record ,rtd1 ,rtd-expr1 ,e* ...) + (let loop ([e* e*] [re* '()] [index d]) + (and (not (null? e*)) + (if (fx= index 0) + (let ([e (car e*)] [e* (rappend re* (cdr e*))]) + (define main (if (null? e*) + (make-nontail ctxt e) + (make-1seq ctxt + (make-seq* 'ignored e*) + (make-nontail ctxt e)))) + (residualize-seq (list ?r ?i) '() ctxt) + (non-result-exp i-expr + (non-result-exp r-expr + main))) + (loop (cdr e*) (cons (car e*) re*) (fx- index 1)))))] + [else #f]))] + [else #f]))]) + (let () (define null-rec? (lambda (?ls) diff --git a/s/primdata.ss b/s/primdata.ss index f3e4f6b058..685cb3e74f 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -2197,7 +2197,7 @@ ($record-equal-procedure [flags discard]) ($record-hash-procedure [flags discard]) ($record-oops #;[sig [(who sub-ptr rtd) -> (bottom)]] [flags abort-op]) - ($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags mifoldable discard]) + ($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags mifoldable discard cp03]) ($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true]) ($record-type-descriptor [flags pure mifoldable discard true]) ($record-type-field-offsets [flags pure mifoldable discard true])