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

Okay, expanding field accesses and mutations to basically inline the

Browse Source 
unwrapping operation helps a bit, especially with inherited fields.
Unfortunately, as one might expect, TANSTAAFL applies here.  In order
to make sure that we keep the contracted objects around as much as
possible to make sure there are no holes, we end up making local and
inherited field access codes 2-3x more than they did before.  However,
this is still something on the order of 5x faster than external
access.  But blah.

CONTRACTS ARE NOT FREE.  Just ask your local lawyer.

svn: r18285
This commit is contained in:
Stevie Strickland 2010-02-23 03:15:43 +00:00
parent 53381bbf03
commit 14ab0175c3
2 changed files with 47 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
collects/scheme/private/class-internal.ss
View File

@ -194,6 +194,26 @@
"used before its definition: ~a" "used before its definition: ~a"
orig))) orig)))
;;--------------------------------------------------------------------
;; object wrapper for contracts
;;--------------------------------------------------------------------
(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
(let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
(make-struct-type 'raw-wrapper-object
#f
1
0)])
(values wrapper-object?
(lambda (v) (ref v 0))
(lambda (o v) (set! o 0 v))
struct:wrapper-object)))
;; unwrap-object : (union wrapper-object object) -> object
;; wrapped objects can only be one level deep, so just do a quick check and unwrap.
(define (unwrap-object o)
(if (wrapper-object? o) (wrapper-object-wrapped o) o))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; class macros ;; class macros
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
@ -1165,6 +1185,7 @@
(make-field-map trace-flag (make-field-map trace-flag
(quote-syntax the-finder) (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax unwrap-object)
(quote-syntax inherit-field-name) (quote-syntax inherit-field-name)
(quote-syntax inherit-field-name-localized) (quote-syntax inherit-field-name-localized)
(quote-syntax inherit-field-accessor) (quote-syntax inherit-field-accessor)
@ -1174,6 +1195,7 @@
(make-field-map trace-flag (make-field-map trace-flag
(quote-syntax the-finder) (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax unwrap-object)
(quote-syntax local-field) (quote-syntax local-field)
(quote-syntax local-field-localized) (quote-syntax local-field-localized)
(quote-syntax local-field-accessor) (quote-syntax local-field-accessor)
@ -1749,26 +1771,6 @@
a)) a))
(eq-hash-code (member-key-id a))) (eq-hash-code (member-key-id a)))
;;--------------------------------------------------------------------
;; object wrapper for contracts
;;--------------------------------------------------------------------
(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
(let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
(make-struct-type 'raw-wrapper-object
#f
1
0)])
(values wrapper-object?
(lambda (v) (ref v 0))
(lambda (o v) (set! o 0 v))
struct:wrapper-object)))
;; unwrap-object : (union wrapper-object object) -> object
;; wrapped objects can only be one level deep, so just do a quick check and unwrap.
(define (unwrap-object o)
(if (wrapper-object? o) (wrapper-object-wrapped o) o))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; class implementation ;; class implementation
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
@ -2179,19 +2181,15 @@
;; Use public field names to name the accessors and mutators ;; Use public field names to name the accessors and mutators
(let-values ([(local-accessors local-mutators) (let-values ([(local-accessors local-mutators)
(values (for/list ([n (in-range num-fields)]) (values (for/list ([n (in-range num-fields)])
(let ([acc (make-struct-field-accessor object-field-ref n #f)]) (make-struct-field-accessor object-field-ref n #f))
(λ (o) (acc (unwrap-object o)))))
(for/list ([n (in-range num-fields)]) (for/list ([n (in-range num-fields)])
(let ([acc (make-struct-field-mutator object-field-set! n #f)]) (make-struct-field-mutator object-field-set! n #f)))]
(λ (o v) (acc (unwrap-object o) v)))))]
[(inh-accessors inh-mutators) [(inh-accessors inh-mutators)
(values (map (lambda (id) (values (map (lambda (id)
(let ([i (hash-ref field-ht id)]) (vector-ref int-field-refs (hash-ref field-ht id)))
(λ (o) ((vector-ref (class-int-field-refs (object-ref o)) i) o))))
inherit-field-names) inherit-field-names)
(map (lambda (id) (map (lambda (id)
(let ([i (hash-ref field-ht id)]) (vector-ref int-field-sets (hash-ref field-ht id)))
(λ (o v) ((vector-ref (class-int-field-sets (object-ref o)) i) o v))))
inherit-field-names))]) inherit-field-names))])
;; -- Extract superclass methods and make rename-inners --- ;; -- Extract superclass methods and make rename-inners ---
@ -2731,11 +2729,9 @@
[old-ref (vector-ref ext-field-refs i)] [old-ref (vector-ref ext-field-refs i)]
[old-set (vector-ref ext-field-sets i)]) [old-set (vector-ref ext-field-sets i)])
(vector-set! ext-field-refs i (vector-set! ext-field-refs i
(λ (o) (λ (o) ((pre-p blame) (old-ref o))))
((pre-p blame) (old-ref o))))
(vector-set! ext-field-sets i (vector-set! ext-field-sets i
(λ (o v) (λ (o v) (old-set o ((pre-p bset) v)))))))))
(old-set o ((pre-p bset) v)))))))))
;; Handle internal field contracts ;; Handle internal field contracts
(unless (null? (class/c-inherit-fields ctc)) (unless (null? (class/c-inherit-fields ctc))
@ -2750,11 +2746,9 @@
[old-ref (vector-ref int-field-refs i)] [old-ref (vector-ref int-field-refs i)]
[old-set (vector-ref int-field-sets i)]) [old-set (vector-ref int-field-sets i)])
(vector-set! int-field-refs i (vector-set! int-field-refs i
(λ (o) (λ (o) ((pre-p blame) (old-ref o))))
((pre-p blame) (old-ref o))))
(vector-set! int-field-sets i (vector-set! int-field-sets i
(λ (o v) (λ (o v) (old-set o ((pre-p bset) v)))))))))
(old-set o ((pre-p bset) v)))))))))
;; Now the trickiest of them all, internal dynamic dispatch. ;; Now the trickiest of them all, internal dynamic dispatch.
;; First we update any dynamic indexes, as applicable. ;; First we update any dynamic indexes, as applicable.
@ -4364,21 +4358,13 @@
[p ((contract-projection c) blame)]) [p ((contract-projection c) blame)])
(vector-set! meths i (p (vector-ref meths i))))))) (vector-set! meths i (p (vector-ref meths i)))))))
;; Redirect internal/external field accessors/mutators ;; Fix up internal/external field accessors/mutators
(let ([old-int-refs (class-int-field-refs cls)] ;; Normally we'd redirect these, but since make-field-map now unwraps
[old-int-sets (class-int-field-sets cls)] ;; on all accesses, we just copy over the old vectors.
[old-ext-refs (class-ext-field-refs cls)] (vector-copy! int-field-refs 0 (class-int-field-refs cls))
[old-ext-sets (class-ext-field-sets cls)]) (vector-copy! int-field-sets 0 (class-int-field-sets cls))
(for ([i (in-range field-pub-width)]) (vector-copy! ext-field-refs 0 (class-ext-field-refs cls))
(let ([old-int-ref (vector-ref old-int-refs i)] (vector-copy! ext-field-sets 0 (class-ext-field-sets cls))
[old-int-set (vector-ref old-int-sets i)]
[old-ext-ref (vector-ref old-ext-refs i)]
[old-ext-set (vector-ref old-ext-sets i)])
;; Take in the object, then completely ignore it.
(vector-set! int-field-refs i (λ (o) (old-int-ref obj)))
(vector-set! int-field-sets i (λ (o v) (old-int-set obj v)))
(vector-set! ext-field-refs i (λ (o) (old-ext-ref obj)))
(vector-set! ext-field-sets i (λ (o v) (old-ext-set obj v))))))
;; Handle external field contracts ;; Handle external field contracts
(unless (null? fields) (unless (null? fields)
@ -4391,11 +4377,9 @@
[old-ref (vector-ref ext-field-refs i)] [old-ref (vector-ref ext-field-refs i)]
[old-set (vector-ref ext-field-sets i)]) [old-set (vector-ref ext-field-sets i)])
(vector-set! ext-field-refs i (vector-set! ext-field-refs i
(λ (o) (λ (o) ((pre-p blame) (old-ref o))))
((pre-p blame) (old-ref o))))
(vector-set! ext-field-sets i (vector-set! ext-field-sets i
(λ (o v) (λ (o v) (old-set o ((pre-p bset) v)))))))))
(old-set o ((pre-p bset) v)))))))))
c)) c))

11
collects/scheme/private/classidmap.ss
View File

@ -59,7 +59,7 @@
[(f . args) [(f . args)
(quasisyntax/loc stx (#,replace-stx . args))]))))) (quasisyntax/loc stx (#,replace-stx . args))])))))
(define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized (define (make-field-map trace-flag the-finder the-obj unwrapper the-binder the-binder-localized
field-accessor field-mutator field-pos/null) field-accessor field-mutator field-pos/null)
(let ([set!-stx (datum->syntax the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
@ -73,7 +73,8 @@
[trace (syntax/loc stx (set-event obj (quote id) id))] [trace (syntax/loc stx (set-event obj (quote id) id))]
[set (quasisyntax/loc stx [set (quasisyntax/loc stx
((unsyntax field-mutator) ((unsyntax field-mutator)
obj (unsyntax-splicing field-pos/null) id))]) ((unsyntax unwrapper) obj)
(unsyntax-splicing field-pos/null) id))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace set)) (syntax/loc stx (let* bindings trace set))
(syntax/loc stx (let* bindings set))))] (syntax/loc stx (let* bindings set))))]
@ -82,7 +83,8 @@
[trace (syntax/loc stx (get-event obj (quote id)))] [trace (syntax/loc stx (get-event obj (quote id)))]
[call (quasisyntax/loc stx [call (quasisyntax/loc stx
(((unsyntax field-accessor) (((unsyntax field-accessor)
obj-expr (unsyntax-splicing field-pos/null)) . args))]) ((unsyntax unwrapper) obj-expr)
(unsyntax-splicing field-pos/null)) . args))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace call)) (syntax/loc stx (let* bindings trace call))
(syntax/loc stx (let* bindings call))))] (syntax/loc stx (let* bindings call))))]
@ -91,7 +93,8 @@
[trace (syntax/loc stx (get-event obj (quote id)))] [trace (syntax/loc stx (get-event obj (quote id)))]
[get (quasisyntax/loc stx [get (quasisyntax/loc stx
((unsyntax field-accessor) ((unsyntax field-accessor)
obj-expr (unsyntax-splicing field-pos/null)))]) ((unsyntax unwrapper) obj-expr)
(unsyntax-splicing field-pos/null)))])
(if trace-flag (if trace-flag
(syntax/loc stx (let* bindings trace get)) (syntax/loc stx (let* bindings trace get))
(syntax/loc stx (let* bindings get))))])))))) (syntax/loc stx (let* bindings get))))]))))))