added two stress tests for ->i performance

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" *)

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)

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)
+