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

Got to the point where I can run some timings to see how well ->i does.

Browse Source 
Here are the results, each contract put on the same function, namely:
(λ (x y) (+ x y))

1: (-> number? (<=/c 0) any)
2: (->i ([x number?] [y (<=/c 0)]) any)
3: (->i ([x number?] [y (x) (<=/c x)]) any)
4: (->d ([x number?] [y (<=/c 0)]) any)
5: (->d ([x number?] [y (<=/c x)]) any)

Taking f1 as the baseline, these are the relative times for calling
that thing over and over in a loop, supplying -1 as both of the
arguments:

f2: 1.01x
f3: 4.15x
f4: 21.1x
f5: 21.5x
This commit is contained in:
Robby Findler 2010-08-04 06:51:32 -05:00
parent 599fe85a16
commit 40cde743a9
2 changed files with 131 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,13 +21,20 @@
;; arg-ctcs : (listof contract) ;; arg-ctcs : (listof contract)
;; arg-dep-ctcs : (-> ??? (listof contract)) ;; arg-dep-ctcs : (-> ??? (listof contract))
;; indy-arg-ctcs : (listof contract)
;; rng-ctcs : (listof contract) ;; rng-ctcs : (listof contract)
;; rng-dep-ctcs : (-> ??? (listof contract)) ;; rng-dep-ctcs : (-> ??? (listof contract))
;; indy-rng-ctcs : (listof contract)
;; mandatory-args, opt-args : number ;; mandatory-args, opt-args : number
;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keyword<? ;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keyword<?
;; rest? : boolean ;; rest? : boolean
;; here : quoted-spec for use in assigning indy blame
;; mk-wrapper : creates the a wrapper function that implements the contract checking ;; mk-wrapper : creates the a wrapper function that implements the contract checking
(struct ->i (arg-ctcs indy-arg-ctcs arg-dep-ctcs rng-ctcs indy-rng-ctcs rng-dep-ctcs mandatory-args opt-args mandatory-kwds opt-kwds rest? here mk-wrapper) (struct ->i (arg-ctcs arg-dep-ctcs indy-arg-ctcs
rng-ctcs rng-dep-ctcs indy-rng-ctcs
mandatory-args opt-args mandatory-kwds opt-kwds rest?
here
mk-wrapper)
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection #:projection
@ -158,17 +165,23 @@
(define-for-syntax (maybe-generate-temporary x) (define-for-syntax (maybe-generate-temporary x)
(and x (car (generate-temporaries (list x))))) (and x (car (generate-temporaries (list x)))))
(define-for-syntax (mk-wrapper-func an-istx) (define-for-syntax (mk-wrapper-func an-istx used-indy-vars)
(let-values ([(ordered-args arg-indicies) (find-ordering (istx-args an-istx))]) (let-values ([(ordered-args arg-indicies) (find-ordering (istx-args an-istx))])
(let ([wrapper-args (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))] (let ([wrapper-args (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))]
[indy-args (generate-temporaries (map arg-var ordered-args))] [indy-args (generate-temporaries (map arg-var ordered-args))]
[arg-proj-vars (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))] [arg-proj-vars (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))]
;; WRONG: need to remove unused indy projections
;; this list is parallel to arg-proj-vars (so use arg-indicies to find the right ones in the loop below) ;; this list is parallel to arg-proj-vars (so use arg-indicies to find the right ones in the loop below)
;; but it contains #fs in places where we don't need the indy projections ;; but it contains #fs in places where we don't need the indy projections (because the corresponding
[indy-arg-proj-vars (list->vector (map maybe-generate-temporary (map (λ (x) (and (not (arg-vars x)) (arg-var x))) (istx-args an-istx))))]) ;; argument is not dependened on anywhere)
[indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary
(and (not (arg-vars x))
(free-identifier-mapping-get used-indy-vars
(arg-var x)
(λ () #f))
(arg-var x))))
(istx-args an-istx)))])
(define (arg-to-indy-var var) (define (arg-to-indy-var var)
(let loop ([iargs indy-args] (let loop ([iargs indy-args]
@ -185,9 +198,13 @@
#`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc #`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc
;; first the non-dependent arg projections ;; first the non-dependent arg projections
#,@(filter values (map (λ (arg arg-proj-var) (and (not (arg-vars arg)) arg-proj-var)) (istx-args an-istx) (vector->list arg-proj-vars))) #,@(filter values (map (λ (arg arg-proj-var) (and (not (arg-vars arg)) arg-proj-var))
(istx-args an-istx)
(vector->list arg-proj-vars)))
;; then the dependent arg projections ;; then the dependent arg projections
#,@(filter values (map (λ (arg arg-proj-var) (and (arg-vars arg) arg-proj-var)) (istx-args an-istx) (vector->list arg-proj-vars))) #,@(filter values (map (λ (arg arg-proj-var) (and (arg-vars arg) arg-proj-var))
(istx-args an-istx)
(vector->list arg-proj-vars)))
;; then the non-dependent indy projections ;; then the non-dependent indy projections
#,@(filter values (vector->list indy-arg-proj-vars))) #,@(filter values (vector->list indy-arg-proj-vars)))
(λ (val) (λ (val)
@ -208,19 +225,25 @@
#,wrapper-arg #,wrapper-arg
#,stx) #,stx)
stx)) stx))
#`(let (
;; WRONG! can avoid creating this thing if it isn't used elsewhere. (let ([indy-binding
[#,indy-arg ;; if indy-arg-proj-var is #f, that means that we don't need that binding here, so skip it
(if indy-arg-proj-var
(list
#`[#,indy-arg
#,(add-unsupplied-check #,(add-unsupplied-check
(if (arg-vars arg) (if (arg-vars arg)
#`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg indy-dom-blame) #`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg indy-dom-blame)
#`(#,indy-arg-proj-var #,wrapper-arg)))] #`(#,indy-arg-proj-var #,wrapper-arg)))])
(list))])
#`(let (#,@indy-binding
[#,wrapper-arg [#,wrapper-arg
#,(add-unsupplied-check #,(add-unsupplied-check
(if (arg-vars arg) (if (arg-vars arg)
#`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg swapped-blame) #`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg swapped-blame)
#`(#,arg-proj-var #,wrapper-arg)))]) #`(#,arg-proj-var #,wrapper-arg)))])
#,body)))) #,body)))))
ctc)))))) ctc))))))
(define (un-dep ctc obj blame) (define (un-dep ctc obj blame)
@ -244,21 +267,29 @@
(define-syntax (->i/m stx) (define-syntax (->i/m stx)
(let* ([an-istx (parse-->i stx)] (let* ([an-istx (parse-->i stx)]
[used-indy-vars (used-indy-vars an-istx)] [used-indy-vars (used-indy-vars an-istx)]
[wrapper-func (mk-wrapper-func an-istx)]) [wrapper-func (mk-wrapper-func an-istx used-indy-vars)])
;(printf "used-indy-vars:") (free-identifier-mapping-for-each used-indy-vars (λ (x y) (printf " ~a" x))) (printf "\n") (with-syntax ([(arg-exp-xs ...)
#`(->i (list #,@(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg))) (generate-temporaries (filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-var arg)))
(istx-args an-istx)))) (istx-args an-istx))))]
;; WRONG! this needs to be a subset of the previous list (and to generate a let to share appropriately) [(arg-exps ...)
(list #,@(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg))) (filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg)))
(istx-args an-istx)))) (istx-args an-istx)))])
#`(let ([arg-exp-xs arg-exps] ...)
(->i
;; all of the non-dependent argument contracts
(list arg-exp-xs ...)
;; 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) #,(arg-ctc arg))))
(istx-args an-istx)))) (istx-args an-istx))))
;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values
(map (λ (arg indy-id)
(and (free-identifier-mapping-get used-indy-vars (arg-var arg) (λ () #f))
indy-id))
(filter (λ (arg) (not (arg-vars arg))) (istx-args an-istx))
(syntax->list #'(arg-exp-xs ...)))))
#,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg) (and (not (res-vars arg)) (res-ctc arg)))
(istx-ress an-istx))))
#''())
;; WRONG! this needs to be a subset of the previuos (and to generate a let to share appropriately)
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg) (and (not (res-vars arg)) (res-ctc arg))) #`(list #,@(filter values (map (λ (arg) (and (not (res-vars arg)) (res-ctc arg)))
(istx-ress an-istx)))) (istx-ress an-istx))))
@ -267,6 +298,11 @@
#`(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) #,(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)
#,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg) (and (not (res-vars arg)) (res-ctc arg)))
(istx-ress an-istx))))
#''())
#,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg)))) #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg))))
(istx-args an-istx)))) (istx-args an-istx))))
@ -280,4 +316,4 @@
keyword<?) keyword<?)
#,(and (istx-rst an-istx) #t) #,(and (istx-rst an-istx) #t)
(quote-module-path) (quote-module-path)
#,wrapper-func))) #,wrapper-func)))))

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

@ -2,60 +2,71 @@
(require racket/contract (require racket/contract
racket/pretty) racket/pretty)
#;
(pretty-print (pretty-print
(syntax->datum (expand-once (syntax->datum (expand-once
#'(->i ([f (-> number? number?)] #'(->i ([f number?]
[y (f) (<=/c (begin (printf "f: ~s\n" f) (f 'not-a-number)))]) [y (f) (<=/c f)])
any)))) any))))
((contract (->i ([f (-> number? number?)] #;
[y (f) (<=/c (begin (printf "f: ~s\n" f) (f 'not-a-number)))]) ((contract (->i ([f number?]
[y (f) (<=/c f)])
any) any)
(λ (f y) (f 'another-non-number) 'final-result) (λ (x y) (+ x y))
'pos 'neg) 'pos 'neg)
(λ (x) (* x x)) -1 -1)
-10)
#;
(define (coerce-proj x)
...)
#;
(build-->i
(list number?)
(list (λ (x pos neg blame info) (coerce-proj (<=/c x) pos neg blame info)))
(λ (x/c y/proc) ;; <= arguments are in strange order: first the non-dependent things, then the dependent things
(λ (pos neg blame info)
(let ([here ...])
(let ([x/proj (x/c neg pos blame info)]
[x/proj/i (x/c here pos blame info)])
(λ (f)
(λ (x y)
(let ([x (x/proj x)]
[xi (x/proj/i x)])
(let ([y (y/proc xi neg pos blame info)]
[y (y/proc xi here pos blame info)])
(f x y))))))))))
#;
(build-->i
(list number?)
(list (λ (x) (coerce-proj (<=/c x))))
(λ (proj-x proj-x/i y/proc here pos neg blame info)
;; λ arguments are in strange order: first the non-dependent things,
;; then the dependent things
(λ (f)
(λ (x y)
(let ([x (x/proj x)]
[xi (x/proj/i x)])
(let ([y (y/proc xi neg pos blame info)]
[yi (y/proc xi here pos blame info)])
(f x y)))))))
;(pretty-print (syntax->datum (expand #'(-> number? (<=/c 10) any))))
;(pretty-print (syntax->datum (expand #'(->* () (#:fst number? #:snd boolean?) any))))
(define f0 (λ (x y) (+ x y)))
(define f1
(contract (-> number? (<=/c 0) any)
(λ (x y) (+ x y))
'pos 'neg))
(define f2
(contract (->i ([x number?] [y (<=/c 0)]) any)
(λ (x y) (+ x y))
'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))
(define (tme f)
(time
(let loop ([n 100000])
(unless (zero? n)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1)
(f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1)
(loop (- n 1))))))
'ignore: (tme f1)
'f0 (tme f0)
'f1 (tme f1)
'f2 (tme f2)
'f3 (tme f3)
'f4 (tme f4)
'f5 (tme f5)
#| #|
test cases: test cases: