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

Added #:dispatch option for clauses in #:defaults and #:fast-defaults.

Browse Source 
The #:dispatch option specifies a second, less strict predicate for a #:defaults
or #:fast-defaults clause.  The main predicate is still used for the generics
group's type predicate, but the dispatch predicate is used in choosing which
method implementation to use.  The #:dispatch option is useful when the dispatch
predicate is disjoint from all other instances, is significantly cheaper to run
than the main predicate, and the full checks can be meaningfully deferred in
method implementations.

Specifically, this is useful in the implementation of iteration for
association-list dictionaries.  The dict-iterate-{next,key,value} functions do
not need to test (andmap pair? dict) if the given dict is eq? to the one stored
in the given iterator.  The dispatch predicate, list?, is much cheaper.
This commit is contained in:
Carl Eastlund 2013-07-17 20:21:05 -04:00
parent d9890b843a
commit 97b78ace5b
4 changed files with 113 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

@ -33,20 +33,54 @@
(parse #'args (hash-set options 'table #'name)))]
[(#:defined-table . other)
(wrong-syntax (stx-car stx) "invalid #:defined-table specification")]
[(#:defaults ([pred defn ...] ...) . args)
[(#:defaults (clause ...) . args)
(if (hash-ref options 'defaults #f)
(wrong-syntax (stx-car stx) "duplicate #:defaults specification")
(parse #'args (hash-set options 'defaults #'([pred defn ...] ...))))]
(let loop ([defaults '()]
[defns (hash-ref options 'defns '())]
[clauses (reverse (syntax->list #'(clause ...)))])
(if (pair? clauses)
(syntax-case (car clauses) ()
[(pred #:dispatch disp defn ...)
(loop (cons #'[pred disp defn ...] defaults)
defns
(cdr clauses))]
[(pred defn ...)
(with-syntax ([name (generate-temporary #'pred)])
(loop (cons #'[name name defn ...] defaults)
(cons #'(define name pred) defns)
(cdr clauses)))]
[clause
(wrong-syntax #'clause "invalid #:defaults specification")])
(parse #'args
(hash-set* options 'defaults defaults 'defns defns)))))]
[(#:defaults . other)
(wrong-syntax (stx-car stx) "invalid #:defaults specification")]
[(#:fast-defaults ([pred defn ...] ...) . args)
[(#:fast-defaults (clause ...) . 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 ...] ...))))]
(let loop ([fast-defaults '()]
[defns (hash-ref options 'defns '())]
[clauses (reverse (syntax->list #'(clause ...)))])
(if (pair? clauses)
(syntax-case (car clauses) ()
[(pred #:dispatch disp defn ...)
(loop (cons #'[pred disp defn ...] fast-defaults)
defns
(cdr clauses))]
[(pred defn ...)
(with-syntax ([name (generate-temporary #'pred)])
(loop (cons #'[name name defn ...] fast-defaults)
(cons #'(define name pred) defns)
(cdr clauses)))]
[clause
(wrong-syntax #'clause
"invalid #:fast-defaults specification")])
(parse #'args
(hash-set* options
'fast-defaults fast-defaults
'defns defns)))))]
[(#:fast-defaults . other)
(wrong-syntax (stx-car stx) "invalid #:fast-defaults specification")]
[(#:fallbacks [fallback ...] . args)
@ -77,6 +111,7 @@
(wrong-syntax #'other
"expected a method identifier with formal arguments")]
[() (values (hash-ref options 'methods '())
(hash-ref options 'defns '())
(hash-ref options 'support generate-temporary)
(hash-ref options 'table #f)
(hash-ref options 'fast-defaults '())
@ -93,8 +128,10 @@
(parameterize ([current-syntax-context stx])
(unless (identifier? #'name)
(wrong-syntax #'name "expected an identifier"))
(define-values (methods support table fasts defaults fallbacks derived)
(define-values
(methods defns support table fasts defaults fallbacks derived)
(parse #'rest))
(define/with-syntax [defn ...] defns)
(define/with-syntax [fast-default ...] fasts)
(define/with-syntax [default ...] defaults)
(define/with-syntax [fallback ...] fallbacks)
@ -119,6 +156,7 @@
(values sym (support-name name sym)))))
#'(begin)))
#'(begin
defn ...
(define-primitive-generics/derived
original
(name gen-name prop-name get-name pred-name support-name)

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

@ -52,6 +52,8 @@
(define no-arg (gensym))
(define (assoc-ref d key [default no-arg])
(unless (assoc? d)
(raise-argument-error 'dict-ref "dict?" d))
(cond
[(assoc key d) => cdr]
[(eq? default no-arg)
@ -79,6 +81,8 @@
(loop (cddr pairs)))))
(define (assoc-set d key val)
(unless (assoc? d)
(raise-argument-error 'dict-set "dict?" d))
(let loop ([xd d])
(cond
[(null? xd) (list (cons key val))]
@ -113,6 +117,8 @@
(dict-set d key (xform (dict-ref d key default)))]))
(define (assoc-remove d key)
(unless (assoc? d)
(raise-argument-error 'dict-remove "dict?" d))
(let loop ([xd d])
(cond
[(null? xd) null]
@ -144,43 +150,59 @@
(define vector-iterate-value vector-ref)
(define (assoc-count d)
(unless (assoc? d)
(raise-argument-error 'dict-count "dict?" d))
(length d))
(struct assoc-iter (head pos))
(define (assoc-iterate-first d)
(unless (assoc? d)
(raise-argument-error 'dict-iterate-first "dict?" d))
(if (null? d) #f (assoc-iter d d)))
(define (assoc-iterate-next d i)
(if (and (assoc-iter? i)
(eq? d (assoc-iter-head i)))
(let ([pos (cdr (assoc-iter-pos i))])
(if (null? pos)
#f
(assoc-iter d pos)))
(raise-mismatch-error
'dict-iterate-next
"invalid iteration position for association list: "
i)))
(cond
[(and (assoc-iter? i)
(eq? d (assoc-iter-head i)))
(let ([pos (cdr (assoc-iter-pos i))])
(if (null? pos)
#f
(assoc-iter d pos)))]
[(assoc? d)
(raise-mismatch-error
'dict-iterate-next
"invalid iteration position for association list: "
i)]
[else (raise-argument-error 'dict-iterate-next "dict?" d)]))
(define (assoc-iterate-key d i)
(if (and (assoc-iter? i) (eq? d (assoc-iter-head i)))
(caar (assoc-iter-pos i))
(raise-mismatch-error
'dict-iterate-key
"invalid iteration position for association list: "
i)))
(cond
[(and (assoc-iter? i) (eq? d (assoc-iter-head i)))
(caar (assoc-iter-pos i))]
[(assoc? d)
(raise-mismatch-error
'dict-iterate-key
"invalid iteration position for association list: "
i)]
[else (raise-argument-error 'dict-iterate-key "dict?" d)]))
(define (assoc-iterate-value d i)
(if (and (assoc-iter? i) (eq? d (assoc-iter-head i)))
(cdar (assoc-iter-pos i))
(raise-mismatch-error
'dict-iterate-value
"invalid iteration position for association list: "
i)))
(cond
[(and (assoc-iter? i) (eq? d (assoc-iter-head i)))
(cdar (assoc-iter-pos i))]
[(assoc? d)
(raise-mismatch-error
'dict-iterate-value
"invalid iteration position for association list: "
i)]
[else (raise-argument-error 'dict-iterate-value "dict?" d)]))
(define-primitive-generics
(dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-supports?)
#:fast-defaults
([mutable-hash?
([mutable-hash? mutable-hash?
(define dict-ref hash-ref)
(define dict-set! hash-set!)
(define dict-remove! hash-remove!)
@ -189,7 +211,7 @@
(define dict-iterate-next hash-iterate-next)
(define dict-iterate-key hash-iterate-key)
(define dict-iterate-value hash-iterate-value)]
[immutable-hash?
[immutable-hash? immutable-hash?
(define dict-ref hash-ref)
(define dict-set hash-set)
(define dict-remove hash-remove)
@ -198,7 +220,7 @@
(define dict-iterate-next hash-iterate-next)
(define dict-iterate-key hash-iterate-key)
(define dict-iterate-value hash-iterate-value)]
[mutable-vector?
[mutable-vector? mutable-vector?
(define dict-ref vector-ref-as-dict)
(define dict-set! vector-set!)
(define dict-count vector-length)
@ -206,18 +228,18 @@
(define dict-iterate-next vector-iterate-next)
(define dict-iterate-key vector-iterate-key)
(define dict-iterate-value vector-iterate-value)]
[immutable-vector?
[immutable-vector? immutable-vector?
(define dict-ref vector-ref-as-dict)
(define dict-count vector-length)
(define dict-iterate-first vector-iterate-first)
(define dict-iterate-next vector-iterate-next)
(define dict-iterate-key vector-iterate-key)
(define dict-iterate-value vector-iterate-value)]
[assoc?
[assoc? list?
(define dict-ref assoc-ref)
(define dict-set assoc-set)
(define dict-remove assoc-remove)
(define dict-count length)
(define dict-count assoc-count)
(define dict-iterate-first assoc-iterate-first)
(define dict-iterate-next assoc-iterate-next)
(define dict-iterate-key assoc-iterate-key)

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

@ -34,8 +34,8 @@
accessor-name
predicate-name
supported-name)
#:fast-defaults ([fast-pred fast-defn ...] ...)
#:defaults ([default-pred default-defn ...] ...)
#:fast-defaults ([fast-pred fast-disp fast-defn ...] ...)
#:defaults ([default-pred default-disp default-defn ...] ...)
#:fallbacks [fallback-defn ...]
#:derive-properties ([derived-prop derived-impl] ...)
[method-name . method-signature]
@ -67,10 +67,14 @@
(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-preds))
(define/with-syntax (fast-pred-name ...)
(generate-temporaries fast-preds))
(define/with-syntax (fast-disp-name ...)
(generate-temporaries #'(fast-disp ...)))
(define/with-syntax (default-pred-name ...)
(generate-temporaries default-preds))
(define/with-syntax (default-disp-name ...)
(generate-temporaries #'(default-disp ...)))
(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)
@ -79,7 +83,9 @@
(define/with-syntax forward-declaration
(if (eq? (syntax-local-context) 'top-level)
#'(define-syntaxes (fast-pred-name ...
fast-disp-name ...
default-pred-name ...
default-disp-name ...
fast-by-method ... ...
default-by-method ... ...
fallback ...)
@ -115,10 +121,10 @@
...)
#t))
forward-declaration
(define fast-pred-name fast-pred)
...
(define default-pred-name default-pred)
...
(define fast-pred-name fast-pred) ...
(define fast-disp-name fast-disp) ...
(define default-pred-name default-pred) ...
(define default-disp-name default-disp) ...
(define (predicate-name self-name)
(or (fast-pred-name self-name)
...
@ -161,11 +167,11 @@
method-signature
self-name
(or (cond
[(fast-pred-name self-name) fast-by-method]
[(fast-disp-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]
[(default-disp-name self-name) default-by-method]
...
[else (raise-argument-error 'method-name
'contract-str