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

Added #:fast-defaults option to define-generics.

Browse Source 
For datatypes that are disjoint with structs that might implement the generic,
this adds a "fast path" implementation that doesn't need to test for struct
properties.
This commit is contained in:
Carl Eastlund 2013-07-17 15:51:46 -04:00
parent 7deb4ad025
commit 1f267d479c
6 changed files with 57 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -20,6 +20,7 @@
ordered-methods
ordered-dict?
dict-def-table)
#:fast-defaults ()
#:defaults ()
#:fallbacks ()
#:derive-properties ()

7
pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt
View File

@ -7,13 +7,14 @@
(stream-first stream)
(stream-rest stream)
(stream-empty? stream)
#:defaults
#:fast-defaults
([list?
(define my-car car)
(define stream-first my-car)
(define stream-rest cdr)
(define stream-empty? null?)]
[s:stream?
(define stream-empty? null?)])
#:defaults
([s:stream?
(define stream-first s:stream-first)
(define stream-rest s:stream-rest)
(define stream-empty? s:stream-empty?)]))

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

@ -22,7 +22,8 @@
(define-primitive-generics
(foo gen:foo prop:foo foo-methods foo? dummy)
#:defaults ([number? (define (meth foo #:kw kw) kw)])
#:fast-defaults ([number? (define (meth foo #:kw kw) kw)])
#:defaults ()
#:fallbacks ()
#:derive-properties ()
(meth foo #:kw kw))

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

@ -31,6 +31,16 @@
(parse #'args (hash-set options 'defaults #'([pred defn ...] ...))))]
[(#:defaults . other)
(wrong-syntax (stx-car stx) "invalid #:defaults specification")]
[(#:fast-defaults ([pred defn ...] ...) . args)
(if (hash-ref options 'fast-defaults #f)
(wrong-syntax (stx-car stx)
"duplicate #:fast-defaults specification")
(parse #'args
(hash-set options
'fast-defaults
#'([pred defn ...] ...))))]
[(#:fast-defaults . other)
(wrong-syntax (stx-car stx) "invalid #:fast-defaults specification")]
[(#:fallbacks [fallback ...] . args)
(if (hash-ref options 'fallbacks #f)
(wrong-syntax (stx-car stx) "duplicate #:fallbacks specification")
@ -60,6 +70,7 @@
"expected a method identifier with formal arguments")]
[() (values (hash-ref options 'methods '())
(hash-ref options 'table generate-temporary)
(hash-ref options 'fast-defaults '())
(hash-ref options 'defaults '())
(hash-ref options 'fallbacks '())
(hash-ref options 'derived '()))]
@ -73,8 +84,9 @@
(parameterize ([current-syntax-context stx])
(unless (identifier? #'name)
(wrong-syntax #'name "expected an identifier"))
(define-values (methods table defaults fallbacks derived)
(define-values (methods table fast-defaults defaults fallbacks derived)
(parse #'rest))
(define/with-syntax [fast-default ...] fast-defaults)
(define/with-syntax [default ...] defaults)
(define/with-syntax [fallback ...] fallbacks)
(define/with-syntax [derive ...] derived)
@ -94,6 +106,7 @@
(define-primitive-generics/derived
original
(name gen-name prop-name get-name pred-name table-name)
#:fast-defaults [fast-default ...]
#:defaults [default ...]
#:fallbacks [fallback ...]
#:derive-properties [derive ...]

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

@ -179,7 +179,7 @@
(define-primitive-generics
(dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-def-table)
#:defaults
#:fast-defaults
([mutable-hash?
(define dict-ref hash-ref)
(define dict-set! hash-set!)
@ -222,6 +222,7 @@
(define dict-iterate-next assoc-iterate-next)
(define dict-iterate-key assoc-iterate-key)
(define dict-iterate-value assoc-iterate-value)])
#:defaults ()
#:fallbacks ()
#:derive-properties ()
(dict-ref dict key [default])

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

@ -34,6 +34,7 @@
accessor-name
predicate-name
supported-name)
#:fast-defaults ([fast-pred fast-defn ...] ...)
#:defaults ([default-pred default-defn ...] ...)
#:fallbacks [fallback-defn ...]
#:derive-properties ([derived-prop derived-impl] ...)
@ -54,21 +55,25 @@
(define/with-syntax [method-index ...] method-indices)
(define/with-syntax contract-str
(format "~s" (syntax-e #'predicate-name)))
(define/with-syntax ([default-pred-name default-impl-name] ...)
(for/list ([pred-stx (in-list (syntax->list #'(default-pred ...)))]
[i (in-naturals 0)])
(list (format-id (syntax-local-introduce #'self-name)
"~a-default-pred~a"
#'self-name
i)
(format-id (syntax-local-introduce #'self-name)
"~a-default-impl~a"
#'self-name
i))))
(define/with-syntax (default-pred-name ...)
(generate-temporaries #'(default-pred ...)))
(define/with-syntax (default-impl-name ...)
(generate-temporaries #'(default-pred ...)))
(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
(format-id (syntax-local-introduce #'self-name)
"~a-fallback"
#'self-name))
(generate-temporary #'self-name))
(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)
(values))
#'(begin)))
#'(begin
(define-syntax generic-name
(make-generic-info (quote-syntax property-name)
@ -97,16 +102,25 @@
derived-impl)))
...)
#t))
forward-declaration
(define (predicate-name self-name)
(or (prop:pred self-name) (default-pred-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])
(cond
[(fast-pred-name self-name) fast-impl-name]
...
[(prop:pred self-name) (accessor-name self-name)]
[(default-pred-name self-name) default-impl-name]
...
[else (raise-argument-error who 'contract-str self-name)]))
(define-values (default-pred-name ...)
(values default-pred ...))
(define fast-pred-name fast-pred)
...
(define default-pred-name default-pred)
...
(define-generic-support supported-name
self-name
[method-name ...]
@ -120,6 +134,9 @@
(vector-ref fallback-name 'method-index))
original)
...
(define fast-impl-name
(generic-method-table generic-name fast-defn ...))
...
(define default-impl-name
(generic-method-table generic-name default-defn ...))
...