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) (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)) (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 (cond
[(and (impersonator? orig) [(and (impersonator? orig)
(or (not rtd) (or (not rtd)
@ -52,7 +54,7 @@
(let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))]) (let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
(let ([r (unsafe-struct*-ref (impersonator-val v) abs-pos)]) (let ([r (unsafe-struct*-ref (impersonator-val v) abs-pos)])
(when (eq? r unsafe-undefined) (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))] r))]
[(or (struct-impersonator? v) [(or (struct-impersonator? v)
(struct-chaperone? v)) (struct-chaperone? v))
@ -77,10 +79,11 @@
[(impersonator? v) [(impersonator? v)
(loop (impersonator-next v))] (loop (impersonator-next v))]
[else [else
(if rtd (cond
(let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))]) [rtd
(unsafe-struct*-ref v abs-pos)) (let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
(acc v))]))] (unsafe-struct*-ref v abs-pos))]
[else val/acc])]))]
[else [else
(raise-argument-error (string->symbol (raise-argument-error (string->symbol
(string-append (symbol->string (or record-name 'struct)) (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)) (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)] (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)] [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 [accessor-name (string->symbol (string-append
(symbol->string name) (symbol->string name)
"-ref"))] "-ref"))]
@ -67,49 +58,51 @@
(string-append (string-append
(symbol->string name) (symbol->string name)
"?"))] "?"))]
[default-fail [pred (procedure-rename*
(escapes-ok (lambda (v)
(lambda (v) (let* ([v (strip-impersonator v)]
(raise-argument-error accessor-name [rtd (if (record-type-descriptor? v)
(symbol->string predicate-name) v
v)))] (and (record? v)
[do-fail (lambda (fail v) (record-rtd v)))])
(cond (and rtd
[(eq? fail default-fail) (default-fail v)] (not (eq? none (struct-property-ref st rtd none))))))
[(procedure? fail) (|#%app| fail)] 2
[else fail]))]) predicate-name)])
(letrec ([acc (letrec ([acc
(procedure-rename* (procedure-rename*
(case-lambda (case-lambda
[(v fail) [(v fail)
(cond (let ([val (let ([v (strip-impersonator v)])
[(and (impersonator? v) (if (record-type-descriptor? v)
(pred v)) (struct-property-ref st v none)
(impersonate-struct-or-property-ref acc #f #|key1:|# acc #|key2:|# #f v #f #f)] (if (record? v)
[else (struct-property-ref st (record-rtd v) none)
(let* ([rtd (if (record-type-descriptor? v) none)))])
v (cond
(and (record? v) [(eq? val none)
(record-rtd v)))]) (cond
(if rtd [(eq? fail none)
(let ([pv (struct-property-ref st rtd none)]) (raise-argument-error accessor-name
(if (eq? pv none) (symbol->string predicate-name)
(do-fail fail v) v)]
pv)) [(procedure? fail) (|#%app| fail)]
(do-fail fail v)))])] [else fail])]
[(v) (acc v default-fail)]) [(impersonator? v)
(impersonate-struct-or-property-ref val #f #|key1:|# acc #|key2:|# #f v #f #f)]
[else val]))]
[(v) (acc v none)])
6 6
accessor-name)]) accessor-name)])
(let ([pred (procedure-rename* pred 2 predicate-name)]) (add-to-table! property-accessors
(add-to-table! property-accessors acc
acc (cons pred can-impersonate?))
(cons pred can-impersonate?)) (add-to-table! property-predicates
(add-to-table! property-predicates pred
pred st)
st) (values st
(values st pred
pred acc)))]))
acc))))]))
(define (struct-type-property-accessor-procedure? v) (define (struct-type-property-accessor-procedure? v)
(let ([v (strip-impersonator v)]) (let ([v (strip-impersonator v)])