Merge pull request #421 from gus-massa/19-4-Fix-Record-Ref

Fix record-ref reduction in cp0
original commit: 53d09d9e049c78d331505105b125f23113f3ea2b

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

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)))))
+)

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)]