suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cp0: improvements for $record-ref and record?

Browse Source
This commit is contained in:
yjqww6 2020-12-02 19:54:15 +08:00 committed by Matthew Flatt
parent 08fc3b17c7
commit cec3041f24
2 changed files with 48 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
racket/src/ChezScheme/mats/record.ms
View File

@ -9187,3 +9187,31 @@
(#2%display 4)
1)))))
)
(mat cp0-$record-ref
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(let ()
(define A (make-record-type-descriptor* 'A #f #f #f #f 2 0))
(define x ((record-constructor A) (begin (display A) 1) (begin (display 0
) 2)))
(+ (#3%$record-ref x 0) (#3%$record-ref x 1)))))
'(let ([a (#2%make-record-type-descriptor* 'A #f #f #f #f 2 0)])
(#2%display 0)
(#2%display a)
3))
)
(mat cp0-record?
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(let ()
(define A (make-record-type-descriptor* 'A #f #f #f #f 2 0))
(define-record B (a b))
(record? ((record-constructor A) 1 2) (record-type-descriptor B)))))
'(begin
(#2%make-record-type-descriptor* 'A #f #f #f #f 2 0)
#f))
)

21
racket/src/ChezScheme/s/cp0.ss
View File

@ -3935,6 +3935,10 @@
(and rtd (f rtd))))))
(residualize-seq '() (list ?x ?rtd) ctxt)
true-rec]
[(record ,rtd ,rtd-expr ,e* ...)
(obviously-incompatible? rtd d0)
(residualize-seq '() (list ?x ?rtd) ctxt)
false-rec]
[else (abandon-ship xval xres d0)]))))]
[(record-type ,rtd ,e)
(cond
@ -4092,7 +4096,22 @@
(non-result-exp r-expr
main)))
(loop (cdr e*) (cons (car e*) re*) (fx- index 1)))))]
[else #f]))]
[else
(nanopass-case (Lsrc Expr) (result-exp/indirect-ref r-expr)
[(record ,rtd1 ,rtd-expr1 ,e* ...)
(guard (< d (length e*))
(rtd-immutable-field? rtd1 d))
(let ([e (list-ref e* d)])
(and
(nanopass-case (Lsrc Expr) e
[(quote ,d) #t]
[(ref ,maybe-src ,x) (not (prelex-assigned x))]
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
[else #f])
(begin
(residualize-seq (list ?r ?i) '() ctxt)
(non-result-exp i-expr (non-result-exp r-expr e)))))]
[else #f])]))]
[else #f]))])
(let ()