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

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

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?)]
+    (define stream-empty? null?)])
-   [s:stream?
+  #:defaults
+  ([s:stream?
     (define stream-first s:stream-first)
     (define stream-rest s:stream-rest)
     (define stream-empty? s:stream-empty?)]))

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))

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 ...]

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])

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] ...)
+       (define/with-syntax (default-pred-name ...)
-         (for/list ([pred-stx (in-list (syntax->list #'(default-pred ...)))]
+         (generate-temporaries #'(default-pred ...)))
-                    [i (in-naturals 0)])
+       (define/with-syntax (default-impl-name ...)
-           (list (format-id (syntax-local-introduce #'self-name)
+         (generate-temporaries #'(default-pred ...)))
-                            "~a-default-pred~a"
+       (define/with-syntax (fast-pred-name ...)
-                            #'self-name
+         (generate-temporaries #'(fast-pred ...)))
-                            i)
+       (define/with-syntax (fast-impl-name ...)
-                 (format-id (syntax-local-introduce #'self-name)
+         (generate-temporaries #'(fast-pred ...)))
-                            "~a-default-impl~a"
-                            #'self-name
-                            i))))
        (define/with-syntax fallback-name
-         (format-id (syntax-local-introduce #'self-name)
+         (generate-temporary #'self-name))
-                    "~a-fallback"
+       (define/with-syntax forward-declaration
-                    #'self-name))
+         (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 ...)
+           (define fast-pred-name fast-pred)
-             (values default-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 ...))
            ...