From 0237050ae0ae29078a8f4d660de49d3c23e0824d Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Mon, 8 Nov 2010 15:36:53 -0500
Subject: [PATCH] Improve ->* expansion in certain cases.

In some expansions, the function used to check the results could appear
multiple times in the expansion.  Factor out the results checker so that
we expand into multiple references to the same name, instead of inlining
the same lambda multiple times.
---
 collects/racket/contract/private/arrow.rkt | 47 +++++++++++++---------
 1 file changed, 27 insertions(+), 20 deletions(-)

diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index 22e95a0751..34162b40c1 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -164,7 +164,11 @@ v4 todo:
                          (for/list ([r (in-list rngs)])
                            (list r (gensym 'rng)))
                          null)])
-        (with-syntax ([(rng-checker ...)
+        (with-syntax ([(rng-checker-name ...)
+                       (if rngs
+                           (list (gensym 'rng-checker))
+                           null)]
+                      [(rng-checker ...)
                        (if rngs
                            (with-syntax ([rng-len (length rngs)]
                                          [rng-pluralize (if (and (pair? rngs) (null? (cdr rngs))) "" "s")])
@@ -258,7 +262,7 @@ v4 todo:
                                         (λ (s) #`(values #,@s this-param ... (dom-ctc dom-x) ...)))])
                                (if no-rng-checking?
                                    (inner-stx-gen #'())
-                                   (check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker ...) inner-stx-gen)))]
+                                   (check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker-name ...) inner-stx-gen)))]
                             [kwd-return
                              (let* ([inner-stx-gen
                                      (if need-apply-values?
@@ -276,7 +280,7 @@ v4 todo:
                                                #,(inner-stx-gen s #'(kwd-results)))))])
                                (if no-rng-checking?
                                    (outer-stx-gen #'())
-                                   (check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker ...) outer-stx-gen)))])
+                                   (check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen)))])
                 (with-syntax ([basic-lambda-name (gensym 'basic-lambda)]
                               [basic-lambda #'(λ basic-params pre ... basic-return)]
                               [kwd-lambda-name (gensym 'kwd-lambda)]
@@ -322,25 +326,28 @@ v4 todo:
                                    [else (cons #'list (build-list (add1 (- max-arity min-arity)) (λ (n) (+ min-arity n))))])])
                     (cond
                       [(and (null? req-keywords) (null? opt-keywords))
-                       #`(let ([basic-lambda-name basic-lambda])
-                           (if (matches-arity-exactly? val contract-arity null null)
-                               basic-lambda-name
-                               (let-values ([(vr va) (procedure-keywords val)]
-                                            [(basic-checker-name) basic-checker])
-                                 (if (or (not va) (pair? vr) (pair? va))
-                                     (make-keyword-procedure kwd-checker basic-checker-name)
-                                     basic-checker-name))))]
+                       #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
+                           (let ([basic-lambda-name basic-lambda])
+                             (if (matches-arity-exactly? val contract-arity null null)
+                                 basic-lambda-name
+                                 (let-values ([(vr va) (procedure-keywords val)]
+                                              [(basic-checker-name) basic-checker])
+                                   (if (or (not va) (pair? vr) (pair? va))
+                                       (make-keyword-procedure kwd-checker basic-checker-name)
+                                       basic-checker-name)))))]
                       [(pair? req-keywords)
-                       #`(let ([kwd-lambda-name kwd-lambda])
-                           (if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...))
-                               kwd-lambda-name
-                               (make-keyword-procedure kwd-checker basic-checker)))]
+                       #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
+                           (let ([kwd-lambda-name kwd-lambda])
+                             (if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...))
+                                 kwd-lambda-name
+                                 (make-keyword-procedure kwd-checker basic-checker))))]
                       [else
-                       #`(let ([basic-lambda-name basic-lambda]
-                               [kwd-lambda-name kwd-lambda])
-                           (if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...))
-                               kwd-lambda-name
-                               (make-keyword-procedure kwd-checker basic-checker)))])))))))))))
+                       #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
+                           (let ([basic-lambda-name basic-lambda]
+                                 [kwd-lambda-name kwd-lambda])
+                             (if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...))
+                                 kwd-lambda-name
+                                 (make-keyword-procedure kwd-checker basic-checker))))])))))))))))
 
 ;; pre : (or/c #f (-> any)) -- checks the pre-condition, if there is one.
 ;; post : (or/c #f (-> any)) -- checks the post-condition, if there is one.