From 97b78ace5b3f7cebe7604513142ba488acee6903 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Wed, 17 Jul 2013 20:21:05 -0400 Subject: [PATCH] Added #:dispatch option for clauses in #:defaults and #:fast-defaults. 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. --- .../racket-test/tests/generic/pr13737.rkt | 2 +- racket/collects/racket/generic.rkt | 54 +++++++++++-- racket/collects/racket/private/dict.rkt | 78 ++++++++++++------- racket/collects/racket/private/generic.rkt | 26 ++++--- 4 files changed, 113 insertions(+), 47 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt index df2d49c862..62dd570bb9 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt @@ -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 () diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index 6647d105a7..7bfd1e996b 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -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) diff --git a/racket/collects/racket/private/dict.rkt b/racket/collects/racket/private/dict.rkt index a8e675977f..678c8abdb4 100644 --- a/racket/collects/racket/private/dict.rkt +++ b/racket/collects/racket/private/dict.rkt @@ -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) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index 0cf6de3f3a..17d47ddfca 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -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