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

Use a weak hashtable to cache concrete instances

Browse Source
This commit is contained in:
Asumu Takikawa 2012-05-02 23:52:48 -04:00 committed by Stevie Strickland
parent 10967a22ce
commit ba8e879703
1 changed files with 85 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
collects/racket/private/class-internal.rkt
View File

@ -1863,6 +1863,8 @@
method-ids ; reverse-ordered list of public method names method-ids ; reverse-ordered list of public method names
method-ictcs ; list of indices of methods to fix for interface ctcs method-ictcs ; list of indices of methods to fix for interface ctcs
ictc-classes ; concretized versions of this class keyed by blame
methods ; vector of methods (for external dynamic dispatch) methods ; vector of methods (for external dynamic dispatch)
super-methods ; vector of methods (for subclass super calls) super-methods ; vector of methods (for subclass super calls)
int-methods ; vector of vector of methods (for internal dynamic dispatch) int-methods ; vector of vector of methods (for internal dynamic dispatch)
@ -2163,6 +2165,7 @@
(let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)]) (let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)])
make-) make-)
method-width method-ht method-names (interfaces->contracted-methods (list i)) method-width method-ht method-names (interfaces->contracted-methods (list i))
(make-weak-hasheq)
methods super-methods int-methods beta-methods meth-flags methods super-methods int-methods beta-methods meth-flags
inner-projs dynamic-idxs dynamic-projs inner-projs dynamic-idxs dynamic-projs
field-width field-pub-width field-ht field-names field-width field-pub-width field-ht field-names
@ -2808,6 +2811,8 @@ An example
(class-method-ids cls) (class-method-ids cls)
null null
(make-weak-hasheq)
methods methods
super-methods super-methods
int-methods int-methods
@ -3649,6 +3654,7 @@ An example
void ; never inspectable void ; never inspectable
0 (make-hasheq) null null 0 (make-hasheq) null null
(make-weak-hasheq)
(vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector)
(vector) (vector) (vector) (vector) (vector) (vector)
@ -3776,88 +3782,93 @@ An example
;; class blame -> class ;; class blame -> class
;; takes a class and concretize interface ctc methods ;; takes a class and concretize interface ctc methods
(define (fetch-concrete-class cls blame) (define (fetch-concrete-class cls blame)
(if (null? (class-method-ictcs cls)) (cond [(null? (class-method-ictcs cls)) cls]
cls [(hash-ref (class-ictc-classes cls) blame (λ () #f)) => values]
;; if there are contracted methods to concretize, do so [else
(let* ([name (class-name cls)] ;; if there are contracted methods to concretize, do so
[method-width (class-method-width cls)] (let* ([name (class-name cls)]
[method-ht (class-method-ht cls)] [method-width (class-method-width cls)]
[meths (class-methods cls)] [method-ht (class-method-ht cls)]
[ictc-meths (class-method-ictcs cls)] [meths (class-methods cls)]
[field-pub-width (class-field-pub-width cls)] [ictc-meths (class-method-ictcs cls)]
[field-ht (class-field-ht cls)] [field-pub-width (class-field-pub-width cls)]
[class-make (if name [field-ht (class-field-ht cls)]
(make-naming-constructor [class-make (if name
struct:class (make-naming-constructor
(string->symbol (format "class:~a" name))) struct:class
make-class)] (string->symbol (format "class:~a" name)))
[c (class-make name make-class)]
(class-pos cls) [c (class-make name
(list->vector (vector->list (class-supers cls))) (class-pos cls)
(class-self-interface cls) (list->vector (vector->list (class-supers cls)))
void ;; No inspecting (class-self-interface cls)
void ;; No inspecting
method-width method-width
method-ht method-ht
(class-method-ids cls) (class-method-ids cls)
null null
meths (make-weak-hasheq)
(class-super-methods cls)
(class-int-methods cls)
(class-beta-methods cls)
(class-meth-flags cls)
(class-inner-projs cls) meths
(class-dynamic-idxs cls) (class-super-methods cls)
(class-dynamic-projs cls) (class-int-methods cls)
(class-beta-methods cls)
(class-meth-flags cls)
(class-field-width cls) (class-inner-projs cls)
field-pub-width (class-dynamic-idxs cls)
field-ht (class-dynamic-projs cls)
(class-field-ids cls)
'struct:object 'object? 'make-object (class-field-width cls)
'field-ref 'field-set! field-pub-width
field-ht
(class-field-ids cls)
(class-init-args cls) 'struct:object 'object? 'make-object
(class-init-mode cls) 'field-ref 'field-set!
(class-init cls)
(class-orig-cls cls) (class-init-args cls)
#f #f ; serializer is never set (class-init-mode cls)
#f)] (class-init cls)
[obj-name (if name
(string->symbol (format "wrapper-object:~a" name))
'object)])
(vector-set! (class-supers c) (class-pos c) c) (class-orig-cls cls)
#f #f ; serializer is never set
#f)]
[obj-name (if name
(string->symbol (format "wrapper-object:~a" name))
'object)])
;; --- Make the new object struct --- (vector-set! (class-supers c) (class-pos c) c)
(let-values ([(struct:object object-make object? object-field-ref object-field-set!)
(make-struct-type obj-name
(class-struct:object cls)
0 ;; No init fields
0 ;; No new fields in this class replacement
undefined
;; Map object property to class:
(list (cons prop:object c)))])
(set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)
(set-class-field-ref! c object-field-ref)
(set-class-field-set!! c object-field-set!))
;; then apply the projections to get the concrete method ;; --- Make the new object struct ---
(vector-copy! meths 0 (class-methods cls)) (let-values ([(struct:object object-make object? object-field-ref object-field-set!)
(for ([m (in-list ictc-meths)]) (make-struct-type obj-name
(define index (hash-ref method-ht m)) (class-struct:object cls)
(define entry (vector-ref meths index)) 0 ;; No init fields
(define meth (car entry)) 0 ;; No new fields in this class replacement
(define ictc-infos (replace-ictc-blame (cadr entry) #f blame)) undefined
(define wrapped-meth (concretize-ictc-method meth ictc-infos)) ;; Map object property to class:
(vector-set! meths index wrapped-meth)) (list (cons prop:object c)))])
c))) (set-class-struct:object! c struct:object)
(set-class-object?! c object?)
(set-class-make-object! c object-make)
(set-class-field-ref! c object-field-ref)
(set-class-field-set!! c object-field-set!))
;; then apply the projections to get the concrete method
(vector-copy! meths 0 (class-methods cls))
(for ([m (in-list ictc-meths)])
(define index (hash-ref method-ht m))
(define entry (vector-ref meths index))
(define meth (car entry))
(define ictc-infos (replace-ictc-blame (cadr entry) #f blame))
(define wrapped-meth (concretize-ictc-method meth ictc-infos))
(vector-set! meths index wrapped-meth))
(hash-set! (class-ictc-classes cls) blame c)
c)]))
;; method info -> method ;; method info -> method
;; appropriately wraps the method with interface contracts ;; appropriately wraps the method with interface contracts
@ -4700,6 +4711,8 @@ An example
(class-method-ids cls) (class-method-ids cls)
(class-method-ictcs cls) (class-method-ictcs cls)
(class-ictc-classes cls)
meths meths
(class-super-methods cls) (class-super-methods cls)
(class-int-methods cls) (class-int-methods cls)