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

cs: faster struct impersonation

Browse Source
This commit is contained in:
Matthew Flatt 2020-02-07 20:32:03 -07:00
parent 615e4f707a
commit 1900c0e57a
5 changed files with 319 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/config.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang racket/base
(provide (all-defined-out))
;; Iterations for slow things:
(define Q 1000000)
;; The depth used for non-tail recursion, typically:
(define M (* Q 10))
;; Intermediate count:
(define L (* M 10))
;; Number of iterations used for a loop, typically
(define N (* L 10))
;; Number of times to run each benchmark:
(define I 3)
(define-syntax times
(syntax-rules ()
[(_ e)
(let loop ([v #f] [i I])
(if (zero? i)
v
(loop (time e) (sub1 i))))]))

161
pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/struct.rkt Normal file
View File

@ -0,0 +1,161 @@
#lang racket/base
(require racket/unsafe/undefined
"config.rkt")
(define-values (prop:mine mine? mine-ref)
(make-struct-type-property 'mine))
(struct posn (x [y #:mutable])
#:property prop:mine #t)
(struct posn3D posn ([z #:mutable]))
(struct posn/u (x [y #:mutable])
#:property prop:mine #t
#:property prop:chaperone-unsafe-undefined '(y x))
(struct posn3D/u posn/u ([z #:mutable])
#:property prop:chaperone-unsafe-undefined '(z y x))
(define pt* (posn 1 2))
(define pt3D* (posn3D 1 2 3))
(define pt*/u (posn/u 1 2))
(define pt3D*/u (posn3D/u 1 2 3))
(define pt (chaperone-struct pt*
posn-x (lambda (self v) v)
set-posn-y! (lambda (self v) v)
mine-ref (lambda (self v) v)))
(define pt3D (chaperone-struct pt3D*
posn-x (lambda (self v) v)
posn3D-z (lambda (self v) v)
set-posn-y! (lambda (self v) v)
set-posn3D-z! (lambda (self v) v)
mine-ref (lambda (self v) v)))
(define pt/u (chaperone-struct pt*/u
posn/u-x (lambda (self v) v)
set-posn/u-y! (lambda (self v) v)
mine-ref (lambda (self v) v)))
(define pt3D/u (chaperone-struct pt3D*/u
posn/u-x (lambda (self v) v)
posn3D/u-z (lambda (self v) v)
set-posn/u-y! (lambda (self v) v)
set-posn3D/u-z! (lambda (self v) v)
mine-ref (lambda (self v) v)))
'----------------------------------------
'chaperone
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(chaperone-struct pt*
posn-x (lambda (self v) v)))))
'chaperone-more
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(chaperone-struct pt
posn-x (lambda (self v) v)))))
'chaperone-prop
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(chaperone-struct pt*
mine-ref (lambda (self v) v)))))
'baseline-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(posn-x pt*))))
'baseline-set!
(times
(for/fold ([r #f]) ([i (in-range M)])
(set-posn-y! pt* 8)))
'baseline-sub-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(posn3D-z pt3D*))))
'baseline-sub-set!
(times
(for/fold ([r #f]) ([i (in-range M)])
(set-posn3D-z! pt3D* 9)))
'baseline-prop-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(mine-ref pt*))))
'undefined-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(posn/u-x pt*/u))))
'undefined-set!
(times
(for/fold ([r #f]) ([i (in-range M)])
(set-posn/u-y! pt*/u 8)))
'undefined-prop-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(mine-ref pt*/u))))
'chaperoned-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(posn-x pt))))
'chaperoned-set!
(times
(for/fold ([r #f]) ([i (in-range M)])
(set-posn-y! pt 8)))
'chaperoned-sub-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(posn3D-z pt3D))))
'chaperoned-sub-set!
(times
(for/fold ([r #f]) ([i (in-range M)])
(set-posn3D-z! pt3D 9)))
'chaperoned-prop-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(mine-ref pt))))
'chaperoned-undefined-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(posn/u-x pt/u))))
'chaperoned-undefined-set!
(times
(for/fold ([r #f]) ([i (in-range M)])
(set-posn/u-y! pt/u 8)))
'chaperoned-undefined-prop-ref
(times
(void
(for/fold ([r #f]) ([i (in-range M)])
(mine-ref pt/u))))

4
racket/src/cs/demo/chaperone.ss
View File

@ -128,7 +128,7 @@
(check (chaperone-of? fc f) #t) (check (chaperone-of? fc f) #t)
(check (chaperone-of? fi f) #f) (check (chaperone-of? fi f) #f)
(check (chaperone-of? fi fc) #f) (check (chaperone-of? fi fc) #f)
(check (chaperone-of? fc fi) #t) (check (chaperone-of? fc fi) #f)
(define fc2 (chaperone-procedure f (define fc2 (chaperone-procedure f
(lambda (x y) (lambda (x y)
@ -348,7 +348,7 @@
(check (ops!) '(set equal-key)) (check (ops!) '(set equal-key))
(check (hash-ref (hash-remove ht1c 1) 1 'none) 'none) (check (hash-ref (hash-remove ht1c 1) 1 'none) 'none)
(check (ops!) '(remove equal-key get equal-key equal-key)) (check (ops!) '(remove equal-key get equal-key))
(check (begin (check (begin
(hash-remove! ht2c 1) (hash-remove! ht2c 1)
(hash-ref ht2c 1 'none)) (hash-ref ht2c 1 'none))

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

@ -22,22 +22,41 @@
"original" e "original" e
"received" e2)) "received" e2))
(define (hash-ref2 ht key1 key2 default)
(let ([ht/val (intmap-ref ht key1 #f)])
(if (and key2 ht/val)
(intmap-ref ht/val key2 #f)
ht/val)))
(define (hash-set2 ht key1 key2 val)
(intmap-set ht key1 (if key2
(intmap-set (intmap-ref ht key1 empty-hasheq) key2 val)
val)))
(define (impersonate-ref acc rtd pos orig record-name field-name) (define (impersonate-ref acc rtd pos orig record-name field-name)
(#%$app/no-inline do-impersonate-ref acc rtd pos orig record-name field-name)) (#%$app/no-inline do-impersonate-ref acc rtd pos orig record-name field-name))
(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 (cons 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 key orig record-name field-name) (define (impersonate-struct-or-property-ref acc rtd key1 key2/pos orig record-name field-name)
(cond (cond
[(and (impersonator? orig) [(and (impersonator? orig)
(or (not rtd) (or (not rtd)
(record? (impersonator-val orig) rtd))) (record? (impersonator-val orig) rtd)))
(let loop ([v orig]) (let loop ([v orig])
(cond (cond
[(and (struct-undefined-chaperone? v)
rtd)
;; Must be the only wrapper left
(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))
r))]
[(or (struct-impersonator? v) [(or (struct-impersonator? v)
(struct-chaperone? v)) (struct-chaperone? v))
(let ([wrapper (hash-ref (struct-impersonator/chaperone-procs v) key #f)]) (let ([wrapper (hash-ref2 (struct-impersonator/chaperone-procs v) key1 key2/pos #f)])
(cond (cond
[wrapper [wrapper
(let* ([r (cond (let* ([r (cond
@ -55,16 +74,13 @@
new-r)] new-r)]
[else [else
(loop (impersonator-next v))]))] (loop (impersonator-next v))]))]
[(and (struct-undefined-chaperone? v)
rtd)
(let ([r (loop (impersonator-next v))])
(when (eq? r unsafe-undefined)
(let ([abs-pos (fx+ (cdr key) (struct-type-parent-total*-count (car key)))])
(raise-unsafe-undefined 'struct-ref "undefined" "use" acc (impersonator-val v) abs-pos)))
r)]
[(impersonator? v) [(impersonator? v)
(loop (impersonator-next v))] (loop (impersonator-next v))]
[else (|#%app| acc v)]))] [else
(if rtd
(let ([abs-pos (fx+ key2/pos (struct-type-parent-total*-count rtd))])
(unsafe-struct*-ref v abs-pos))
(|#%app| acc v))]))]
[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))
@ -76,16 +92,27 @@
(define (impersonate-set! set rtd pos abs-pos orig a record-name field-name) (define (impersonate-set! set rtd pos abs-pos orig a record-name field-name)
(#%$app/no-inline do-impersonate-set! set rtd pos abs-pos orig a record-name field-name)) (#%$app/no-inline do-impersonate-set! set rtd pos abs-pos orig a record-name field-name))
(define (struct-mutator-pos->key2 pos) (fx- -1 pos))
(define (do-impersonate-set! set rtd pos abs-pos orig a record-name field-name) (define (do-impersonate-set! set rtd pos abs-pos orig a record-name field-name)
(cond (cond
[(and (impersonator? orig) [(and (impersonator? orig)
(record? (impersonator-val orig) rtd)) (record? (impersonator-val orig) rtd))
(let ([key (vector rtd pos)]) (let ([key1 rtd]
[key2 (struct-mutator-pos->key2 pos)])
(let loop ([v orig] [a a]) (let loop ([v orig] [a a])
(cond (cond
[(struct-undefined-chaperone? v)
;; Must be the only wrapper left
(let ([v (impersonator-val v)])
(when (eq? (unsafe-struct*-ref v abs-pos) unsafe-undefined)
(unless (eq? (continuation-mark-set-first #f prop:chaperone-unsafe-undefined)
unsafe-undefined)
(raise-unsafe-undefined 'struct-set! "assignment disallowed" "assign" set v abs-pos)))
(unsafe-struct*-set! v abs-pos a))]
[(or (struct-impersonator? v) [(or (struct-impersonator? v)
(struct-chaperone? v)) (struct-chaperone? v))
(let ([wrapper (hash-ref (struct-impersonator/chaperone-procs v) key #f)]) (let ([wrapper (hash-ref2 (struct-impersonator/chaperone-procs v) key1 key2 #f)])
(cond (cond
[wrapper [wrapper
(let ([new-a (cond (let ([new-a (cond
@ -102,15 +129,11 @@
(loop (impersonator-next v) new-a)]))] (loop (impersonator-next v) new-a)]))]
[else [else
(loop (impersonator-next v) a)]))] (loop (impersonator-next v) a)]))]
[(struct-undefined-chaperone? v)
(when (eq? (unsafe-struct*-ref (impersonator-val v) abs-pos) unsafe-undefined)
(unless (eq? (continuation-mark-set-first #f prop:chaperone-unsafe-undefined)
unsafe-undefined)
(raise-unsafe-undefined 'struct-set! "assignment disallowed" "assign" set (impersonator-val v) abs-pos)))
(loop (impersonator-next v) a)]
[(impersonator? v) [(impersonator? v)
(loop (impersonator-next v) a)] (loop (impersonator-next v) a)]
[else (set v a)])))] [else
;; Equivalent to `(set v a)`:
(unsafe-struct*-set! v abs-pos a)])))]
[else [else
(raise-argument-error (string->symbol (raise-argument-error (string->symbol
(string-append "set" (string-append "set"
@ -347,59 +370,57 @@
"value" v)) "value" v))
(let loop ([first? (not st)] (let loop ([first? (not st)]
[args orig-args] [args orig-args]
[props empty-hash] [props empty-hasheq]
[saw-props empty-hash] [saw-props empty-hasheq]
[witnessed? (and st #t)] [witnessed? (and st #t)]
[iprops orig-iprops]) [iprops orig-iprops])
(let ([get-proc (let ([get-proc
(lambda (what args arity proc->key key-applies?) (lambda (what args arity orig-proc key1 key2 key-applies? now-witnessed?)
(let* ([orig-proc (car args)] (unless key-applies?
[key-proc (strip-impersonator orig-proc)] (raise-arguments-error who
[key (proc->key key-proc)]) "operation does not apply to given value"
(when (hash-ref saw-props key #f) "operation kind" (make-unquoted-printing-string what)
(raise-arguments-error who "operation procedure" orig-proc
"given operation accesses the same value as a previous operation argument" "value" v))
"operation kind" what (when (hash-ref2 saw-props key1 key2 #f)
"operation procedure" orig-proc)) (raise-arguments-error who
(when key-applies? "given operation accesses the same value as a previous operation argument"
(unless (key-applies? key val) "operation kind" (make-unquoted-printing-string what)
"operation procedure" orig-proc))
(when (null? (cdr args))
(raise-arguments-error who
"missing redirection procedure after operation"
"operation kind" (make-unquoted-printing-string what)
"operation procedure" orig-proc))
(let ([proc (cadr args)])
(when proc
(unless (unsafe-procedure-and-arity-includes? proc arity)
(raise-arguments-error who (raise-arguments-error who
"operation does not apply to given value" "operation's redirection procedure does not match the expected arity"
"operation kind" what "given" proc
"operation procedure" orig-proc "expected" (make-unquoted-printing-string
"value" v))) (string-append
(when (null? (cdr args)) "(or/c #f (procedure-arity-includes/c " (number->string arity) "))"))
"operation kind" (make-unquoted-printing-string what)
"operation procedure" orig-proc)))
(when (and as-chaperone?
(and (impersonator? orig-proc)
(not (chaperone? orig-proc))))
(raise-arguments-error who (raise-arguments-error who
"missing redirection procedure after operation" "impersonated operation cannot be used to create a chaperone"
"operation kind" what "operation" orig-proc))
"operation procedure" orig-proc)) (let ([new-args (cddr args)])
(let ([proc (cadr args)])
(when proc
(unless (procedure-arity-includes? proc arity)
(raise-arguments-error who
"operation's redirection procedure does not match the expected arity"
"given" proc
"expected" (string-append
"(or/c #f (procedure-arity-includes/c " (number->string arity) "))")
"operation kind" what
"operation procedure" orig-proc)))
(when (and as-chaperone?
(and (impersonator? orig-proc)
(not (chaperone? orig-proc))))
(raise-arguments-error who
"impersonated operation cannot be used to create a chaperone"
"operation" orig-proc))
(loop #f (loop #f
(cddr args) new-args
(if proc (if proc
(hash-set props key (hash-set2 props key1 key2
(if (impersonator? orig-proc) (if (impersonator? orig-proc)
(cons orig-proc ; save original accessor, in case it's impersonated (cons orig-proc ; save original accessor, in case it's impersonated
proc) ; the interposition proc proc) ; the interposition proc
proc)) proc))
props) props)
(hash-set saw-props key #t) (if (null? new-args) saw-props (hash-set2 saw-props key1 key2 #t))
(or witnessed? key-applies?) (or witnessed? now-witnessed?)
iprops))))]) iprops))))])
(cond (cond
[(null? args) [(null? args)
@ -422,7 +443,7 @@
" instance of an authentic structure type") " instance of an authentic structure type")
"given value" v)) "given value" v))
(cond (cond
[(zero? (hash-count props)) [(eq? props empty-hasheq)
;; No structure operations chaperoned, so either unchanged or ;; No structure operations chaperoned, so either unchanged or
;; a properties-only impersonator ;; a properties-only impersonator
(cond (cond
@ -463,39 +484,46 @@
witnessed? witnessed?
(add-impersonator-properties who args iprops))] (add-impersonator-properties who args iprops))]
[(struct-accessor-procedure? (car args)) [(struct-accessor-procedure? (car args))
(get-proc "accessor" args 2 (let* ([orig-proc (car args)]
struct-accessor-procedure-rtd+pos [key-proc (strip-impersonator orig-proc)]
(lambda (rtd+pos v) [rtd+pos (struct-accessor-procedure-rtd+pos key-proc)])
(and (record? v (car rtd+pos)) (unless (or as-chaperone?
(begin (struct-type-field-mutable? (car rtd+pos) (cdr rtd+pos)))
(unless (or as-chaperone? (raise-arguments-error who
(struct-type-field-mutable? (car rtd+pos) (cdr rtd+pos))) "cannot replace operation for an immutable field"
(raise-arguments-error who "operation kind" (make-unquoted-printing-string "property accessor")
"cannot replace operation for an immutable field" "operation procedure" (car args)))
"operation kind" "property accessor" (get-proc "accessor" args 2
"operation procedure" (car args))) orig-proc (car rtd+pos) (cdr rtd+pos)
#t))))] (record? val (car rtd+pos))
#t))]
[(struct-mutator-procedure? (car args)) [(struct-mutator-procedure? (car args))
(get-proc "mutator" args 2 (let* ([orig-proc (car args)]
(lambda (proc) [key-proc (strip-impersonator orig-proc)]
(let ([rtd+pos (struct-mutator-procedure-rtd+pos proc)]) [rtd+pos (struct-mutator-procedure-rtd+pos key-proc)])
(vector (car rtd+pos) (cdr rtd+pos)))) (get-proc "mutator" args 2
(lambda (rtd++pos v) orig-proc (car rtd+pos) (struct-mutator-pos->key2 (cdr rtd+pos))
(record? v (vector-ref rtd++pos 0))))] (record? val (car rtd+pos))
#t))]
[(struct-type-property-accessor-procedure? (car args)) [(struct-type-property-accessor-procedure? (car args))
(get-proc "property accessor" args 2 (let* ([orig-proc (car args)]
(lambda (proc) proc) [key-proc (strip-impersonator orig-proc)])
(lambda (proc v) (unless (or as-chaperone?
(unless (or as-chaperone? (struct-type-property-accessor-procedure-can-impersonate? key-proc))
(struct-type-property-accessor-procedure-can-impersonate? proc)) (raise-arguments-error who
(raise-arguments-error who "operation cannot be impersonated"
"operation cannot be impersonated" "operation kind" (make-unquoted-printing-string "property accessor")
"operation kind" "property accessor" "operation procedure" orig-proc))
"operation procedure" (car args))) (get-proc "property accessor" args 2
((struct-type-property-accessor-procedure-pred proc) v)))] orig-proc key-proc #f
((struct-type-property-accessor-procedure-pred key-proc) val)
#t))]
[(and as-chaperone? [(and as-chaperone?
(equal? struct-info (car args))) (equal? struct-info (car args)))
(get-proc "struct-info procedure" args 2 (lambda (proc) proc) #f)] (get-proc "struct-info procedure" args 2
struct-info struct-info #f
#t
#f)]
[else [else
(raise-argument-error who (raise-argument-error who
(string-append (string-append

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

@ -82,7 +82,7 @@
(cond (cond
[(and (impersonator? v) [(and (impersonator? v)
(pred v)) (pred v))
(impersonate-struct-or-property-ref acc #f acc v #f #f)] (impersonate-struct-or-property-ref acc #f #|key1:|# acc #|key2:|# #f v #f #f)]
[else [else
(let* ([rtd (if (record-type-descriptor? v) (let* ([rtd (if (record-type-descriptor? v)
v v
@ -406,38 +406,38 @@
(define (struct-constructor-procedure? v) (define (struct-constructor-procedure? v)
(and (procedure? v) (and (procedure? v)
(let ([v (strip-impersonator v)]) (let ([v (strip-impersonator v)])
(with-global-lock* (hashtable-ref struct-constructors v #f))))) (with-global-lock* (eq-hashtable-ref struct-constructors v #f)))))
(define (struct-predicate-procedure? v) (define (struct-predicate-procedure? v)
(and (procedure? v) (and (procedure? v)
(let ([v (strip-impersonator v)]) (let ([v (strip-impersonator v)])
(with-global-lock* (hashtable-ref struct-predicates v #f))))) (with-global-lock* (eq-hashtable-ref struct-predicates v #f)))))
(define (struct-accessor-procedure? v) (define (struct-accessor-procedure? v)
(and (procedure? v) (and (procedure? v)
(let ([v (strip-impersonator v)]) (let ([v (strip-impersonator v)])
(or (position-based-accessor? v) (or (position-based-accessor? v)
(with-global-lock* (hashtable-ref struct-field-accessors v #f)))) (with-global-lock* (eq-hashtable-ref struct-field-accessors v #f))))
#t)) #t))
(define (struct-mutator-procedure? v) (define (struct-mutator-procedure? v)
(and (procedure? v) (and (procedure? v)
(let ([v (strip-impersonator v)]) (let ([v (strip-impersonator v)])
(or (position-based-mutator? v) (or (position-based-mutator? v)
(with-global-lock* (hashtable-ref struct-field-mutators v #f)))) (with-global-lock* (eq-hashtable-ref struct-field-mutators v #f))))
#t)) #t))
(define (struct-accessor-procedure-rtd+pos v) (define (struct-accessor-procedure-rtd+pos v)
(if (position-based-accessor? v) (if (position-based-accessor? v)
(cons (position-based-accessor-rtd v) (cons (position-based-accessor-rtd v)
(position-based-accessor-offset v)) (position-based-accessor-offset v))
(with-global-lock* (hashtable-ref struct-field-accessors v #f)))) (with-global-lock* (eq-hashtable-ref struct-field-accessors v #f))))
(define (struct-mutator-procedure-rtd+pos v) (define (struct-mutator-procedure-rtd+pos v)
(if (position-based-mutator? v) (if (position-based-mutator? v)
(cons (position-based-mutator-rtd v) (cons (position-based-mutator-rtd v)
(position-based-mutator-offset v)) (position-based-mutator-offset v))
(with-global-lock* (hashtable-ref struct-field-mutators v #f)))) (with-global-lock* (eq-hashtable-ref struct-field-mutators v #f))))
;; This indirection prevents the whole-program optimizer from inlining ;; This indirection prevents the whole-program optimizer from inlining
;; the `with-glocal-lock*` expansion --- which, at the time of ;; the `with-glocal-lock*` expansion --- which, at the time of