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

cs: improve chaperoned structure-property access

Browse Source 
Avoid looking up the property twice.
This commit is contained in:
Matthew Flatt 2020-02-16 16:27:51 -07:00
parent 5555019ec2
commit e1c1269939
2 changed files with 48 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
racket/src/cs/rumble/impersonator.ss
View File

@ -39,7 +39,9 @@
(define (do-impersonate-ref acc rtd pos orig record-name field-name)
(impersonate-struct-or-property-ref acc rtd rtd pos orig record-name field-name))
(define (impersonate-struct-or-property-ref acc rtd key1 key2/pos orig record-name field-name)
;; `val/acc` is an accessor if `rtd`, a value otherwise;
;; `key2/pos` is a pos if `rtd`
(define (impersonate-struct-or-property-ref val/acc rtd key1 key2/pos orig record-name field-name)
(cond
[(and (impersonator? orig)
(or (not rtd)
@ -52,7 +54,7 @@
(let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
(let ([r (unsafe-struct*-ref (impersonator-val v) abs-pos)])
(when (eq? r unsafe-undefined)
(raise-unsafe-undefined 'struct-ref "undefined" "use" acc (impersonator-val v) abs-pos))
(raise-unsafe-undefined 'struct-ref "undefined" "use" val/acc (impersonator-val v) abs-pos))
r))]
[(or (struct-impersonator? v)
(struct-chaperone? v))
@ -77,10 +79,11 @@
[(impersonator? v)
(loop (impersonator-next v))]
[else
(if rtd
(let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
(unsafe-struct*-ref v abs-pos))
(acc v))]))]
(cond
[rtd
(let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
(unsafe-struct*-ref v abs-pos))]
[else val/acc])]))]
[else
(raise-argument-error (string->symbol
(string-append (symbol->string (or record-name 'struct))

85
racket/src/cs/rumble/struct.ss
View File

@ -51,15 +51,6 @@
(raise-argument-error who "(listof (cons/c struct-type-property? (procedure-arity-includes/c 1)))" supers))
(let* ([can-impersonate? (and (or can-impersonate? (eq? guard 'can-impersonate)) #t)]
[st (make-struct-type-prop name (and (not (eq? guard 'can-impersonate)) guard) supers)]
[pred (escapes-ok
(lambda (v)
(let* ([v (strip-impersonator v)]
[rtd (if (record-type-descriptor? v)
v
(and (record? v)
(record-rtd v)))])
(and rtd
(not (eq? none (struct-property-ref st rtd none)))))))]
[accessor-name (string->symbol (string-append
(symbol->string name)
"-ref"))]
@ -67,49 +58,51 @@
(string-append
(symbol->string name)
"?"))]
[default-fail
(escapes-ok
(lambda (v)
(raise-argument-error accessor-name
(symbol->string predicate-name)
v)))]
[do-fail (lambda (fail v)
(cond
[(eq? fail default-fail) (default-fail v)]
[(procedure? fail) (|#%app| fail)]
[else fail]))])
[pred (procedure-rename*
(lambda (v)
(let* ([v (strip-impersonator v)]
[rtd (if (record-type-descriptor? v)
v
(and (record? v)
(record-rtd v)))])
(and rtd
(not (eq? none (struct-property-ref st rtd none))))))
2
predicate-name)])
(letrec ([acc
(procedure-rename*
(case-lambda
[(v fail)
(cond
[(and (impersonator? v)
(pred v))
(impersonate-struct-or-property-ref acc #f #|key1:|# acc #|key2:|# #f v #f #f)]
[else
(let* ([rtd (if (record-type-descriptor? v)
v
(and (record? v)
(record-rtd v)))])
(if rtd
(let ([pv (struct-property-ref st rtd none)])
(if (eq? pv none)
(do-fail fail v)
pv))
(do-fail fail v)))])]
[(v) (acc v default-fail)])
(let ([val (let ([v (strip-impersonator v)])
(if (record-type-descriptor? v)
(struct-property-ref st v none)
(if (record? v)
(struct-property-ref st (record-rtd v) none)
none)))])
(cond
[(eq? val none)
(cond
[(eq? fail none)
(raise-argument-error accessor-name
(symbol->string predicate-name)
v)]
[(procedure? fail) (|#%app| fail)]
[else fail])]
[(impersonator? v)
(impersonate-struct-or-property-ref val #f #|key1:|# acc #|key2:|# #f v #f #f)]
[else val]))]
[(v) (acc v none)])
6
accessor-name)])
(let ([pred (procedure-rename* pred 2 predicate-name)])
(add-to-table! property-accessors
acc
(cons pred can-impersonate?))
(add-to-table! property-predicates
pred
st)
(values st
pred
acc))))]))
(add-to-table! property-accessors
acc
(cons pred can-impersonate?))
(add-to-table! property-predicates
pred
st)
(values st
pred
acc)))]))
(define (struct-type-property-accessor-procedure? v)
(let ([v (strip-impersonator v)])