Changes to define-generics: added #:defined-predicate; improved generated code.

The #:defined-predicate option is like #:defined-table, but it defines a
two-argument predicate that only processes the requested method name and doesn't
allocate a hash table each time it is called.

Method implementations provided via #:fallbacks, #:defaults, and #:fast-defaults
are now called directly by method procedures rather than stored in a vector and
extracted by index.  This should hopefully improve inlining for methods.

pkgs/data-lib/data/order.rkt

@@ -19,7 +19,7 @@
                 prop:ordered-dict
                 ordered-methods
                 ordered-dict?
-                dict-def-table)
+                ordered-dict-supports?)
   #:fast-defaults ()
   #:defaults ()
   #:fallbacks ()

pkgs/racket-pkgs/racket-test/tests/generic/fallbacks.rkt

@@ -3,7 +3,7 @@
 (require racket/generic)
 
 (define-generics numeric
-  #:defined-table numeric-support
+  #:defined-predicate numeric-supports?
   (decrement numeric)
   (is-zero? numeric)
   (is-even? numeric)
@@ -19,19 +19,16 @@
 
 (define (is-even?-fallback x)
   (cond
-    [(supports? x 'is-odd?) (not (is-odd? x))]
+    [(numeric-supports? x 'is-odd?) (not (is-odd? x))]
     [(is-zero? x) #true]
     [else (is-odd? (decrement x))]))
 
 (define (is-odd?-fallback x)
   (cond
-    [(supports? x 'is-even?) (not (is-even? x))]
+    [(numeric-supports? x 'is-even?) (not (is-even? x))]
     [(is-zero? x) #false]
     [else (is-even? (decrement x))]))
 
-(define (supports? x sym)
-  (hash-ref (numeric-support x) sym #f))
-
 (struct peano-zero []
   #:transparent
   #:methods gen:numeric

pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt

@@ -21,7 +21,7 @@
   (local-require racket/private/generic)
 
   (define-primitive-generics
-    (foo gen:foo prop:foo foo-methods foo? dummy)
+    (foo gen:foo prop:foo foo-methods foo? foo-supports?)
     #:fast-defaults ([number? (define (meth foo #:kw kw) kw)])
     #:defaults ()
     #:fallbacks ()

racket/collects/racket/generic.rkt

@@ -17,6 +17,14 @@
 
   (define (parse stx [options (hasheq)])
     (syntax-case stx ()
+      [(#:defined-predicate name . args)
+       (identifier? #'name)
+       (if (hash-ref options 'support #f)
+           (wrong-syntax (stx-car stx)
+                         "duplicate #:defined-predicate specification")
+           (parse #'args (hash-set options 'support #'name)))]
+      [(#:defined-predicate . other)
+       (wrong-syntax (stx-car stx) "invalid #:defined-predicate specification")]
       [(#:defined-table name . args)
        (identifier? #'name)
        (if (hash-ref options 'table #f)
@@ -69,7 +77,8 @@
        (wrong-syntax #'other
                      "expected a method identifier with formal arguments")]
       [() (values (hash-ref options 'methods '())
-                  (hash-ref options 'table generate-temporary)
+                  (hash-ref options 'support generate-temporary)
+                  (hash-ref options 'table #f)
                   (hash-ref options 'fast-defaults '())
                   (hash-ref options 'defaults '())
                   (hash-ref options 'fallbacks '())
@@ -84,9 +93,9 @@
      (parameterize ([current-syntax-context stx])
        (unless (identifier? #'name)
          (wrong-syntax #'name "expected an identifier"))
-       (define-values (methods table fast-defaults defaults fallbacks derived)
+       (define-values (methods support table fasts defaults fallbacks derived)
          (parse #'rest))
-       (define/with-syntax [fast-default ...] fast-defaults)
+       (define/with-syntax [fast-default ...] fasts)
        (define/with-syntax [default ...] defaults)
        (define/with-syntax [fallback ...] fallbacks)
        (define/with-syntax [derive ...] derived)
@@ -100,17 +109,25 @@
        (define/with-syntax gen-name (format-id #'name "gen:~a" #'name))
        (define/with-syntax prop-name (generate-temporary #'name))
        (define/with-syntax get-name (generate-temporary #'name))
-       (define/with-syntax table-name table)
+       (define/with-syntax support-name support)
        (define/with-syntax original stx)
+       (define/with-syntax table-defn
+         (if table
+             (with-syntax ([table-name table])
+               #'(define (table-name name)
+                   (for/hasheq ([sym (in-list '(method ...))])
+                     (values sym (support-name name sym)))))
+             #'(begin)))
        #'(begin
            (define-primitive-generics/derived
              original
-             (name gen-name prop-name get-name pred-name table-name)
+             (name gen-name prop-name get-name pred-name support-name)
              #:fast-defaults [fast-default ...]
              #:defaults [default ...]
              #:fallbacks [fallback ...]
              #:derive-properties [derive ...]
              method ...)
+           table-defn
            (define-generics-contract name pred-name get-name
              [method-name method-index]
              ...)))]))

racket/collects/racket/private/dict.rkt

@@ -19,21 +19,21 @@
 (define (mutable-vector? v)
   (and (vector? v) (not (immutable? v))))
 
-(define (dict-supports? who d . whats)
-  (unless (dict? d)
-    (raise-argument-error who "dict?" d))
-  (define table (dict-def-table d))
-  (for/or ([what (in-list whats)])
-    (hash-ref table what #f)))
-
 (define (dict-mutable? d)
-  (dict-supports? 'dict-mutable? d 'dict-set!))
+  (unless (dict? d)
+    (raise-argument-error 'dict-mutable? "dict?" d))
+  (dict-supports? d 'dict-set!))
 
 (define (dict-can-remove-keys? d)
-  (dict-supports? 'dict-can-remove-keys? d 'dict-remove! 'dict-remove))
+  (unless (dict? d)
+    (raise-argument-error 'dict-can-remove-keys? "dict?" d))
+  (or (dict-supports? d 'dict-remove!)
+      (dict-supports? d 'dict-remove)))
 
 (define (dict-can-functional-set? d)
-  (dict-supports? 'dict-can-functional-set? d 'dict-set))
+  (unless (dict? d)
+    (raise-argument-error 'dict-can-functional-set? "dict?" d))
+  (dict-supports? d 'dict-set))
 
 (define (dict-has-key? d k)
   (define not-there (gensym))
@@ -178,7 +178,7 @@
        i)))
 
 (define-primitive-generics
-  (dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-def-table)
+  (dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-supports?)
   #:fast-defaults
   ([mutable-hash?
     (define dict-ref hash-ref)

racket/collects/racket/private/generic-methods.rkt

@@ -6,6 +6,7 @@
 
   (#%provide define/generic
              generic-property
+             generic-methods
              generic-method-table
              (for-syntax generic-info?
                          make-generic-info
@@ -72,11 +73,11 @@
       [(_ gen)
        (generic-info-property (get-info 'generic-property stx #'gen))]))
 
-  (define-syntax (generic-method-table stx)
+  (define-syntax (generic-methods stx)
     (syntax-case stx ()
       [(_ gen def ...)
        (let ()
-         (define info (get-info 'generic-method-table stx #'gen))
+         (define info (get-info 'generic-methods stx #'gen))
          (define delta (syntax-local-make-delta-introducer #'gen))
          (define methods (map delta (generic-info-methods info)))
          (with-syntax ([(method ...) methods])
@@ -86,7 +87,12 @@
                    ([(method) (make-unimplemented 'method)] ...)
                    ()
                  def ...
-                 (vector (implementation method) ...))))))]))
+                 (values (implementation method) ...))))))]))
+
+  (define-syntax (generic-method-table stx)
+    (syntax-case stx ()
+      [(_ gen def ...)
+       #'(call-with-values (lambda () (generic-methods gen def ...)) vector)]))
 
   (define-syntax (define/generic stx)
     (define gen-id (syntax-parameter-value #'generic-method-context))

racket/collects/racket/private/generic.rkt

@@ -49,31 +49,43 @@
        (check-identifier! #'self-name)
        (define methods (syntax->list #'(method-name ...)))
        (for-each check-identifier! methods)
+
        (define n (length methods))
        (define method-indices (for/list ([i (in-range n)]) i))
+       (define fast-preds (syntax->list #'(fast-pred ...)))
+       (define default-preds (syntax->list #'(default-pred ...)))
+       (define (generate-methods . ignore) (generate-temporaries methods))
+       (define (transpose-methods names)
+         (map cdr (apply map list methods names)))
+
+       (define fasts-by-type (map generate-methods fast-preds))
+       (define fasts-by-method (transpose-methods fasts-by-type))
+       (define defaults-by-type (map generate-methods default-preds))
+       (define defaults-by-method (transpose-methods defaults-by-type))
+
        (define/with-syntax size n)
        (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-pred ...)))
+         (generate-temporaries default-preds))
-       (define/with-syntax (default-impl-name ...)
-         (generate-temporaries #'(default-pred ...)))
        (define/with-syntax (fast-pred-name ...)
-         (generate-temporaries #'(fast-pred ...)))
+         (generate-temporaries fast-preds))
-       (define/with-syntax (fast-impl-name ...)
+       (define/with-syntax ([fast-by-method ...] ...) fasts-by-method)
-         (generate-temporaries #'(fast-pred ...)))
+       (define/with-syntax ([fast-by-type ...] ...) fasts-by-type)
-       (define/with-syntax fallback-name
+       (define/with-syntax ([default-by-method ...] ...) defaults-by-method)
-         (generate-temporary #'self-name))
+       (define/with-syntax ([default-by-type ...] ...) defaults-by-type)
+       (define/with-syntax [fallback ...] (generate-methods))
        (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 ...
+                                 fast-by-method ... ...
-                                 fallback-name)
+                                 default-by-method ... ...
+                                 fallback ...)
                  (values))
              #'(begin)))
+
        #'(begin
            (define-syntax generic-name
              (make-generic-info (quote-syntax property-name)
@@ -103,74 +115,78 @@
                ...)
               #t))
            forward-declaration
+           (define fast-pred-name fast-pred)
+           ...
+           (define default-pred-name default-pred)
+           ...
            (define (predicate-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])
+           (define (supported-name self-name . syms)
+             (define (bad-sym sym)
+               (raise-argument-error 'supported-name
+                                     (format "~s" '(or/c 'method-name ...))
+                                     sym))
              (cond
-               [(fast-pred-name self-name) fast-impl-name]
+               [(fast-pred-name self-name)
+                (for/and ([sym (in-list syms)])
+                  (case sym
+                    [(method-name) (procedure? fast-by-type)]
+                    ...
+                    [else (bad-sym sym)]))]
                ...
-               [(prop:pred self-name) (accessor-name self-name)]
+               [(prop:pred self-name)
-               [(default-pred-name self-name) default-impl-name]
+                (define table (accessor-name self-name))
+                (for/and ([sym (in-list syms)])
+                  (case sym
+                    [(method-name)
+                     (procedure? (vector-ref table 'method-index))]
+                    ...
+                    [else (bad-sym sym)]))]
+               [(default-pred-name self-name)
+                (for/and ([sym (in-list syms)])
+                  (case sym
+                    [(method-name) (procedure? default-by-type)]
+                    ...
+                    [else (bad-sym sym)]))]
                ...
-               [else (raise-argument-error who 'contract-str self-name)]))
+               [else (raise-argument-error 'supported-name
-           (define fast-pred-name fast-pred)
+                                           'contract-str
-           ...
+                                           self-name)]))
-           (define default-pred-name default-pred)
-           ...
-           (define-generic-support supported-name
-                                   self-name
-                                   [method-name ...]
-                                   (table-name self-name 'supported-name)
-                                   original)
            (define-generic-method
              method-name
              method-signature
              self-name
-             (or (vector-ref (table-name self-name 'method-name) 'method-index)
+             (or (cond
-                 (vector-ref fallback-name 'method-index))
+                   [(fast-pred-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]
+                   ...
+                   [else (raise-argument-error 'method-name
+                                               'contract-str
+                                               self-name)])
+                 fallback)
              original)
            ...
-           (define fast-impl-name
+           (define-values (fast-by-type ...)
-             (generic-method-table generic-name fast-defn ...))
+             (generic-methods generic-name fast-defn ...))
            ...
-           (define default-impl-name
+           (define-values (default-by-type ...)
-             (generic-method-table generic-name default-defn ...))
+             (generic-methods generic-name default-defn ...))
            ...
-           (define fallback-name
+           (define-values (fallback ...)
-             (generic-method-table generic-name fallback-defn ...))))]))
+             (generic-methods generic-name fallback-defn ...))))]))
 
 (define-syntax (define-primitive-generics stx)
   (syntax-case stx ()
     [(_ . args)
      #`(define-primitive-generics/derived #,stx . args)]))
 
-(define-syntax (define-generic-support stx)
-  (syntax-case stx ()
-    [(_ supported-name
-        self-name
-        [method-name ...]
-        table
-        original)
-     (parameterize ([current-syntax-context #'original])
-       (check-identifier! #'supported-name)
-       (check-identifier! #'self-name)
-       (for-each check-identifier! (syntax->list #'(method-name ...)))
-       (define/with-syntax (index ...)
-         (for/list ([idx (in-naturals)]
-                    [stx (in-list (syntax->list #'(method-name ...)))])
-           idx))
-       #'(define (supported-name self-name)
-           (define v table)
-           (make-immutable-hasheqv
-             (list
-              (cons 'method-name
-                    (procedure? (vector-ref v 'index)))
-              ...))))]))
-
 (begin-for-syntax
 
   (define (method-formals/application name-stx proc-stx self-id sig-stx)