suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added in a use of Shu-yu's opt/c to see if it helps (which it does for complex contracts)

Browse Source
This commit is contained in:
Robby Findler 2010-08-04 08:08:55 -05:00
parent 40cde743a9
commit d2894e7a8e
2 changed files with 22 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/racket/contract/private/arr-i.rkt
View File

@ -3,6 +3,7 @@
(require "arrow.rkt" (require "arrow.rkt"
"prop.rkt" "prop.rkt"
"guts.rkt" "guts.rkt"
"opt.rkt"
unstable/location unstable/location
(for-syntax racket/base (for-syntax racket/base
racket/stxparam-exptime racket/stxparam-exptime
@ -279,7 +280,7 @@
;; all of the non-dependent argument contracts ;; all of the non-dependent argument contracts
(list arg-exp-xs ...) (list arg-exp-xs ...)
;; all of the dependent argument contracts ;; all of the dependent argument contracts
(list #,@(filter values (map (λ (arg) (and (arg-vars arg) #`(λ #,(arg-vars arg) #,(arg-ctc arg)))) (list #,@(filter values (map (λ (arg) (and (arg-vars arg) #`(λ #,(arg-vars arg) (opt/c #,(arg-ctc arg)))))
(istx-args an-istx)))) (istx-args an-istx))))
;; then the non-dependent argument contracts that are themselves dependend on ;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values (list #,@(filter values
@ -295,7 +296,7 @@
(istx-ress an-istx)))) (istx-ress an-istx))))
#''()) #''())
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg) (and (res-vars arg) #`(λ #,(res-vars arg) #,(res-ctc arg)))) #`(list #,@(filter values (map (λ (arg) (and (res-vars arg) #`(λ #,(res-vars arg) (opt/c #,(res-ctc arg)))))
(istx-ress an-istx)))) (istx-ress an-istx))))
#''()) #''())
;; WRONG! this needs to be a subset of the previuos^2 (and to generate a let to share appropriately) ;; WRONG! this needs to be a subset of the previuos^2 (and to generate a let to share appropriately)

56
collects/racket/contract/scratch.rkt
View File

@ -5,44 +5,30 @@
#; #;
(pretty-print (pretty-print
(syntax->datum (expand-once (syntax->datum (expand-once
#'(->i ([f number?] #'(->i ([x number?] [y (x) (<=/c x)]) any))))
[y (f) (<=/c f)])
any)))) (pretty-print
(syntax->datum (expand
#'(->i ([x number?] [y number?] [z (x y) (if (<= x y) (<=/c x) (<=/c y))]) any))))
#; #;
((contract (->i ([f number?] ((contract (->i ([x number?] [y (x) (<=/c x)]) any)
[y (f) (<=/c f)])
any)
(λ (x y) (+ x y)) (λ (x y) (+ x y))
'pos 'neg) 'pos 'neg)
-1 -1) -1 -1)
(define f0 (λ (x y) (+ x y))) ;; timing tests:
(define f1 (define f1
(contract (-> number? (<=/c 0) any) (contract (-> number? number? (or/c (<=/c 1) (<=/c 2)) any)
(λ (x y) (+ x y)) (λ (x y z) (+ x y z))
'pos 'neg)) 'pos 'neg))
(define f2 (define f2
(contract (->i ([x number?] [y (<=/c 0)]) any) (contract (->i ([x number?] [y number?] [z (x y) (or/c (<=/c x) (<=/c y))]) any)
(λ (x y) (+ x y)) (λ (x y z) (+ x y z))
'pos 'neg))
(define f3
(contract (->i ([x number?] [y (x) (<=/c x)]) any)
(λ (x y) (+ x y))
'pos 'neg))
(define f4
(contract (->d ([x number?] [y (<=/c 0)]) any)
(λ (x y) (+ x y))
'pos 'neg))
(define f5
(contract (->d ([x number?] [y (<=/c x)]) any)
(λ (x y) (+ x y))
'pos 'neg)) 'pos 'neg))
@ -50,23 +36,19 @@
(time (time
(let loop ([n 100000]) (let loop ([n 100000])
(unless (zero? n) (unless (zero? n)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1)
(loop (- n 1)))))) (loop (- n 1))))))
'ignore: (tme f1) 'ignore: (tme f1)
'f0 (tme f0)
'f1 (tme f1) 'f1 (tme f1)
'f2 (tme f2) 'f2 (tme f2)
'f3 (tme f3)
'f4 (tme f4)
'f5 (tme f5)
#| #|
test cases: test cases: