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

Changes to define-generics: added #:defined-predicate; improved generated code.

Browse Source 
The #:defined-predicate option is like #:defined-table, but it defines a
two-argument predicate that only processes the requested method name and doesn't
allocate a hash table each time it is called.

Method implementations provided via #:fallbacks, #:defaults, and #:fast-defaults
are now called directly by method procedures rather than stored in a vector and
extracted by index.  This should hopefully improve inlining for methods.
This commit is contained in:
Carl Eastlund 2013-07-17 17:31:21 -04:00
parent 1f267d479c
commit d9890b843a
7 changed files with 119 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/data-lib/data/order.rkt
View File

@ -19,7 +19,7 @@
prop:ordered-dict
ordered-methods
ordered-dict?
dict-def-table)
ordered-dict-supports?)
#:fast-defaults ()
#:defaults ()
#:fallbacks ()

9
pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt
View File

@ -3,7 +3,7 @@
(require racket/generic)
(define-generics numeric
#:defined-table numeric-support
#:defined-predicate numeric-supports?
(decrement numeric)
(is-zero? numeric)
(is-even? numeric)
@ -19,19 +19,16 @@
(define (is-even?-fallback x)
(cond
[(supports? x 'is-odd?) (not (is-odd? x))]
[(numeric-supports? x 'is-odd?) (not (is-odd? x))]
[(is-zero? x) #true]
[else (is-odd? (decrement x))]))
(define (is-odd?-fallback x)
(cond
[(supports? x 'is-even?) (not (is-even? x))]
[(numeric-supports? x 'is-even?) (not (is-even? x))]
[(is-zero? x) #false]
[else (is-even? (decrement x))]))
(define (supports? x sym)
(hash-ref (numeric-support x) sym #f))
(struct peano-zero []
#:transparent
#:methods gen:numeric

2
pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt
View File

@ -21,7 +21,7 @@
(local-require racket/private/generic)
(define-primitive-generics
(foo gen:foo prop:foo foo-methods foo? dummy)
(foo gen:foo prop:foo foo-methods foo? foo-supports?)
#:fast-defaults ([number? (define (meth foo #:kw kw) kw)])
#:defaults ()
#:fallbacks ()

27
racket/collects/racket/generic.rkt
View File

@ -17,6 +17,14 @@
(define (parse stx [options (hasheq)])
(syntax-case stx ()
[(#:defined-predicate name . args)
(identifier? #'name)
(if (hash-ref options 'support #f)
(wrong-syntax (stx-car stx)
"duplicate #:defined-predicate specification")
(parse #'args (hash-set options 'support #'name)))]
[(#:defined-predicate . other)
(wrong-syntax (stx-car stx) "invalid #:defined-predicate specification")]
[(#:defined-table name . args)
(identifier? #'name)
(if (hash-ref options 'table #f)
@ -69,7 +77,8 @@
(wrong-syntax #'other
"expected a method identifier with formal arguments")]
[() (values (hash-ref options 'methods '())
(hash-ref options 'table generate-temporary)
(hash-ref options 'support generate-temporary)
(hash-ref options 'table #f)
(hash-ref options 'fast-defaults '())
(hash-ref options 'defaults '())
(hash-ref options 'fallbacks '())
@ -84,9 +93,9 @@
(parameterize ([current-syntax-context stx])
(unless (identifier? #'name)
(wrong-syntax #'name "expected an identifier"))
(define-values (methods table fast-defaults defaults fallbacks derived)
(define-values (methods support table fasts defaults fallbacks derived)
(parse #'rest))
(define/with-syntax [fast-default ...] fast-defaults)
(define/with-syntax [fast-default ...] fasts)
(define/with-syntax [default ...] defaults)
(define/with-syntax [fallback ...] fallbacks)
(define/with-syntax [derive ...] derived)
@ -100,17 +109,25 @@
(define/with-syntax gen-name (format-id #'name "gen:~a" #'name))
(define/with-syntax prop-name (generate-temporary #'name))
(define/with-syntax get-name (generate-temporary #'name))
(define/with-syntax table-name table)
(define/with-syntax support-name support)
(define/with-syntax original stx)
(define/with-syntax table-defn
(if table
(with-syntax ([table-name table])
#'(define (table-name name)
(for/hasheq ([sym (in-list '(method ...))])
(values sym (support-name name sym)))))
#'(begin)))
#'(begin
(define-primitive-generics/derived
original
(name gen-name prop-name get-name pred-name table-name)
(name gen-name prop-name get-name pred-name support-name)
#:fast-defaults [fast-default ...]
#:defaults [default ...]
#:fallbacks [fallback ...]
#:derive-properties [derive ...]
method ...)
table-defn
(define-generics-contract name pred-name get-name
[method-name method-index]
...)))]))

22
racket/collects/racket/private/dict.rkt
View File

@ -19,21 +19,21 @@
(define (mutable-vector? v)
(and (vector? v) (not (immutable? v))))
(define (dict-supports? who d . whats)
(unless (dict? d)
(raise-argument-error who "dict?" d))
(define table (dict-def-table d))
(for/or ([what (in-list whats)])
(hash-ref table what #f)))
(define (dict-mutable? d)
(dict-supports? 'dict-mutable? d 'dict-set!))
(unless (dict? d)
(raise-argument-error 'dict-mutable? "dict?" d))
(dict-supports? d 'dict-set!))
(define (dict-can-remove-keys? d)
(dict-supports? 'dict-can-remove-keys? d 'dict-remove! 'dict-remove))
(unless (dict? d)
(raise-argument-error 'dict-can-remove-keys? "dict?" d))
(or (dict-supports? d 'dict-remove!)
(dict-supports? d 'dict-remove)))
(define (dict-can-functional-set? d)
(dict-supports? 'dict-can-functional-set? d 'dict-set))
(unless (dict? d)
(raise-argument-error 'dict-can-functional-set? "dict?" d))
(dict-supports? d 'dict-set))
(define (dict-has-key? d k)
(define not-there (gensym))
@ -178,7 +178,7 @@
i)))
(define-primitive-generics
(dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-def-table)
(dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-supports?)
#:fast-defaults
([mutable-hash?
(define dict-ref hash-ref)

12
racket/collects/racket/private/generic-methods.rkt
View File

@ -6,6 +6,7 @@
(#%provide define/generic
generic-property
generic-methods
generic-method-table
(for-syntax generic-info?
make-generic-info
@ -72,11 +73,11 @@
[(_ gen)
(generic-info-property (get-info 'generic-property stx #'gen))]))
(define-syntax (generic-method-table stx)
(define-syntax (generic-methods stx)
(syntax-case stx ()
[(_ gen def ...)
(let ()
(define info (get-info 'generic-method-table stx #'gen))
(define info (get-info 'generic-methods stx #'gen))
(define delta (syntax-local-make-delta-introducer #'gen))
(define methods (map delta (generic-info-methods info)))
(with-syntax ([(method ...) methods])
@ -86,7 +87,12 @@
([(method) (make-unimplemented 'method)] ...)
()
def ...
(vector (implementation method) ...))))))]))
(values (implementation method) ...))))))]))
(define-syntax (generic-method-table stx)
(syntax-case stx ()
[(_ gen def ...)
#'(call-with-values (lambda () (generic-methods gen def ...)) vector)]))
(define-syntax (define/generic stx)
(define gen-id (syntax-parameter-value #'generic-method-context))

124
racket/collects/racket/private/generic.rkt
View File

@ -49,31 +49,43 @@
(check-identifier! #'self-name)
(define methods (syntax->list #'(method-name ...)))
(for-each check-identifier! methods)
(define n (length methods))
(define method-indices (for/list ([i (in-range n)]) i))
(define fast-preds (syntax->list #'(fast-pred ...)))
(define default-preds (syntax->list #'(default-pred ...)))
(define (generate-methods . ignore) (generate-temporaries methods))
(define (transpose-methods names)
(map cdr (apply map list methods names)))
(define fasts-by-type (map generate-methods fast-preds))
(define fasts-by-method (transpose-methods fasts-by-type))
(define defaults-by-type (map generate-methods default-preds))
(define defaults-by-method (transpose-methods defaults-by-type))
(define/with-syntax size n)
(define/with-syntax [method-index ...] method-indices)
(define/with-syntax contract-str
(format "~s" (syntax-e #'predicate-name)))
(define/with-syntax (default-pred-name ...)
(generate-temporaries #'(default-pred ...)))
(define/with-syntax (default-impl-name ...)
(generate-temporaries #'(default-pred ...)))
(generate-temporaries default-preds))
(define/with-syntax (fast-pred-name ...)
(generate-temporaries #'(fast-pred ...)))
(define/with-syntax (fast-impl-name ...)
(generate-temporaries #'(fast-pred ...)))
(define/with-syntax fallback-name
(generate-temporary #'self-name))
(generate-temporaries fast-preds))
(define/with-syntax ([fast-by-method ...] ...) fasts-by-method)
(define/with-syntax ([fast-by-type ...] ...) fasts-by-type)
(define/with-syntax ([default-by-method ...] ...) defaults-by-method)
(define/with-syntax ([default-by-type ...] ...) defaults-by-type)
(define/with-syntax [fallback ...] (generate-methods))
(define/with-syntax forward-declaration
(if (eq? (syntax-local-context) 'top-level)
#'(define-syntaxes (fast-pred-name ...
fast-impl-name ...
default-pred-name ...
default-impl-name ...
fallback-name)
fast-by-method ... ...
default-by-method ... ...
fallback ...)
(values))
#'(begin)))
#'(begin
(define-syntax generic-name
(make-generic-info (quote-syntax property-name)
@ -103,74 +115,78 @@
...)
#t))
forward-declaration
(define fast-pred-name fast-pred)
...
(define default-pred-name default-pred)
...
(define (predicate-name self-name)
(or (fast-pred-name self-name)
...
(prop:pred self-name)
(default-pred-name self-name)
...))
(define (table-name self-name [who 'table-name])
(define (supported-name self-name . syms)
(define (bad-sym sym)
(raise-argument-error 'supported-name
(format "~s" '(or/c 'method-name ...))
sym))
(cond
[(fast-pred-name self-name) fast-impl-name]
[(fast-pred-name self-name)
(for/and ([sym (in-list syms)])
(case sym
[(method-name) (procedure? fast-by-type)]
...
[(prop:pred self-name) (accessor-name self-name)]
[(default-pred-name self-name) default-impl-name]
[else (bad-sym sym)]))]
...
[else (raise-argument-error who 'contract-str self-name)]))
(define fast-pred-name fast-pred)
[(prop:pred self-name)
(define table (accessor-name self-name))
(for/and ([sym (in-list syms)])
(case sym
[(method-name)
(procedure? (vector-ref table 'method-index))]
...
(define default-pred-name default-pred)
[else (bad-sym sym)]))]
[(default-pred-name self-name)
(for/and ([sym (in-list syms)])
(case sym
[(method-name) (procedure? default-by-type)]
...
(define-generic-support supported-name
self-name
[method-name ...]
(table-name self-name 'supported-name)
original)
[else (bad-sym sym)]))]
...
[else (raise-argument-error 'supported-name
'contract-str
self-name)]))
(define-generic-method
method-name
method-signature
self-name
(or (vector-ref (table-name self-name 'method-name) 'method-index)
(vector-ref fallback-name 'method-index))
(or (cond
[(fast-pred-name self-name) fast-by-method]
...
[(prop:pred self-name)
(vector-ref (accessor-name self-name) 'method-index)]
[(default-pred-name self-name) default-by-method]
...
[else (raise-argument-error 'method-name
'contract-str
self-name)])
fallback)
original)
...
(define fast-impl-name
(generic-method-table generic-name fast-defn ...))
(define-values (fast-by-type ...)
(generic-methods generic-name fast-defn ...))
...
(define default-impl-name
(generic-method-table generic-name default-defn ...))
(define-values (default-by-type ...)
(generic-methods generic-name default-defn ...))
...
(define fallback-name
(generic-method-table generic-name fallback-defn ...))))]))
(define-values (fallback ...)
(generic-methods generic-name fallback-defn ...))))]))
(define-syntax (define-primitive-generics stx)
(syntax-case stx ()
[(_ . args)
#`(define-primitive-generics/derived #,stx . args)]))
(define-syntax (define-generic-support stx)
(syntax-case stx ()
[(_ supported-name
self-name
[method-name ...]
table
original)
(parameterize ([current-syntax-context #'original])
(check-identifier! #'supported-name)
(check-identifier! #'self-name)
(for-each check-identifier! (syntax->list #'(method-name ...)))
(define/with-syntax (index ...)
(for/list ([idx (in-naturals)]
[stx (in-list (syntax->list #'(method-name ...)))])
idx))
#'(define (supported-name self-name)
(define v table)
(make-immutable-hasheqv
(list
(cons 'method-name
(procedure? (vector-ref v 'index)))
...))))]))
(begin-for-syntax
(define (method-formals/application name-stx proc-stx self-id sig-stx)