Skip to content

Commit

Permalink
Merge pull request cisco#421 from gus-massa/19-4-Fix-Record-Ref
Browse files Browse the repository at this point in the history 
Fix record-ref reduction in cp0
  • Loading branch information
@dybvig
dybvig authored Apr 19, 2019
2 parents 3ea6f8e + 5c50c5d commit 53d09d9
Show file tree
Hide file tree
Showing 3 changed files with 153 additions and 12 deletions.
6 changes: 6 additions & 0 deletions LOG
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
134 changes: 134 additions & 0 deletions mats/record.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))))
)
25 changes: 13 additions & 12 deletions s/cp0.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand All @@ -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)]
Expand Down

0 comments on commit 53d09d9

Please sign in to comment.