From 6575c9c58d862f1b207e45048b39c34f8f0d97e3 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 13 Jul 2006 14:49:12 +0000
Subject: [PATCH] fixed performance problem with (provide/contract (struct
 ...))

svn: r3698
---
 collects/mzlib/private/contract.ss | 49 ++++++++++++++++++++----------
 1 file changed, 33 insertions(+), 16 deletions(-)

diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss
index 39c2e4b55c..8ff0496ff9 100644
--- a/collects/mzlib/private/contract.ss
+++ b/collects/mzlib/private/contract.ss
@@ -456,22 +456,12 @@ add struct contracts for immutable structs?
                        mutator-codes ...
                        predicate-code
                        constructor-code
-                       (define -struct:struct-name
-                         (let-values ([(struct:struct-name _make _pred _get _set)
-                                       (make-struct-type 'struct-name
-                                                         struct:struct-name
-                                                         0 ;; init
-                                                         0 ;; auto
-                                                         #f  ;; auto-v
-                                                         '() ;; props
-                                                         #f  ;; inspector
-                                                         #f ;; proc-spec
-                                                         '
-                                                         ()  ;; immutable-k-list
-                                                         (λ (selector-ids ... ignore) 
-                                                           (values (-contract field-contract-ids selector-ids 'not-enough-info-for-blame 'not-enough-info-for-blame)
-                                                                   ...)))])
-                           struct:struct-name))
+                       
+                       ;; expanding out the body of the `make-pc-struct-type' function
+                       ;; directly here in the expansion makes this very expensive at compile time
+                       ;; when there are a lot of provide/contract clause using structs
+                       (define -struct:struct-name 
+                         (make-pc-struct-type 'struct-name struct:struct-name field-contract-ids ...))
                        (provide (rename -struct:struct-name struct:struct-name)))))))))
           
          (define (map/count f . ls)
@@ -600,6 +590,33 @@ add struct contracts for immutable structs?
               bodies ...))))]))
   
   
+  (define (make-pc-struct-type struct-name struct:struct-name . ctcs)
+    (let-values ([(struct:struct-name _make _pred _get _set)
+                  (make-struct-type struct-name
+                                    struct:struct-name
+                                    0 ;; init
+                                    0 ;; auto
+                                    #f  ;; auto-v
+                                    '() ;; props
+                                    #f  ;; inspector
+                                    #f ;; proc-spec
+                                    '()  ;; immutable-k-list
+                                    (λ args
+                                      (let ([vals (let loop ([args args])
+                                                    (cond
+                                                      [(null? args) null]
+                                                      [(null? (cdr args)) null]
+                                                      [else (cons (car args) (loop (cdr args)))]))])
+                                        (apply values
+                                               (map (λ (ctc val)
+                                                      (-contract ctc
+                                                                 val
+                                                                 'not-enough-info-for-blame
+                                                                 'not-enough-info-for-blame))
+                                                    ctcs
+                                                    vals)))))])
+      struct:struct-name))
+  
   (define (test-proc/flat-contract f x)
     (if (flat-contract? f)
         ((flat-contract-predicate f) x)