From 31f4a120f1ae99700c24ac3f5f8fc07137ee88d3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 22 Oct 2010 13:38:51 -0500 Subject: [PATCH] added two stress tests for ->i performance --- collects/meta/props | 2 + .../tests/racket/contract-stress-argmin.rkt | 69 +++++++++++++++ .../racket/contract-stress-take-right.rkt | 83 +++++++++++++++++++ 3 files changed, 154 insertions(+) create mode 100644 collects/tests/racket/contract-stress-argmin.rkt create mode 100644 collects/tests/racket/contract-stress-take-right.rkt diff --git a/collects/meta/props b/collects/meta/props index 89d8369773..1e6359d77d 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1720,6 +1720,8 @@ path/s is either such a string or a list of them. "collects/tests/racket/contmark.rktl" drdr:command-line #f "collects/tests/racket/contract-mzlib-test.rktl" responsible (robby) drdr:command-line (racket "-qr" *) "collects/tests/racket/contract-opt-tests.rkt" drdr:command-line (racket "-f" *) +"collects/tests/racket/contract-stress-argmin.rkt" responsible (robby) +"collects/tests/racket/contract-stress-take-right.rkt" responsible (robby) "collects/tests/racket/contract-test.rktl" responsible (robby) drdr:command-line #f "collects/tests/racket/control.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/date.rktl" drdr:command-line (racket "-f" *) diff --git a/collects/tests/racket/contract-stress-argmin.rkt b/collects/tests/racket/contract-stress-argmin.rkt new file mode 100644 index 0000000000..e9ea2e80bf --- /dev/null +++ b/collects/tests/racket/contract-stress-argmin.rkt @@ -0,0 +1,69 @@ +#lang racket/load + +(module argmin racket/base + (require racket/contract) + + ;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X + (define (mk-min cmp name f xs) + (let ([init-min-var (f (car xs))]) + (let loop ([min (car xs)] + [min-var init-min-var] + [xs (cdr xs)]) + (cond + [(null? xs) min] + [else (let ([new-min (f (car xs))]) + (cond + [(cmp new-min min-var) (loop (car xs) new-min (cdr xs))] + [else (loop min min-var (cdr xs))]))])))) + + (define (argmin f xs) (mk-min < 'argmin f xs)) + + (define (good f xs cmp) + (lambda (max) + ;; if (empty? (rest xs)) pick the only element on the list + (define f@max (f max)) + ;; strengthening the contract: make sure that the first element is picked + ;; weakening: just ensure that the condition holds for a random element + (andmap (lambda (x) (cmp f@max (f x))) xs))) + + (provide + [rename-out (argmin o:argmin)]) + + (provide/contract + [rename argmin a:argmin + (-> (-> any/c real?) list? any/c)] + [rename argmin i:argmin + (->i ([f (-> any/c real?)][xs list?]) () + (_result (f xs) (flat-named-contract "minimal element" (good f xs <=))))] + [rename argmin d:argmin + (->d ([f (-> any/c real?)][xs list?]) () + (_result (flat-named-contract "minimal element" (good f xs <=))))])) + +(module argmin-perf racket/base + + (require 'argmin) + + (define (test2 n argmin) + (collect-garbage) (collect-garbage) + (time + (for ((i (in-range (quotient n 2)))) + (argmin (lambda (x) (+ (* x x) 12)) x))) + (list n argmin) + (void)) + + (define n 1000) + (define x (build-list n (lambda (i) (random n)))) + + 'original + (test2 n o:argmin) + + '->-contracted + (test2 n a:argmin) + + 'd-contracted + (test2 n d:argmin) + + 'i-contracted + (test2 n i:argmin)) + +(require 'argmin-perf) diff --git a/collects/tests/racket/contract-stress-take-right.rkt b/collects/tests/racket/contract-stress-take-right.rkt new file mode 100644 index 0000000000..83b347f8c7 --- /dev/null +++ b/collects/tests/racket/contract-stress-take-right.rkt @@ -0,0 +1,83 @@ +#lang racket/load + +(module take-right racket/base + (require racket/contract) + + (define-syntax-rule + (define/lead (name x n) base combine pfx ...) + ;; MF: lead is (- (depth x) n) items, ergo traversing lead leaves + ;; (- (depth x) (- (depth x) n)) = n items to be dealt with + ;; either via a combine ~ cons or an accumulator + (define (name x n) + (let loop ([lead (drop x n)] [x x][pfx '()] ...) + (if (pair? lead) + (combine (car x) (loop (cdr lead) (cdr x) (cons (car x) pfx) ...)) + (base x pfx ...))))) + + (define (drop x n) + (if (zero? n) x (drop (cdr x) (sub1 n)))) + + (define-syntax-rule (K- a b) b) + + (define/lead (take-right x n) + values K-) ;; I 8! values as identity + + ;; S-expression -> natural-number/c + (define (depth l) + (let D ([l l][d 0]) + (if (pair? l) (D (cdr l) (+ d 1)) d))) + + ;; S-expression -> natural-number/c + (define (min-depth x <) + (lambda (n) + (let D ([l x][d n]) + (if (= d 0) + #t + (if (pair? l) + (D (cdr l) (- d 1)) + #f))))) + + (provide + [rename-out (take-right o:take-right)]) + + (provide/contract + [rename take-right a:take-right (-> any/c natural-number/c any/c)] + + [rename take-right d:take-right + (->d ([x any/c][n (and/c natural-number/c (min-depth x <))]) () + (_result (compose (=/c n) depth)))] + + [rename take-right i:take-right + (->i ([x any/c][n (x) (and/c natural-number/c (min-depth x <))]) () + (_result (n) (compose (=/c n) depth)))])) + +(module take-right-perf racket/base + (require 'take-right) + + (define (test n -right) + (define x (build-list n add1)) + (collect-garbage) (collect-garbage) + (time + (for ((i (in-range (quotient n 2)))) + (-right x i))) + (list n -right) + (void)) + + (define n 10000) + (define x (build-list n (lambda (i) (random n)))) + + + 'original + (test n o:take-right) + + '->-contracted + (test n a:take-right) + + 'd-contracted + (test n d:take-right) + + 'i-contracted + (test n i:take-right)) + +(require 'take-right-perf) +