From e47c0efa1f49d396e60c07f40ed35b253197b6c0 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 7 Feb 2014 07:51:46 -0600
Subject: [PATCH] change class/c to keep a vector of wrapper methods, not a
 hash table

this change is mostly motivated by improving how generics work on
contracted objects.

Also fix dynamic-send

TR's optimizer seems to get angry at the new send expansion, so
disable optimizations auto-language.rkt and insert-large-letters.rkt
(for now)
---
 .../drracket/private/auto-language.rkt        |   2 +-
 .../drracket/private/insert-large-letters.rkt |   2 +-
 .../tests/racket/contract/class.rkt           | 149 +++++++++++++++++
 .../racket-test/tests/racket/object.rktl      |  12 +-
 racket/collects/racket/class.rkt              |   3 +-
 .../collects/racket/private/class-c-new.rkt   | 139 +++++++---------
 .../collects/racket/private/class-c-old.rkt   |   2 +-
 .../racket/private/class-internal.rkt         | 155 +++++++-----------
 racket/collects/racket/private/classidmap.rkt |  59 +++++--
 9 files changed, 331 insertions(+), 192 deletions(-)

diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/auto-language.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/auto-language.rkt
index 86d69776a6..353e1f637e 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/private/auto-language.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/private/auto-language.rkt
@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang typed/racket/base #:no-optimize
 
 (require typed/framework/framework 
 	 typed/mred/mred
diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt
index 6391efac22..2a4245c2a8 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt
@@ -1,4 +1,4 @@
-#lang typed/racket/base
+#lang typed/racket/base #:no-optimize
 
 (require typed/mred/mred
          typed/framework/framework
diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
index 9ac6f8435a..63fff45263 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt
@@ -2146,6 +2146,155 @@
               'pos
               'neg))
   
+  (test/spec-passed
+   'generic1
+   '(let* ([c% (class object%
+                 (super-new)
+                 (define/public (m x) x))])
+      (send-generic (new (contract (class/c
+                                    (m (->m integer? integer?)))
+                                   c%
+                                   'pos 'neg))
+                    (generic c% m)
+                    5)))
+  
+  (test/neg-blame
+   'generic2
+   '(let* ([c% (class object%
+                 (super-new)
+                 (define/public (m x) x))])
+      (send-generic (new (contract (class/c
+                                    (m (->m integer? integer?)))
+                                   c%
+                                   'pos 'neg))
+                    (generic c% m)
+                    #f)))
+  
+  (test/spec-passed
+   'generic3
+   '(let* ([i<%> (interface () m)]
+           [c% (class* object% (i<%>)
+                (super-new)
+                (define/public (m x) x))])
+      (send-generic (new (contract (class/c
+                                    (m (->m integer? integer?)))
+                                   c%
+                                   'pos 'neg))
+                    (generic i<%> m)
+                    5)))
+  
+  (test/neg-blame
+   'generic4
+   '(let* ([i<%> (interface () m)]
+           [c% (class* object% (i<%>)
+                (super-new)
+                (define/public (m x) x))])
+      (send-generic (new (contract (class/c
+                                    (m (->m integer? integer?)))
+                                   c%
+                                   'pos 'neg))
+                    (generic i<%> m)
+                    #f)))
+  
+  (test/spec-passed
+   'generic5
+   '(let* ([c% (class object%
+                 (super-new)
+                 (define/public (m x) x))]
+           [c%+c (contract (class/c (m (->m integer? integer?)))
+                           c%
+                           'pos 'neg)]
+           [o (new c%)]
+           [g (generic c%+c m)])
+      (send-generic o g #f)))
+
+  (test/neg-blame
+   'generic6
+   '(let* ([c% (class object%
+                 (super-new)
+                 (define/public (m x) x))]
+           [c%+c (contract (class/c (m (->m integer? integer?)))
+                           c%
+                           'pos 'neg)]
+           [o (new c%+c)]
+           [g (generic c% m)])
+      (send-generic o g #f)))
+  
+  (test/spec-passed
+   'generic7
+   '(let* ([i<%> (interface () m)]
+           [c% (class* object% (i<%>)
+                (super-new)
+                (define/public (m x) x))])
+      (send-generic (new (contract (class/c m)
+                                   c%
+                                   'pos 'neg))
+                    (generic c% m)
+                    5)))
+  
+  (test/spec-passed
+   'generic8
+   '(let* ([i<%> (interface () n)]
+           [c% (class* object% (i<%>)
+                (super-new)
+                 (define/public (m x) x)
+                 (define/public (n x) x))])
+      (send-generic (new (contract (class/c m)
+                                   c%
+                                   'pos 'neg))
+                    (generic c% n)
+                    5)))
+  
+  (test/spec-passed
+   'dynamic-send1
+   '(dynamic-send (new (contract (class/c [m (->m integer? integer?)])
+                                 (class object% (define/public (m x) x) (super-new))
+                                 'pos
+                                 'neg))
+                  'm 1))
+  (test/spec-passed
+   'dynamic-send2
+   '(dynamic-send (new (contract (class/c m)
+                                 (class object% (define/public (m x) x) (super-new))
+                                 'pos
+                                 'neg))
+                  'm 1))
+  (test/spec-passed
+   'dynamic-send3
+   '(dynamic-send (new (contract (class/c m)
+                                 (class object% 
+                                   (define/public (m x) x) 
+                                   (define/public (n x) x)
+                                   (super-new))
+                                 'pos
+                                 'neg))
+                  'n 1))
+  (test/neg-blame
+   'dynamic-send4
+   '(dynamic-send (new (contract (class/c [m (->m integer? integer?)])
+                                 (class object% (define/public (m x) x) (super-new))
+                                 'pos
+                                 'neg))
+                  'm #f))
+  
+  (test/spec-passed
+   'with-method1
+   '(let ([o (new (contract (class/c [m (->m integer? integer?)])
+                            (class object% (define/public (m x) x) (super-new))
+                            'pos
+                            'neg))])
+      (with-method ([m (o m)])
+        (m 1))))
+  
+  (test/neg-blame
+   'with-method1
+   '(let ([o (new (contract (class/c [m (->m integer? integer?)])
+                            (class object% (define/public (m x) x) (super-new))
+                            'pos
+                            'neg))])
+      (with-method ([m (o m)])
+        (m #f))))
+  
   (let ([expected-given?
          (λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
                        (regexp-match? #rx"expected: boolean[?]" (exn-message exn))
diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl
index fd0fbc9548..2b13eec1db 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl
@@ -1885,16 +1885,23 @@
                (super-new)
                (define/public (m x) x)))
   
+  (define i<%> (interface () m))
+  (define c/i% (class* object% (i<%>)
+                 (super-new)
+                 (define/public (m x) x)))
+  
   (define c%/c
     (class/c
      (m (->m integer? integer?))))
   
   (provide
    (contract-out
-    [c% c%/c])
+    [c% c%/c]
+    [c/i% (class/c [m (-> any/c integer? integer?)])])
    is-c%?
    c%-is?
-   is-a-c%?)
+   is-a-c%?
+   i<%>)
   
   (define (is-c%? c)
     (c . subclass? . c%))
@@ -1913,6 +1920,7 @@
 (test #t is-a-c%? (new c%))
 
 (test 5 'send-generic (send-generic (new c%) (generic c% m) 5))
+(test 6 'send-generic-interface (send-generic (new c/i%) (generic i<%> m) 6))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
diff --git a/racket/collects/racket/class.rkt b/racket/collects/racket/class.rkt
index ef06d2510e..a3be91a65b 100644
--- a/racket/collects/racket/class.rkt
+++ b/racket/collects/racket/class.rkt
@@ -6,7 +6,8 @@
 ;; All of the implementation is actually in private/class-internal.rkt,
 ;;  which provides extra (private) functionality to contract.rkt.
 (require "private/class-internal.rkt"
-         "private/class-c-old.rkt")
+         (except-in "private/class-c-old.rkt" class/c)
+         (rename-in "private/class-c-new.rkt" [class/c2 class/c]))
   
 (provide-public-names)
 (provide generic?)
diff --git a/racket/collects/racket/private/class-c-new.rkt b/racket/collects/racket/private/class-c-new.rkt
index 621153eb58..ddd1c141c3 100644
--- a/racket/collects/racket/private/class-c-new.rkt
+++ b/racket/collects/racket/private/class-c-new.rkt
@@ -140,16 +140,18 @@
               (λ (neg-party)
                 (((class/c-proj ctc) (blame-add-missing-party blame neg-party)) cls))]
              [else 
-              (build-neg-acceptor-proc this maybe-err blame cls (make-hash) '() 
+              (build-neg-acceptor-proc this maybe-err blame cls #f '() 
                                        (make-hasheq) (make-hasheq))])]
           [(wrapped-class? cls) 
-           (define neg-acceptors-ht
-             (wrapped-class-info-neg-acceptors-ht (wrapped-class-the-info cls)))
            (define wrapper-neg-party (wrapped-class-neg-party cls))
-           (define new-mths-ht
-             (for/hash ([(mth neg-acceptor) (in-hash neg-acceptors-ht)])
-               (values mth (neg-acceptor wrapper-neg-party))))
            (define the-info (wrapped-class-the-info cls))
+           (define neg-acceptors (wrapped-class-info-neg-acceptors-ht the-info))
+           (define real-class (wrapped-class-info-class the-info))
+           (define mth->idx (class-method-ht real-class))
+           (define new-mths (make-vector (vector-length (class-methods real-class)) #f))
+           (for ([(mth neg-acceptor) (in-hash neg-acceptors)])
+             (define mth-idx (hash-ref mth->idx mth))
+             (vector-set! new-mths mth-idx (neg-acceptor wrapper-neg-party)))
            (define fixed-neg-init-projs
              (for/list ([proj-pair (wrapped-class-info-init-proj-pairs the-info)])
                (cons (list-ref proj-pair 0)
@@ -158,7 +160,7 @@
                                   ((func val) wrapper-neg-party)))))))
            (build-neg-acceptor-proc this maybe-err blame 
                                     (wrapped-class-info-class the-info)
-                                    new-mths-ht
+                                    new-mths
                                     fixed-neg-init-projs
                                     (wrapped-class-info-pos-field-projs the-info)
                                     (wrapped-class-info-neg-field-projs the-info))]
@@ -169,100 +171,81 @@
                blame #:missing-party neg-party cls
                '(expected: "a class"))))])))))
 
-(define (build-neg-acceptor-proc this maybe-err blame cls new-mths-ht old-init-pairs 
+(define (build-neg-acceptor-proc this maybe-err blame cls old-mths-vec old-init-pairs 
                                  old-pos-fld-ht old-neg-fld-ht)
   (define mth->idx (class-method-ht cls))
   (define mtd-vec (class-methods cls))
   
   (define internal-proj (internal-class/c-proj (ext-class/c-contract-internal-ctc this)))
   
-  (define (get-unwrapped-method name)
-    (cond
-      [(hash-ref new-mths-ht name #f) => values]
-      [else
-       (define mth-idx (hash-ref mth->idx name #f))
-       (and mth-idx
-            (vector-ref mtd-vec mth-idx))]))
-  
-  (define neg-extra-arg-ht (make-hash))
+  ;; The #f may survive if the method is just-check-existence or
+  ;; if the contract doesn't mention the method (and it isn't opaque)
+  (define neg-extra-arg-vec (make-vector (vector-length mtd-vec) #f))
   (define neg-acceptors-ht (make-hash))
   
   (define pos-field-projs (hash-copy old-pos-fld-ht))
   (define neg-field-projs (hash-copy old-neg-fld-ht))
   
-  (define (generic-wrapper mth)
-    (define raw-proc (get-unwrapped-method mth))
-    (make-keyword-procedure
-     (λ (kwds kwd-args neg-party . args)
-       (keyword-apply raw-proc kwds kwd-args args))
-     (λ (neg-party . args)
-       (apply raw-proc args))))
-  
-  (for ([(mth proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))])
-    (define m-mth (get-unwrapped-method mth))
-    (unless m-mth
+  (for ([(mth-name proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))])
+    (define mth-idx (hash-ref mth->idx mth-name #f))
+    (unless mth-idx
       (maybe-err
        (λ (neg-party)
          (raise-blame-error 
           blame #:missing-party neg-party cls
           '(expected: "a class with a public method named ~a")
-          mth))))
+          mth-name))))
     
-    (cond
-      [(just-check-existence? proj)
-       ;; if we just check the method's existence,
-       ;; then make an inefficient wrapper for it
-       ;; that discards the neg-party argument
-       (hash-set! neg-extra-arg-ht mth (generic-wrapper mth))]
-      [else
-       (define w/blame (proj (blame-add-method-context blame mth)))
-       (define projd-mth (w/blame m-mth))
-       (hash-set! neg-acceptors-ht mth projd-mth)
-       (define neg-acceptor
-         (cond
-           [(wrapped-extra-arg-arrow? projd-mth)
-            (wrapped-extra-arg-arrow-extra-neg-party-argument projd-mth)]
-           [else 
-            ;; if some contract doesn't subscribe to the wrapped-extra-arg-arrow
-            ;; protocol, then make an inefficient wrapper for it.
-            (make-keyword-procedure
-             (λ (kwds kwd-args neg-party . args)
-               (keyword-apply (projd-mth neg-party) kwds kwd-args args))
-             (λ (neg-party . args)
-               (apply (projd-mth neg-party) args)))]))
-       (hash-set! neg-extra-arg-ht mth neg-acceptor)]))
+    (unless (just-check-existence? proj)
+      (define w/blame (proj (blame-add-method-context blame mth-name)))
+      (define m-mth (if old-mths-vec
+                        (or (vector-ref old-mths-vec mth-idx)
+                            (vector-ref mtd-vec mth-idx))
+                        (vector-ref mtd-vec mth-idx)))
+      (define projd-mth (w/blame m-mth))
+      (hash-set! neg-acceptors-ht mth-name projd-mth)
+      (define neg-extra-arg
+        (cond
+          [(wrapped-extra-arg-arrow? projd-mth)
+           (wrapped-extra-arg-arrow-extra-neg-party-argument projd-mth)]
+          [else 
+           ;; if some contract doesn't subscribe to the wrapped-extra-arg-arrow
+           ;; protocol, then make an inefficient wrapper for it.
+           (make-keyword-procedure
+            (λ (kwds kwd-args neg-party . args)
+              (keyword-apply (projd-mth neg-party) kwds kwd-args args))
+            (λ (neg-party . args)
+              (apply (projd-mth neg-party) args)))]))
+      (vector-set! neg-extra-arg-vec mth-idx neg-extra-arg)))
   
   (define absent-methods (ext-class/c-contract-absent-methods this))
-  (for ([(mth _) (in-hash mth->idx)])
-    (when (member mth absent-methods)
+  (for ([(mth-name mth-idx) (in-hash mth->idx)])
+    (when (member mth-name absent-methods)
       (maybe-err
        (λ (neg-party)
          (raise-blame-error 
           blame #:missing-party neg-party cls
           '(expected: "a class that does not have the method ~a")
-          mth))))
+          mth-name))))
     
-    ;; use a generic wrapper to drop the neg-party argument, which means
-    ;; methods without explicit contracts are going to be slow
-    (unless (hash-ref neg-extra-arg-ht mth #f)
-      (if (ext-class/c-contract-opaque? this)
-          (maybe-err
-           (λ (neg-party)
-             (define mth-names
-               (for/list ([(mth proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))])
-                 (format " ~a" mth)))
-             (raise-blame-error 
-              blame #:missing-party neg-party cls
-              '(expected: "~a" given: "a class that has a method: ~a")
-              (cond
-                [(null? mth-names) "a class with no methods"]
-                [(null? (cdr mth-names)) 
-                 (format "a class with only one method:~a" (car mth-names))]
-                [else
-                 (format "a class with only the methods:~a" 
-                         (apply string-append mth-names))])
-              mth)))
-          (hash-set! neg-extra-arg-ht mth (generic-wrapper mth)))))
+    (when (ext-class/c-contract-opaque? this)
+      (unless (hash-ref (ext-class/c-contract-table-of-meths-to-projs this) mth-name #f)
+        (maybe-err
+         (λ (neg-party)
+           (define mth-names
+             (for/list ([(mth proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))])
+               (format " ~a" mth)))
+           (raise-blame-error 
+            blame #:missing-party neg-party cls
+            '(expected: "~a" given: "a class that has a method: ~a")
+            (cond
+              [(null? mth-names) "a class with no methods"]
+              [(null? (cdr mth-names)) 
+               (format "a class with only one method:~a" (car mth-names))]
+              [else
+               (format "a class with only the methods:~a" 
+                       (apply string-append mth-names))])
+            mth-name))))))
   
   (for ([(fld proj) (in-hash (ext-class/c-contract-table-of-flds-to-projs this))])
     (define field-ht (class-field-ht cls))
@@ -325,7 +308,7 @@
                 ((get/build-val-first-projection ctc) 
                  (blame-add-init-context blame (car ctc-pair)))))))
   (define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs))
-  (define the-info (wrapped-class-info cls blame neg-extra-arg-ht neg-acceptors-ht 
+  (define the-info (wrapped-class-info cls blame neg-extra-arg-vec neg-acceptors-ht
                                        pos-field-projs neg-field-projs
                                        merged-init-pairs))
   
@@ -333,7 +316,7 @@
     ;; run this for the side-effect of 
     ;; checking that first-order tests on
     ;; methods (arity, etc) all pass
-    (for ([(mth neg-party-acceptor) (in-hash neg-acceptors-ht)])
+    (for ([(mth-name neg-party-acceptor) (in-hash neg-acceptors-ht)])
       (neg-party-acceptor neg-party))
     
     ;; XXX: we have to not do this;
diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index 5740f8e459..47391c0f8d 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -1167,7 +1167,7 @@
          (define the-info (wrapped-class-the-info new-cls))
          (wrapped-object
           val
-          (wrapped-class-info-neg-extra-arg-ht the-info)
+          (wrapped-class-info-neg-extra-arg-vec the-info)
           (wrapped-class-info-pos-field-projs the-info)
           (wrapped-class-info-neg-field-projs the-info)
           (wrapped-class-neg-party new-cls))]
diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt
index 43806586f5..f3cee449b6 100644
--- a/racket/collects/racket/private/class-internal.rkt
+++ b/racket/collects/racket/private/class-internal.rkt
@@ -4,6 +4,7 @@
          racket/stxparam
          racket/unsafe/ops
          "serialize-structs.rkt"
+         "class-wrapped.rkt"
          racket/runtime-path
          (only-in "../contract/region.rkt" current-contract-region)
          "../contract/base.rkt"
@@ -3240,7 +3241,7 @@ An example
                                   (wrapped-class-info-init-proj-pairs the-info)))
      (wrapped-object
       unwrapped-o
-      (wrapped-class-info-neg-extra-arg-ht the-info)
+      (wrapped-class-info-neg-extra-arg-vec the-info)
       (wrapped-class-info-pos-field-projs the-info)
       (wrapped-class-info-neg-field-projs the-info)
       (wrapped-class-neg-party class))]
@@ -3464,44 +3465,15 @@ An example
           (let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
                         [(receiver) (unsyntax obj)]
                         [(method) (find-method/who '(unsyntax form) receiver sym)])
-            
-            #;(unsyntax
-             (make-method-call
-              stx
-              (syntax/loc stx receiver)
-              (syntax/loc stx method)
-              (syntax/loc stx sym)
-              args
-              rest-arg?
-              kw-args/var))
-            
-            
             (let (#,@(if kw-args
                          (list #`[kw-arg-tmp #,(cadr kw-args)])
                          (list))
                   #,@let-bindings)
-              (if (wrapped-object? receiver)
-                  ;; this is kind of a hack: passing the neg party in
-                  ;; as the object to 'make-method-call' so that the
-                  ;; arguments end up in the right order.
-                  (unsyntax
-                   (make-method-call
-                    stx
-                    #`(wrapped-object-neg-party receiver)
-                    (syntax/loc stx method)
-                    (syntax/loc stx sym)
-                    #`((wrapped-object-object #,(syntax/loc stx receiver)) #,@arg-list)
-                    rest-arg?
-                    kw-args/var))
-                  (unsyntax
-                   (make-method-call
-                    stx
-                    (syntax/loc stx receiver)
-                    (syntax/loc stx method)
-                    (syntax/loc stx sym)
-                    arg-list
-                    rest-arg?
-                    kw-args/var))))))))
+              (unsyntax
+               (make-method-call-to-possibly-wrapped-object
+                stx kw-args/var arg-list rest-arg?
+                #'sym #'method #'receiver
+                (quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym)))))))))
     
     (define (core-send apply? kws?)
       (lambda (stx)
@@ -3553,7 +3525,20 @@ An example
    (lambda (kws kw-vals obj method-name . args)
      (unless (object? obj) (raise-argument-error 'dynamic-send "object?" obj))
      (unless (symbol? method-name) (raise-argument-error 'dynamic-send "symbol?" method-name))
-     (keyword-apply (find-method/who 'dynamic-send obj method-name) kws kw-vals obj args))))
+     (define mtd (find-method/who 'dynamic-send obj method-name))
+     (cond
+       [(wrapped-object? obj)
+        (if mtd
+            (keyword-apply mtd kws kw-vals 
+                           (wrapped-object-neg-party obj) 
+                           (wrapped-object-object obj)
+                           args)
+            (keyword-apply dynamic-send kws kw-vals
+                           (wrapped-object-object obj)
+                           method-name
+                           args))]
+       [else
+        (keyword-apply mtd kws kw-vals obj args)]))))
 
 ;; imperative chained send
 (define-syntax (send* stx)
@@ -3594,13 +3579,20 @@ An example
   (cond
     [(_object? in-object)
      (define cls (object-ref in-object #f))
-     (define pos (hash-ref (class-method-ht cls) name #f))
-     (if pos
-         (vector-ref (class-methods cls) pos)
+     (define mth-idx (hash-ref (class-method-ht cls) name #f))
+     (if mth-idx
+         (vector-ref (class-methods cls) mth-idx)
          (no-such-method who name cls))]
     [(wrapped-object? in-object)
-     (or (hash-ref (wrapped-object-method-wrappers in-object) name #f)
-         (no-such-method who name (object-ref in-object)))]
+     (define cls
+       (let loop ([obj in-object])
+         (cond
+           [(wrapped-object? obj) (loop (wrapped-object-object obj))]
+           [else 
+            (object-ref obj #f)])))
+     (define mth-idx (hash-ref (class-method-ht cls) name #f))
+     (unless mth-idx (no-such-method who name (object-ref in-object)))
+     (vector-ref (wrapped-object-neg-extra-arg-vec in-object) mth-idx)]
     [else
      (obj-error who "target is not an object"
                 "target" in-object 
@@ -3684,20 +3676,24 @@ An example
                                                    "method name" (as-write name)
                                                    #:class-name (class-name class))))]
                        [instance? (class-object? (class-orig-cls class))]
+                       [fail (λ (obj)
+                               (obj-error 
+                                (string->symbol (format "generic:~a" name))
+                                "target is not an instance of the generic's class"
+                                "target" obj
+                                #:class-name (class-name class)))]
                        [dynamic-generic
                         (lambda (obj)
-                          (unless (instance? obj)
-                            (obj-error 
-                             (string->symbol (format "generic:~a" name))
-                             "target is not an instance of the generic's class"
-                             "target" obj
-                             #:class-name (class-name class)))
-                          (vector-ref (class-methods (object-ref obj)) pos))]) ;; TODO: object-ref audit
+                          (cond
+                            [(wrapped-object? obj)
+                             (vector-ref (wrapped-object-neg-extra-arg-vec obj) pos)]
+                            [(instance? obj)
+                             (vector-ref (class-methods (object-ref obj)) pos)]
+                            [else (fail obj)]))])
                   (if (eq? 'final (vector-ref (class-meth-flags class) pos))
                       (let ([method (vector-ref (class-methods class) pos)])
                         (lambda (obj)
-                          (unless (instance? obj)
-                            (dynamic-generic obj))
+                          (unless (instance? obj) (fail obj))
                           method))
                       dynamic-generic)))))])
     make-generic))
@@ -3713,15 +3709,18 @@ An example
          (quasisyntax/loc stx
            (let* ([obj object]
                   [gen generic])
+             ;(check-generic gen)
              (unsyntax
-              (make-method-call
-               stx
-               (syntax obj)
-               (syntax/loc stx ((generic-applicable gen) obj))
-               (syntax/loc stx (generic-name gen))
-               flat-stx
-               (not proper?)
-               #f))))))]))
+              (make-method-call-to-possibly-wrapped-object
+               stx #f flat-stx (not proper?)
+               #'(generic-name gen) 
+               #'((generic-applicable gen) obj) 
+               #'obj
+               #'((generic-applicable gen) obj)))))))]))
+
+(define (check-generic gen)
+  (unless (generic? gen)
+    (raise-argument-error 'send-generic "generic?" gen)))
 
 (define-syntaxes (class-field-accessor class-field-mutator generic/form)
   (let ([mk
@@ -4210,46 +4209,6 @@ An example
 (define-values (impersonator-prop:original-object has-original-object? original-object)
   (make-impersonator-property 'impersonator-prop:original-object))
 
-;;--------------------------------------------------------------------
-;; runtime wrappers to support contracts with better space properties
-;;--------------------------------------------------------------------
-
-(struct wrapped-class-info (class blame 
-                             neg-extra-arg-ht neg-acceptors-ht 
-                             pos-field-projs neg-field-projs
-                             init-proj-pairs)
-  #:transparent)
-(struct wrapped-class (the-info neg-party)
-  #:property prop:custom-write
-  (λ (stct port mode)
-    (do-custom-write (wrapped-class-info-class (wrapped-class-the-info stct)) port mode))
-  #:transparent)
-(define (unwrap-class cls)
-  (let loop ([class cls])
-    (cond
-      [(wrapped-class? class) (loop (wrapped-class-info-class (wrapped-class-the-info class)))]
-      [else class])))
-
-(struct wrapped-object (object method-wrappers pos-field-projs neg-field-projs neg-party)
-  #:transparent
-  #:property prop:custom-write
-  (λ (stct port mode)
-    (do-custom-write (wrapped-object-object stct) port mode)))
-
-(define (do-custom-write v port mode)
-  (cond
-    [(custom-write? v)
-     ((custom-write-accessor v) v port mode)]
-    [(equal? mode #t)
-     (write v port)]
-    [(equal? mode #f)
-     (display v port)]
-    [else
-     (print v port mode)]))
-(define (unwrap-object o)
-  (cond
-    [(wrapped-object? o) (unwrap-object (wrapped-object-object o))]
-    [else o]))
 
 (define (check-arg-contracts wrapped-blame wrapped-neg-party val init-proj-pairs orig-named-args)
   ;; blame will be #f only when init-ctc-pairs is '()
diff --git a/racket/collects/racket/private/classidmap.rkt b/racket/collects/racket/private/classidmap.rkt
index 17e785211d..0f6a8a7e10 100644
--- a/racket/collects/racket/private/classidmap.rkt
+++ b/racket/collects/racket/private/classidmap.rkt
@@ -2,7 +2,8 @@
 
 (require syntax/stx
          (for-syntax racket/base)
-         (for-template racket/base))
+         (for-template racket/base
+                       "class-wrapped.rkt"))
 
 (define insp (variable-reference->module-declaration-inspector
               (#%variable-reference)))
@@ -282,14 +283,9 @@
          (let* ([args-stx (syntax args)]
                 [proper? (stx-list? args-stx)]
                 [flat-args-stx (if proper? args-stx (flatten-args args-stx))])
-           (make-method-call
-            stx
-            method-obj-stx
-            method-stx
-            (syntax (quote id))
-            flat-args-stx
-            (not proper?)
-            #f))]
+           (make-method-call-to-possibly-wrapped-object
+            stx #f flat-args-stx (not proper?)
+            #''id method-stx method-obj-stx method-obj-stx))]
         [id
          (identifier? (syntax id))
          (raise-syntax-error 
@@ -364,12 +360,55 @@
                  [args args-stx])
      (qstx (app method kw-arg ... object . args)))))
 
+(define (make-method-call-to-possibly-wrapped-object
+         stx kw-args/var arg-list rest-arg?
+         sym method receiver method-in-wrapper-fallback-case)
+  (with-syntax ([sym sym]
+                [method method]
+                [receiver receiver]
+                [method-in-wrapper-fallback-case method-in-wrapper-fallback-case])
+    (quasisyntax/loc stx
+      (if (wrapped-object? receiver)
+          (if method
+              ;; this is a hack: passing the neg party in
+              ;; as the object to 'make-method-call' so that the
+              ;; arguments end up in the right order.
+              (unsyntax
+               (make-method-call
+                stx
+                #`(wrapped-object-neg-party receiver)
+                (syntax/loc stx method)
+                (syntax/loc stx sym)
+                #`((wrapped-object-object #,(syntax/loc stx receiver)) #,@arg-list)
+                rest-arg?
+                kw-args/var))
+              (let ([receiver (wrapped-object-object receiver)])
+                (unsyntax
+                 (make-method-call
+                  stx
+                  (syntax/loc stx receiver)
+                  (syntax/loc stx method-in-wrapper-fallback-case)
+                  (syntax/loc stx sym)
+                  arg-list
+                  rest-arg?
+                  kw-args/var))))
+          (unsyntax
+           (make-method-call
+            stx
+            (syntax/loc stx receiver)
+            (syntax/loc stx method)
+            (syntax/loc stx sym)
+            arg-list
+            rest-arg?
+            kw-args/var))))))
+
 (provide (protect-out make-this-map make-this%-map make-field-map make-method-map 
                       make-direct-method-map 
                       make-rename-super-map make-rename-inner-map
                       make-init-error-map make-init-redirect super-error-map 
                       make-with-method-map
-                      flatten-args make-method-call
+                      flatten-args make-method-call 
+                      make-method-call-to-possibly-wrapped-object
                       do-localize make-private-name
                       generate-super-call generate-inner-call
                       generate-class-expand-context class-top-level-context?))