From ba78b8389be07f6c6fff8868ef449c7d5367ed20 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 9 Sep 2010 09:29:42 -0500 Subject: [PATCH] added a test to show a performance problem in the contract library --- .../tests/stress/racket/contract-lifting.rkt | 44 +++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 collects/tests/stress/racket/contract-lifting.rkt diff --git a/collects/tests/stress/racket/contract-lifting.rkt b/collects/tests/stress/racket/contract-lifting.rkt new file mode 100644 index 0000000000..91cb01f969 --- /dev/null +++ b/collects/tests/stress/racket/contract-lifting.rkt @@ -0,0 +1,44 @@ +#lang racket + +(define-struct/contract s1 ([x any/c] [y any/c])) +(define-struct s2 (x y)) +(define-values (make-s3 s3-x) + (let () + (define-struct s3 (x y)) + (values (contract (-> any/c any/c s3?) + make-s3 + 'pos + 'neg) + (contract (-> s3? any/c) s3-x 'pos 'neg)))) + +(define s4-func + (let ([ns (make-base-namespace)]) + (parameterize ([current-namespace ns]) + (eval '(module m1 racket/base + (require racket/contract) + (define-struct s4 (x y)) + (provide/contract + [make-s4 (-> any/c any/c s4?)] + [s4-x (-> s4? any/c)]))) + (eval '(module m2 racket/base + (require 'm1) + (define (s4-func x) (s4-x (make-s4 x x))) + (provide s4-func))) + (eval '(require 'm2)) + (eval 's4-func)))) + +(define (t f) + (time + (let loop ([n 10000]) + (unless (zero? n) + (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) + (loop (- n 1)))))) + +(t (λ (x) (s1-x (make-s1 x x)))) +(t (λ (x) (s2-x (make-s2 x x)))) +(t (λ (x) (s3-x (make-s3 x x)))) +(t s4-func)