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

cs: optimize pattern matching on authentic structs

Browse Source
This commit is contained in:
yjqww6 2021-02-18 14:04:17 +08:00 committed by Matthew Flatt
parent 23dc67c1a4
commit 4110761f94
3 changed files with 43 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
racket/src/ChezScheme/mats/cptypes.ms
View File

@ -696,6 +696,18 @@
(define-record-type ,my-rec (fields a))
(define-record-type ,my-sub-rec (fields a) (parent ,my-rec) (sealed #t))
(lambda (x) (and (my-rec? x) (list 'ok (#3%$sealed-record-instance? x (record-type-descriptor ,my-sub-rec)))))))
;; obviously incompatible rtds
;; the third pass is needed to eliminate #3%$value
(parameterize ([run-cp0 (lambda (cp0 x) (cp0 (cp0 (cp0 x))))])
(cptypes-equivalent-expansion?
`(let ()
(define-record I (a))
(define A (make-record-type-descriptor* 'a #f #f #f #f 1 0))
(lambda (x) (and ((record-predicate A) x) (I? x))))
`(begin
(make-record-type-descriptor* 'a #f #f #f #f 1 0)
(lambda (x) #f))))
)
(mat cptypes-unsafe

30
racket/src/ChezScheme/s/cptypes-lattice.ss
View File

@ -42,6 +42,7 @@
; don't use rtd-* as defined in record.ss in case we're building a patch
; file for cross compilation, because the offsets may be incorrect
(define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors))
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
(define-record-type pred-$record/rtd
(fields rtd)
@ -49,10 +50,23 @@
(sealed #t))
(define-record-type pred-$record/ref
(fields ref)
(nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0})
(fields ref maybe-rtd)
(nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-1})
(sealed #t))
;could be a ctrtd
(define (pred-$record-maybe-rtd x)
(cond
[(pred-$record/rtd? x) (pred-$record/rtd-rtd x)]
[(pred-$record/ref? x) (pred-$record/ref-maybe-rtd x)]
[else #f]))
(define (rtd-obviously-incompatible? x y)
(let ([x-flds (rtd-flds x)]
[y-flds (rtd-flds y)])
(or (and (fixnum? x-flds) (not (fixnum? y-flds)))
(and (not (fixnum? x-flds)) (fixnum? y-flds)))))
(define (check-constant-is? x pred?)
(and (Lsrc? x)
(nanopass-case (Lsrc Expr) x
@ -592,10 +606,20 @@
[(rtd-ancestor*? y-rtd x-rtd) x]
[(rtd-ancestor*? x-rtd y-rtd) y]
[else 'bottom])]))]
[(pred-$record/ref? x)
(let ([x-rtd (pred-$record/ref-maybe-rtd x)]
[y-rtd (pred-$record/rtd-rtd y)])
(if (and x-rtd (rtd-obviously-incompatible? x-rtd y-rtd))
'bottom
(intersect/record x y)))]
[else
(intersect/record x y)])]
[(pred-$record/ref? y)
(intersect/record x y)]
(let ([y-rtd (pred-$record/ref-maybe-rtd y)]
[x-rtd (pred-$record-maybe-rtd x)])
(if (and x-rtd y-rtd (rtd-obviously-incompatible? x-rtd y-rtd))
'bottom
(intersect/record x y)))]
[else
(case y
[($record)

5
racket/src/ChezScheme/s/cptypes.ss
View File

@ -528,7 +528,10 @@ Notes:
(make-pred-$record/rtd d)]
[(ref ,maybe-src ,x)
(guard (not (prelex-assigned x)))
(make-pred-$record/ref x)]
(make-pred-$record/ref x #f)]
[(record-type ,rtd (ref ,maybe-src ,x))
(guard (not (prelex-assigned x)))
(make-pred-$record/ref x rtd)]
[(record-type ,rtd ,e)
(rtd->record-predicate e extend?)]
[else (if (not extend?) 'bottom '$record)])]