From 36368628af81fa75c2df0277a89048ebaf57312a Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 9 Jan 2017 21:21:50 -0600
Subject: [PATCH] adjust -> expansion to make it more friendly to possible
 inlining

---
 .../contract/private/arrow-val-first.rkt      | 135 ++++++++++++++++--
 1 file changed, 121 insertions(+), 14 deletions(-)

diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt
index d36604a0ec..b1b4674b00 100644
--- a/racket/collects/racket/contract/private/arrow-val-first.rkt
+++ b/racket/collects/racket/contract/private/arrow-val-first.rkt
@@ -672,20 +672,50 @@
           method?))
        (syntax-property
         #`(let #,let-bindings
-            #,(quasisyntax/loc stx
-                (build-simple-->
-                 (list #,@regular-args)
-                 '(#,@kwds)
-                 (list #,@kwd-args)
-                 #,(if rngs
-                       #`(list #,@rngs)
-                       #'#f)
-                 #,plus-one-arity-function
-                 #,chaperone-constructor
-                 #,(if ellipsis-info
-                       #`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
-                       #'#f)
-                 #,method?)))
+            #,(cond
+                [(and (not method?)
+                      (null? kwd-args)
+                      (not ellipsis-info))
+                 (define rng-count (and rngs (length rngs)))
+                 (define doms-count (length regular-args))
+                 (cond
+                   [(and (equal? rng-count 1) (= doms-count 0))
+                    (quasisyntax/loc stx
+                      (build-nullary-very-simple-->
+                       #,(car rngs)
+                       #,plus-one-arity-function
+                       #,chaperone-constructor))]
+                   [(and (equal? rng-count 1) (= doms-count 1))
+                    (quasisyntax/loc stx
+                      (build-unary-very-simple-->
+                       #,(car regular-args)
+                       #,(car rngs)
+                       #,plus-one-arity-function
+                       #,chaperone-constructor))]
+                   [else
+                    (quasisyntax/loc stx
+                      (build-very-simple-->
+                       (list #,@regular-args)
+                       #,(if rngs
+                             #`(list #,@rngs)
+                             #'#f)
+                       #,plus-one-arity-function
+                       #,chaperone-constructor))])]
+                [else
+                 (quasisyntax/loc stx
+                   (build-simple-->
+                    (list #,@regular-args)
+                    '(#,@kwds)
+                    (list #,@kwd-args)
+                    #,(if rngs
+                          #`(list #,@rngs)
+                          #'#f)
+                    #,plus-one-arity-function
+                    #,chaperone-constructor
+                    #,(if ellipsis-info
+                          #`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
+                          #'#f)
+                    #,method?))]))
         'racket/contract:contract
         (vector this->
                 ;; the -> in the original input to this guy
@@ -919,6 +949,83 @@
    expected-values
    (if (= 1 expected-values) "" "s")))
 
+(define (build-nullary-very-simple--> _rng
+                                      plus-one-arity-function
+                                      chaperone-constructor)
+  (define rng (coerce-contract '-> _rng))
+  (cond
+    [(and (flat-contract? rng)
+          (eq? void? (flat-contract-predicate rng)))
+     ->void-contract]
+    [(chaperone-contract? rng)
+     (make--> 0
+              '() '() #f #f
+              (list rng) #f
+              plus-one-arity-function
+              chaperone-constructor
+              #f)]
+    [else
+     (make-impersonator-> 0 '() '() #f #f
+                          (list rng) #f
+                          plus-one-arity-function
+                          chaperone-constructor
+                          #f)]))
+
+(define (build-unary-very-simple--> _dom _rng
+                                    plus-one-arity-function
+                                    chaperone-constructor)
+  (define dom (coerce-contract '-> _dom))
+  (define rng (coerce-contract '-> _rng))
+  (cond
+    [(and (any/c? dom)
+          (flat-contract? rng)
+          (eq? boolean? (flat-contract-predicate rng)))
+     any/c->boolean-contract]
+    [(and (chaperone-contract? dom)
+          (chaperone-contract? rng))
+     (make--> 1
+              (list dom) '() #f #f
+              (list rng) #f
+              plus-one-arity-function
+              chaperone-constructor
+              #f)]
+    [else
+     (make-impersonator-> 1
+                          (list dom) '() #f #f
+                          (list rng) #f
+                          plus-one-arity-function
+                          chaperone-constructor
+                          #f)]))
+
+;; INVARIANT: this is not called when `build-unary-very-simple-->`
+;; or `build-nullary-very-simple-->` could have been
+(define (build-very-simple--> raw-regular-doms raw-rngs
+                              plus-one-arity-function
+                              chaperone-constructor)
+  (define regular-doms
+    (for/list ([dom (in-list raw-regular-doms)])
+      (coerce-contract '-> dom)))
+  (define rngs
+    (and raw-rngs
+         (for/list ([rng (in-list raw-rngs)])
+           (coerce-contract '-> rng))))
+  (cond
+    [(and (andmap chaperone-contract? regular-doms)
+          (andmap chaperone-contract? (or rngs '())))
+     (make--> (length raw-regular-doms)
+              regular-doms '() #f #f
+              rngs #f
+              plus-one-arity-function
+              chaperone-constructor
+              #f)]
+    [else
+     (make-impersonator-> (length raw-regular-doms)
+                          regular-doms '() #f #f
+                          rngs #f
+                          plus-one-arity-function
+                          chaperone-constructor
+                          #f)]))
+
 (define (build-simple--> raw-regular-doms
                          mandatory-kwds mandatory-raw-kwd-doms
                          raw-rngs