From 1f267d479cc8b3bca6b5f9434f2a3cf419e89937 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Wed, 17 Jul 2013 15:51:46 -0400 Subject: [PATCH] Added #:fast-defaults option to define-generics. 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. --- pkgs/data-lib/data/order.rkt | 1 + .../racket-test/tests/generic/defaults.rkt | 7 +-- .../racket-test/tests/generic/pr13737.rkt | 3 +- racket/collects/racket/generic.rkt | 15 +++++- racket/collects/racket/private/dict.rkt | 3 +- racket/collects/racket/private/generic.rkt | 51 ++++++++++++------- 6 files changed, 57 insertions(+), 23 deletions(-) diff --git a/pkgs/data-lib/data/order.rkt b/pkgs/data-lib/data/order.rkt index 2f65d075f2..3c45780213 100644 --- a/pkgs/data-lib/data/order.rkt +++ b/pkgs/data-lib/data/order.rkt @@ -20,6 +20,7 @@ ordered-methods ordered-dict? dict-def-table) + #:fast-defaults () #:defaults () #:fallbacks () #:derive-properties () diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt index 8f2114aa16..d5a596af13 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/defaults.rkt @@ -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?)])) diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt index f9f2f629fe..e558969ac4 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt @@ -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)) diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index c98fa12f23..8af9387c0b 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -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 ...] diff --git a/racket/collects/racket/private/dict.rkt b/racket/collects/racket/private/dict.rkt index 2238b561f2..532063c930 100644 --- a/racket/collects/racket/private/dict.rkt +++ b/racket/collects/racket/private/dict.rkt @@ -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]) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index e5924837db..353aa5276b 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -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 ...)) ...