From 5c50c5d1c520c79035065b4bd977eadd8e4cb800 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Tue, 16 Apr 2019 15:19:11 -0300 Subject: [PATCH] Fix record-ref reduction in cp0 In expressions like (record-ref ... (begin (newline) (record ...))) the reduction was dropping the possible side effect expressions in this case the (newline). cp0.ss --- LOG | 6 +++ mats/record.ms | 134 +++++++++++++++++++++++++++++++++++++++++++++++++ s/cp0.ss | 25 ++++----- 3 files changed, 153 insertions(+), 12 deletions(-) diff --git a/LOG b/LOG index 4e7091df9..a37984693 100644 --- a/LOG +++ b/LOG @@ -1337,3 +1337,9 @@ externs.h, compress-io.c, new-io.c, scheme.c, fasl.c - added entries for mutex-name and mutex-thread threads.stex +- fix record-ref reduction in cp0 + in expressions like + (record-ref ... (begin (newline) (record ...))) + the reduction was dropping the possible side effect expressions + in this case the (newline). + cp0.ss diff --git a/mats/record.ms b/mats/record.ms index c8aa0dcf1..f2884a6b4 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -9051,3 +9051,137 @@ (#2%list #t #t) (#2%list #f (#2%record-type-sealed? rtd)))))) ) + +(define (cp0x3 cp0 x) + (cp0 (cp0 (cp0 x)))) + +(define (member? o l) + (and (member o l) #t)) + +(mat cp0-kar-kons-optimizations + ; for now, it's necesary to run cp0 three times to complete the reduction + (equal? + (with-output-to-string + (lambda () + (define-record mybox (val)) + (display (mybox-val (begin (display 1) (make-mybox 2)))))) + "12") + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record mybox (val)) + (display (mybox-val (begin (display 1) (make-mybox 2))))))) + '(#2%display + (begin + (#2%display 1) + 2))) + (eq? (let () + (define-record kons (kar kdr)) + (kons-kar (make-kons 'a 'b))) + 'a) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (kons-kar (make-kons 'a 'b))))) + ''a) + (eq? (let () + (define-record kons (kar kdr)) + (kons-kdr (make-kons 'a 'b))) + 'b) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (kons-kdr (make-kons 'a 'b))))) + ''b) + (member? + (with-output-to-string + (lambda () + (define-record kons (kar kdr)) + (display (kons-kar (make-kons (begin (display 1) (display 2) 3) + (begin (display 4) (display 5) 6)))))) + '("45123" "12453")) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (display (kons-kar (make-kons (begin (display 1) (display 2) 3) + (begin (display 4) (display 5) 6))))))) + '(#2%display + (begin + (#2%display 4) + (#2%display 5) + (#2%display 1) + (#2%display 2) + 3))) + (member? + (with-output-to-string + (lambda () + (define-record kons (kar kdr)) + (display (kons-kdr (make-kons (begin (display 1) (display 2) 3) + (begin (display 4) (display 5) 6)))))) + '("45126" "12456")) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record kons (kar kdr)) + (display (kons-kdr (make-kons (begin (display 1) (display 2) 3) + (begin (display 4) (display 5) 6))))))) + '(#2%display + (begin + (#2%display 4) + (#2%display 5) + (#2%display 1) + (#2%display 2) + 6))) + (equal? + (with-output-to-string + (lambda () + (define-record ktail (kar (immutable kdr))) + (define x (make-ktail 1 2)) + (display 3) + (display (ktail-kdr (begin (display 4) x))))) + "342") + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record ktail (kar (immutable kdr))) + (define x (make-ktail 1 2)) + (display 3) + (display (ktail-kdr (begin (display 4) x)))))) + '(begin + (#2%display 3) + (#2%display + (begin + (#2%display 4) + 2)))) + (equal? + (with-output-to-string + (lambda () + (define-record ktail (kar (immutable kdr))) + (define x (make-ktail 1 2)) + (display 3) + (display (ktail-kar (begin (display 4) x))))) + "341") + (not (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record ktail (kar (immutable kdr))) + (define x (make-ktail 1 2)) + (display 3) + (display (ktail-kar (begin (display 4) x)))))) + '(begin + (#2%display 3) + (#2%display + (begin + (#2%display 4) + 1))))) +) diff --git a/s/cp0.ss b/s/cp0.ss index 3c544b0f4..3722fca7e 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -4694,26 +4694,27 @@ (cp0 rtd-expr 'effect env sc wd #f moi) (map (lambda (e) (cp0 e 'effect env sc wd #f moi)) e*))) true-rec)])] - [(record-ref ,rtd ,type ,index ,e) + [(record-ref ,rtd ,type ,index ,e0) (context-case ctxt - [(effect) (cp0 e 'effect env sc wd name moi)] + [(effect) (cp0 e0 'effect env sc wd name moi)] [else - (let ([e (cp0 e 'value env sc wd name moi)]) - (or (nanopass-case (Lsrc Expr) (result-exp e) + (let ([e0 (cp0 e0 'value env sc wd name moi)]) + (or (nanopass-case (Lsrc Expr) (result-exp e0) [(quote ,d) (and (record? d rtd) - (make-seq ctxt e `(quote ,((csv7:record-field-accessor rtd index) d))))] + (make-seq ctxt e0 `(quote ,((csv7:record-field-accessor rtd index) d))))] [(record ,rtd1 ,rtd-expr ,e* ...) (let loop ([e* e*] [re* '()] [index index]) (and (not (null? e*)) - (if (= index 0) + (if (fx= index 0) (let ([e (car e*)] [e* (rappend re* (cdr e*))]) - (if (null? e*) - e - (make-seq ctxt (make-seq* 'effect e*) e))) + (non-result-exp e0 + (if (null? e*) + e + (make-seq ctxt (make-seq* 'effect e*) e)))) (loop (cdr e*) (cons (car e*) re*) (fx- index 1)))))] [else #f]) - (nanopass-case (Lsrc Expr) (result-exp/indirect-ref e) + (nanopass-case (Lsrc Expr) (result-exp/indirect-ref e0) [(record ,rtd1 ,rtd-expr ,e* ...) (and (> (length e*) index) (not (fld-mutable? (list-ref (rtd-flds rtd) index))) @@ -4724,9 +4725,9 @@ [,pr (all-set? (prim-mask proc) (primref-flags pr))] [else #f]) ; recur to cp0 to get inlining, folding, etc. - (cp0 e ctxt env sc wd name moi))))] + (non-result-exp e0 (cp0 e ctxt env sc wd name moi)))))] [else #f]) - (begin (bump sc 1) `(record-ref ,rtd ,type ,index ,e))))])] + (begin (bump sc 1) `(record-ref ,rtd ,type ,index ,e0))))])] [(record-set! ,rtd ,type ,index ,[cp0 : e1 'value env sc wd #f moi -> e1] ,[cp0 : e2 'value env sc wd #f moi -> e2]) `(record-set! ,rtd ,type ,index ,e1 ,e2)] [(record-type ,rtd ,e) (cp0 e ctxt env sc wd name moi)]