From 1900c0e57a0639a4193d476c75acbacbe2b90915 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 7 Feb 2020 20:32:03 -0700 Subject: [PATCH] cs: faster struct impersonation --- .../racket/benchmarks/chaperone/config.rkt | 26 +++ .../racket/benchmarks/chaperone/struct.rkt | 161 +++++++++++++ racket/src/cs/demo/chaperone.ss | 4 +- racket/src/cs/rumble/impersonator.ss | 218 ++++++++++-------- racket/src/cs/rumble/struct.ss | 14 +- 5 files changed, 319 insertions(+), 104 deletions(-) create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/config.rkt create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/struct.rkt diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/config.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/config.rkt new file mode 100644 index 0000000000..28be5db139 --- /dev/null +++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/config.rkt @@ -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))))])) diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/struct.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/struct.rkt new file mode 100644 index 0000000000..4bf8df9cdc --- /dev/null +++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/chaperone/struct.rkt @@ -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)))) diff --git a/racket/src/cs/demo/chaperone.ss b/racket/src/cs/demo/chaperone.ss index f0d3e84516..3e8ffeb02b 100644 --- a/racket/src/cs/demo/chaperone.ss +++ b/racket/src/cs/demo/chaperone.ss @@ -128,7 +128,7 @@ (check (chaperone-of? fc f) #t) (check (chaperone-of? fi f) #f) (check (chaperone-of? fi fc) #f) -(check (chaperone-of? fc fi) #t) +(check (chaperone-of? fc fi) #f) (define fc2 (chaperone-procedure f (lambda (x y) @@ -348,7 +348,7 @@ (check (ops!) '(set equal-key)) (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 (hash-remove! ht2c 1) (hash-ref ht2c 1 'none)) diff --git a/racket/src/cs/rumble/impersonator.ss b/racket/src/cs/rumble/impersonator.ss index 7f3422f8e5..83ec745293 100644 --- a/racket/src/cs/rumble/impersonator.ss +++ b/racket/src/cs/rumble/impersonator.ss @@ -22,22 +22,41 @@ "original" e "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) (#%$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) - (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 [(and (impersonator? orig) (or (not rtd) (record? (impersonator-val orig) rtd))) (let loop ([v orig]) (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) (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 [wrapper (let* ([r (cond @@ -55,16 +74,13 @@ new-r)] [else (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) (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 (raise-argument-error (string->symbol (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) (#%$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) (cond [(and (impersonator? orig) (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]) (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) (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 [wrapper (let ([new-a (cond @@ -102,15 +129,11 @@ (loop (impersonator-next v) new-a)]))] [else (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) (loop (impersonator-next v) a)] - [else (set v a)])))] + [else + ;; Equivalent to `(set v a)`: + (unsafe-struct*-set! v abs-pos a)])))] [else (raise-argument-error (string->symbol (string-append "set" @@ -347,59 +370,57 @@ "value" v)) (let loop ([first? (not st)] [args orig-args] - [props empty-hash] - [saw-props empty-hash] + [props empty-hasheq] + [saw-props empty-hasheq] [witnessed? (and st #t)] [iprops orig-iprops]) (let ([get-proc - (lambda (what args arity proc->key key-applies?) - (let* ([orig-proc (car args)] - [key-proc (strip-impersonator orig-proc)] - [key (proc->key key-proc)]) - (when (hash-ref saw-props key #f) - (raise-arguments-error who - "given operation accesses the same value as a previous operation argument" - "operation kind" what - "operation procedure" orig-proc)) - (when key-applies? - (unless (key-applies? key val) + (lambda (what args arity orig-proc key1 key2 key-applies? now-witnessed?) + (unless key-applies? + (raise-arguments-error who + "operation does not apply to given value" + "operation kind" (make-unquoted-printing-string what) + "operation procedure" orig-proc + "value" v)) + (when (hash-ref2 saw-props key1 key2 #f) + (raise-arguments-error who + "given operation accesses the same value as a previous operation argument" + "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 - "operation does not apply to given value" - "operation kind" what - "operation procedure" orig-proc - "value" v))) - (when (null? (cdr args)) + "operation's redirection procedure does not match the expected arity" + "given" proc + "expected" (make-unquoted-printing-string + (string-append + "(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 - "missing redirection procedure after operation" - "operation kind" what - "operation procedure" orig-proc)) - (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)) + "impersonated operation cannot be used to create a chaperone" + "operation" orig-proc)) + (let ([new-args (cddr args)]) (loop #f - (cddr args) + new-args (if proc - (hash-set props key - (if (impersonator? orig-proc) - (cons orig-proc ; save original accessor, in case it's impersonated - proc) ; the interposition proc - proc)) + (hash-set2 props key1 key2 + (if (impersonator? orig-proc) + (cons orig-proc ; save original accessor, in case it's impersonated + proc) ; the interposition proc + proc)) props) - (hash-set saw-props key #t) - (or witnessed? key-applies?) + (if (null? new-args) saw-props (hash-set2 saw-props key1 key2 #t)) + (or witnessed? now-witnessed?) iprops))))]) (cond [(null? args) @@ -422,7 +443,7 @@ " instance of an authentic structure type") "given value" v)) (cond - [(zero? (hash-count props)) + [(eq? props empty-hasheq) ;; No structure operations chaperoned, so either unchanged or ;; a properties-only impersonator (cond @@ -463,39 +484,46 @@ witnessed? (add-impersonator-properties who args iprops))] [(struct-accessor-procedure? (car args)) - (get-proc "accessor" args 2 - struct-accessor-procedure-rtd+pos - (lambda (rtd+pos v) - (and (record? v (car rtd+pos)) - (begin - (unless (or as-chaperone? - (struct-type-field-mutable? (car rtd+pos) (cdr rtd+pos))) - (raise-arguments-error who - "cannot replace operation for an immutable field" - "operation kind" "property accessor" - "operation procedure" (car args))) - #t))))] + (let* ([orig-proc (car args)] + [key-proc (strip-impersonator orig-proc)] + [rtd+pos (struct-accessor-procedure-rtd+pos key-proc)]) + (unless (or as-chaperone? + (struct-type-field-mutable? (car rtd+pos) (cdr rtd+pos))) + (raise-arguments-error who + "cannot replace operation for an immutable field" + "operation kind" (make-unquoted-printing-string "property accessor") + "operation procedure" (car args))) + (get-proc "accessor" args 2 + orig-proc (car rtd+pos) (cdr rtd+pos) + (record? val (car rtd+pos)) + #t))] [(struct-mutator-procedure? (car args)) - (get-proc "mutator" args 2 - (lambda (proc) - (let ([rtd+pos (struct-mutator-procedure-rtd+pos proc)]) - (vector (car rtd+pos) (cdr rtd+pos)))) - (lambda (rtd++pos v) - (record? v (vector-ref rtd++pos 0))))] + (let* ([orig-proc (car args)] + [key-proc (strip-impersonator orig-proc)] + [rtd+pos (struct-mutator-procedure-rtd+pos key-proc)]) + (get-proc "mutator" args 2 + orig-proc (car rtd+pos) (struct-mutator-pos->key2 (cdr rtd+pos)) + (record? val (car rtd+pos)) + #t))] [(struct-type-property-accessor-procedure? (car args)) - (get-proc "property accessor" args 2 - (lambda (proc) proc) - (lambda (proc v) - (unless (or as-chaperone? - (struct-type-property-accessor-procedure-can-impersonate? proc)) - (raise-arguments-error who - "operation cannot be impersonated" - "operation kind" "property accessor" - "operation procedure" (car args))) - ((struct-type-property-accessor-procedure-pred proc) v)))] + (let* ([orig-proc (car args)] + [key-proc (strip-impersonator orig-proc)]) + (unless (or as-chaperone? + (struct-type-property-accessor-procedure-can-impersonate? key-proc)) + (raise-arguments-error who + "operation cannot be impersonated" + "operation kind" (make-unquoted-printing-string "property accessor") + "operation procedure" orig-proc)) + (get-proc "property accessor" args 2 + orig-proc key-proc #f + ((struct-type-property-accessor-procedure-pred key-proc) val) + #t))] [(and as-chaperone? (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 (raise-argument-error who (string-append diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index 0cc07f20be..e65b6678c8 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -82,7 +82,7 @@ (cond [(and (impersonator? 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 (let* ([rtd (if (record-type-descriptor? v) v @@ -406,38 +406,38 @@ (define (struct-constructor-procedure? v) (and (procedure? 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) (and (procedure? 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) (and (procedure? v) (let ([v (strip-impersonator 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)) (define (struct-mutator-procedure? v) (and (procedure? v) (let ([v (strip-impersonator 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)) (define (struct-accessor-procedure-rtd+pos v) (if (position-based-accessor? v) (cons (position-based-accessor-rtd 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) (if (position-based-mutator? v) (cons (position-based-mutator-rtd 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 ;; the `with-glocal-lock*` expansion --- which, at the time of