Got to the point where I can run some timings to see how well ->i does.
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
parent
599fe85a16
commit
40cde743a9
|
|
@ -21,13 +21,20 @@
|
|||
|
||||
;; arg-ctcs : (listof contract)
|
||||
;; arg-dep-ctcs : (-> ??? (listof contract))
|
||||
;; indy-arg-ctcs : (listof contract)
|
||||
;; rng-ctcs : (listof contract)
|
||||
;; rng-dep-ctcs : (-> ??? (listof contract))
|
||||
;; indy-rng-ctcs : (listof contract)
|
||||
;; mandatory-args, opt-args : number
|
||||
;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keyword<?
|
||||
;; rest? : boolean
|
||||
;; here : quoted-spec for use in assigning indy blame
|
||||
;; 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
|
||||
(build-contract-property
|
||||
#:projection
|
||||
|
|
@ -158,17 +165,23 @@
|
|||
(define-for-syntax (maybe-generate-temporary 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 ([wrapper-args (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))]
|
||||
[indy-args (generate-temporaries (map arg-var ordered-args))]
|
||||
[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)
|
||||
;; but it contains #fs in places where we don't need the indy projections
|
||||
[indy-arg-proj-vars (list->vector (map maybe-generate-temporary (map (λ (x) (and (not (arg-vars x)) (arg-var x))) (istx-args an-istx))))])
|
||||
;; but it contains #fs in places where we don't need the indy projections (because the corresponding
|
||||
;; 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)
|
||||
(let loop ([iargs indy-args]
|
||||
|
|
@ -185,9 +198,13 @@
|
|||
|
||||
#`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc
|
||||
;; 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
|
||||
#,@(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
|
||||
#,@(filter values (vector->list indy-arg-proj-vars)))
|
||||
(λ (val)
|
||||
|
|
@ -208,19 +225,25 @@
|
|||
#,wrapper-arg
|
||||
#,stx)
|
||||
stx))
|
||||
#`(let (
|
||||
;; WRONG! can avoid creating this thing if it isn't used elsewhere.
|
||||
[#,indy-arg
|
||||
|
||||
(let ([indy-binding
|
||||
;; 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
|
||||
(if (arg-vars arg)
|
||||
#`(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
|
||||
#,(add-unsupplied-check
|
||||
(if (arg-vars arg)
|
||||
#`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg swapped-blame)
|
||||
#`(#,arg-proj-var #,wrapper-arg)))])
|
||||
#,body))))
|
||||
#,body)))))
|
||||
ctc))))))
|
||||
|
||||
(define (un-dep ctc obj blame)
|
||||
|
|
@ -244,21 +267,29 @@
|
|||
(define-syntax (->i/m stx)
|
||||
(let* ([an-istx (parse-->i stx)]
|
||||
[used-indy-vars (used-indy-vars an-istx)]
|
||||
[wrapper-func (mk-wrapper-func an-istx)])
|
||||
;(printf "used-indy-vars:") (free-identifier-mapping-for-each used-indy-vars (λ (x y) (printf " ~a" x))) (printf "\n")
|
||||
#`(->i (list #,@(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg)))
|
||||
(istx-args an-istx))))
|
||||
;; WRONG! this needs to be a subset of the previous list (and to generate a let to share appropriately)
|
||||
(list #,@(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg)))
|
||||
(istx-args an-istx))))
|
||||
[wrapper-func (mk-wrapper-func an-istx used-indy-vars)])
|
||||
(with-syntax ([(arg-exp-xs ...)
|
||||
(generate-temporaries (filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-var arg)))
|
||||
(istx-args an-istx))))]
|
||||
[(arg-exps ...)
|
||||
(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg)))
|
||||
(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))))
|
||||
(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)
|
||||
#`(list #,@(filter values (map (λ (arg) (and (not (res-vars arg)) (res-ctc arg)))
|
||||
(istx-ress an-istx))))
|
||||
|
|
@ -267,6 +298,11 @@
|
|||
#`(list #,@(filter values (map (λ (arg) (and (res-vars arg) #`(λ #,(res-vars arg) #,(res-ctc arg))))
|
||||
(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))))
|
||||
(istx-args an-istx))))
|
||||
|
|
@ -280,4 +316,4 @@
|
|||
keyword<?)
|
||||
#,(and (istx-rst an-istx) #t)
|
||||
(quote-module-path)
|
||||
#,wrapper-func)))
|
||||
#,wrapper-func)))))
|
||||
|
|
|
|||
|
|
@ -2,60 +2,71 @@
|
|||
(require racket/contract
|
||||
racket/pretty)
|
||||
|
||||
#;
|
||||
(pretty-print
|
||||
(syntax->datum (expand-once
|
||||
#'(->i ([f (-> number? number?)]
|
||||
[y (f) (<=/c (begin (printf "f: ~s\n" f) (f 'not-a-number)))])
|
||||
#'(->i ([f number?]
|
||||
[y (f) (<=/c f)])
|
||||
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)
|
||||
(λ (f y) (f 'another-non-number) 'final-result)
|
||||
(λ (x y) (+ x y))
|
||||
'pos 'neg)
|
||||
(λ (x) (* x x))
|
||||
-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))))
|
||||
-1 -1)
|
||||
|
||||
|
||||
(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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user