Revert "improve the way plus-one arity functions fall back when they can't see the application site"

This reverts commit c24ddb4a7c.

This optimization was bogus, as shown by the test case in 393d72f153

(Thanks to Sam again for the test case.)

pkgs/racket-doc/scribblings/reference/contract-util.rkt

@@ -1,27 +0,0 @@
-#lang racket/base
-(require scribble/manual)
-
-(provide add-use-sources declare-exporting-ctc)
-
-(define-syntax-rule
-  (add-use-sources (x y ...))
-  (x y ...
-     #:use-sources
-     (racket/contract/private/base
-      racket/contract/private/misc
-      racket/contract/private/provide
-      racket/contract/private/guts
-      racket/contract/private/prop
-      racket/contract/private/blame
-      racket/contract/private/ds
-      racket/contract/private/opt
-      racket/contract/private/basic-opters
-      
-      racket/contract/private/box
-      racket/contract/private/hash
-      racket/contract/private/vector
-      racket/contract/private/struct-dc)))
-
-(define-syntax-rule
-  (declare-exporting-ctc mod)
-  (add-use-sources (declare-exporting mod racket/contract racket)))

racket/collects/racket/contract/private/application-arity-checking.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require (for-template racket/base))
+
 #|
 
 Used to check an application site of a well-known
@@ -13,8 +13,7 @@ a valid-app-shape.
 |#
 
 (provide (struct-out valid-app-shapes)
-         valid-argument-list?
+         valid-argument-list?)
-         generate-medium-speed-wrapper)
 
 ;; valid-arities : (or/c (listof nat) (improper-listof nat))
 ;;    -- if improper, then the last nat indicates that any number
@@ -64,42 +63,6 @@ a valid-app-shape.
      ans?]
     [else #t]))
 
-;; called in the case that the identifier isn't used directly in an
-;; application. Try to generate a case-lambda that can still avoid
-;; the chaperone creation
-(define (generate-medium-speed-wrapper the-valid-app-shape
-                                       chaperone-expr
-                                       extra-arg-function
-                                       neg-party-id
-                                       add-medium-speed-kwd-wrapper-id
-                                       expected-name)
-  (cond
-    [(and the-valid-app-shape
-          (null? (valid-app-shapes-mandatory-kwds the-valid-app-shape))
-          (null? (valid-app-shapes-optional-kwds the-valid-app-shape)))
-     (define chaperone-expr-id (car (generate-temporaries '(medium-speed-wrapper))))
-     (define (mk-n-ids n) (generate-temporaries (build-list n (λ (x) 'medium-speed-wrapper-arg))))
-     (define case-lambda-clauses
-       (let loop ([valid-arities (valid-app-shapes-valid-arities the-valid-app-shape)])
-         (cond
-           [(null? valid-arities)
-            (list #`[args (apply #,chaperone-expr-id args)])]
-           [(number? valid-arities)
-            (with-syntax ([(x ...) (mk-n-ids valid-arities)]
-                          [(rest-arg) (generate-temporaries '(medium-speed-wrapper-dot-arg))])
-              (list
-               #`[(x ... . rest-arg) (apply #,extra-arg-function #,neg-party-id x ... rest-arg)]))]
-           [else
-            (with-syntax ([(x ...) (mk-n-ids (car valid-arities))])
-              (cons #`[(x ...) (#,extra-arg-function #,neg-party-id x ...)]
-                    (loop (cdr valid-arities))))])))
-     #`(let ([#,chaperone-expr-id #,chaperone-expr])
-         (#,add-medium-speed-kwd-wrapper-id
-          #,chaperone-expr-id
-          (let ([#,expected-name (case-lambda #,@case-lambda-clauses)])
-            #,expected-name)))]
-    [else chaperone-expr]))
-
 (define-logger optimizer)
 (define (log-problem stx)
   (log-optimizer-warning 

racket/collects/racket/contract/private/provide.rkt

@@ -88,8 +88,7 @@
     (saved-ho-id-table
      partially-applied-id
      extra-neg-party-argument-fn
-     valid-argument-lists
+     valid-argument-lists)
-     ex-id)
     #:property
     prop:set!-transformer
     (λ (self stx)
@@ -97,9 +96,8 @@
             [saved-ho-id-table (provide/contract-arrow-transformer-saved-ho-id-table self)]
             [extra-neg-party-argument-fn 
              (provide/contract-arrow-transformer-extra-neg-party-argument-fn self)]
-            [the-valid-arg-shapes (provide/contract-arrow-transformer-valid-argument-lists self)]
+            [valid-arg-lists (provide/contract-arrow-transformer-valid-argument-lists self)]
-            [rename-id (provide/contract-info-rename-id self)]
+            [rename-id (provide/contract-info-rename-id self)])
-            [ex-id (provide/contract-arrow-transformer-ex-id self)])
         (with-syntax ([partially-applied-id partially-applied-id]
                       [extra-neg-party-argument-fn extra-neg-party-argument-fn])
           (if (eq? 'expression (syntax-local-context))
@@ -126,15 +124,7 @@
                            (add-rename-id rename-id
                             (syntax-local-lift-expression
                              (add-lifted-property
-                              (generate-medium-speed-wrapper
+                              #'(partially-applied-id lifted-neg-party))))))))
-                               the-valid-arg-shapes
-                               #'(partially-applied-id lifted-neg-party)
-                               (add-neg-party (add-rename-id
-                                               rename-id
-                                               #'extra-neg-party-argument-fn))
-                               #'lifted-neg-party
-                               #'add-medium-speed-kwd-wrapper
-                               ex-id))))))))
                   (when key (hash-set! saved-ho-id-table key lifted-ctc-val))
                   (adjust-location (syntax-local-introduce lifted-ctc-val)))
                 (syntax-case stx (set!)
@@ -148,7 +138,7 @@
                     stx #'id)]
                   [(name more ...)
                    (with-syntax ([app (datum->syntax stx '#%app)])
-                     (if (valid-argument-list? stx the-valid-arg-shapes)
+                     (if (valid-argument-list? stx valid-arg-lists)
                          (with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)])
                            (adjust-location
                             #`(app #,(add-neg-party (add-rename-id
@@ -219,27 +209,12 @@
                  #`(app #,id args ...))]
               [x (identifier? #'x) id])))))
   
-  (define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val ex-id)
+  (define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val)
     (provide/contract-arrow-transformer rename-id
                                         contract-id id
                                         (make-hasheq)
-                                        pai enpfn val ex-id)))
+                                        pai enpfn val)))
 
-(define (add-medium-speed-kwd-wrapper chapone-contracted-proc no-keywords-path)
-  (make-keyword-procedure
-   (λ (kwds kwd-args . args)
-     (keyword-apply chapone-contracted-proc kwds kwd-args args))
-   no-keywords-path))
-
-(define-syntax (maybe-add-name stx)
-  (syntax-case stx ()
-    [(_ expr)
-     (let ()
-       (define name (syntax-local-name))
-       (printf "name! ~s\n" name)
-       (if (symbol? name)
-           #`(let ([#,name expr]) #,name)
-           #'expr))]))
 
 ;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
 ;; given the syntax for an identifier and a contract,
@@ -342,8 +317,7 @@
                    (quote-syntax contract-id) (quote-syntax id)
                    (quote-syntax partially-applied-id)
                    (quote-syntax extra-neg-party-argument-fn)
-                   #,the-valid-app-shapes
+                   #,the-valid-app-shapes)
-                   '#,ex-id)
                 #`(make-provide/contract-transformer
                    (quote-syntax #,id-rename)
                    (quote-syntax contract-id) (quote-syntax id)