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

improved the integration between ->i and Shu-yu's contract optimization.

Browse Source 
When calling this function:

   (contract (->i ([x integer?]
                   [y (x) (>=/c x)])
                  any)
             (λ (x y) x)
             'pos
             'neg)

before this change it took this much time (to call the function many times):

  cpu time: 1596 real time: 1606 gc time: 191

and after this change it takes this much time:

  cpu time: 791 real time: 794 gc time: 7

Of course, on the same machine, just calling (λ (x y) x) the same number of times
gives us back this:

  cpu time: 0 real time: 0 gc time: 0

sigh.

For perhaps another point of reference, this:

   (contract (-> integer? integer? any)
             (λ (x y) x)
             'pos
             'neg)

takes this much time:

  cpu time: 393 real time: 395 gc time: 0
This commit is contained in:
Robby Findler 2010-08-21 13:46:26 -05:00
parent 72f31ffec0
commit 0b1e89bb50
2 changed files with 111 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -366,10 +366,11 @@
arg
wrapper-arg
(if (arg/res-vars arg)
#`(un-dep (#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))) #,wrapper-arg
#,(if swapped-blame?
#'indy-dom-blame
#'indy-rng-blame))
#`(#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))
#,wrapper-arg
#,(if swapped-blame?
#'indy-dom-blame
#'indy-rng-blame))
#`(#,indy-arg-proj-var #,wrapper-arg)))])
(list))])
#`(let (#,@indy-binding
@ -385,10 +386,11 @@
#'swapped-blame
#'blame))]
[(arg/res-vars arg)
#`(un-dep (#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))) #,wrapper-arg
#,(if swapped-blame?
#'swapped-blame
#'blame))]
#`(#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))
#,wrapper-arg
#,(if swapped-blame?
#'swapped-blame
#'blame))]
[else
#`(#,arg-proj-var #,wrapper-arg)]))])
#,body)))))
@ -464,8 +466,7 @@
;; but it contains #fs in places where we don't need the indy projections (because the corresponding
;; result is not dependened on by anything)
[indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary
(and #;(not (arg/res-vars x))
(free-identifier-mapping-get used-indy-vars
(and (free-identifier-mapping-get used-indy-vars
(arg/res-var x)
(λ () #f))
(arg/res-var x))))
@ -636,14 +637,15 @@
;; all of the dependent argument contracts
(list #,@(filter values (map (λ (arg)
(and (arg/res-vars arg)
#`(λ #,(arg/res-vars arg)
(opt/c #,(syntax-property
(syntax-property
(arg/res-ctc arg)
'racket/contract:negative-position
this->i)
'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary))))))
#`(λ (#,@(arg/res-vars arg) val blame)
(opt/direct #,(syntax-property
(syntax-property
(arg/res-ctc arg)
'racket/contract:negative-position
this->i)
'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary))
val blame))))
args+rst)))
;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values
@ -660,14 +662,24 @@
#,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg)
(and (arg/res-vars arg)
#`(λ #,(arg/res-vars arg)
(opt/c #,(syntax-property
(syntax-property
(arg/res-ctc arg)
'racket/contract:positive-position
this->i)
'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary))))))
(if (eres? arg)
#`(λ #,(arg/res-vars arg)
(opt/c #,(syntax-property
(syntax-property
(arg/res-ctc arg)
'racket/contract:positive-position
this->i)
'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary))))
#`(λ (#,@(arg/res-vars arg) val blame)
(opt/direct #,(syntax-property
(syntax-property
(arg/res-ctc arg)
'racket/contract:positive-position
this->i)
'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary))
val blame)))))
(istx-ress an-istx))))
#''())
#,(if (istx-ress an-istx)

119
collects/racket/contract/private/opt.rkt
View File

@ -6,6 +6,7 @@
(for-syntax racket/stxparam))
(provide opt/c define-opt/c define/opter opt-stronger-vars-ref
opt/direct
begin-lifted)
;; define/opter : id -> syntax
@ -80,58 +81,57 @@
(with-syntax (((stronger ...) strongers))
(syntax (and stronger ...))))))
;; opt/i : id opt/info syntax ->
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
(define-for-syntax (opt/i opt/info stx)
;; the case dispatch here must match what top-level-unknown? is doing
(syntax-case stx ()
[(ctc arg ...)
(and (identifier? #'ctc) (opter #'ctc))
((opter #'ctc) opt/i opt/info stx)]
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
((opter #'argless-ctc) opt/i opt/info stx)]
[(f arg ...)
(and (identifier? #'f)
(syntax-parameter-value #'define/opt-recursive-fn)
(free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
#'f))
(values
#`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...)
null
null
null
#f
#f
null)]
[else
(opt/unknown opt/i opt/info stx)]))
;; top-level-unknown? : syntax -> boolean
;; this must match what opt/i is doing
(define-for-syntax (top-level-unknown? stx)
(syntax-case stx ()
[(ctc arg ...)
(and (identifier? #'ctc) (opter #'ctc))
#f]
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
#f]
[(f arg ...)
(and (identifier? #'f)
(syntax-parameter-value #'define/opt-recursive-fn)
(free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
#'f))
#f]
[else
#t]))
;; opt/c : syntax -> syntax
;; opt/c is an optimization routine that takes in an sexp containing
;; contract combinators and attempts to "unroll" those combinators to save
;; on things such as closure allocation time.
(define-syntax (opt/c stx)
;; opt/i : id opt/info syntax ->
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
(define (opt/i opt/info stx)
;; the case dispatch here must match what top-level-unknown? is doing
(syntax-case stx ()
[(ctc arg ...)
(and (identifier? #'ctc) (opter #'ctc))
((opter #'ctc) opt/i opt/info stx)]
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
((opter #'argless-ctc) opt/i opt/info stx)]
[(f arg ...)
(and (identifier? #'f)
(syntax-parameter-value #'define/opt-recursive-fn)
(free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
#'f))
(values
#`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...)
null
null
null
#f
#f
null)]
[else
(opt/unknown opt/i opt/info stx)]))
;; top-level-unknown? : syntax -> boolean
;; this must match what the function above is doing
(define (top-level-unknown? stx)
(syntax-case stx ()
[(ctc arg ...)
(and (identifier? #'ctc) (opter #'ctc))
#f]
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
#f]
[(f arg ...)
(and (identifier? #'f)
(syntax-parameter-value #'define/opt-recursive-fn)
(free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
#'f))
#f]
[else
#t]))
(syntax-case stx ()
[(_ e)
(if (top-level-unknown? #'e)
@ -173,6 +173,31 @@
(vector)
(begin-lifted (box #f)))))))]))
;; this macro optimizes 'e' as a contract
(define-syntax (opt/direct stx)
(syntax-case stx ()
[(_ e val-e blame-e)
(let*-values ([(info) (make-opt/info #'ctc
#'val
#'blame
#f
'()
#f
#f
#'this
#'that)]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
#`(let ([ctc e] ;;; hm... what to do about this?!
[val val-e]
[blame blame-e])
#,(bind-superlifts
superlifts
(bind-lifts
lifts
(bind-superlifts
partials
next)))))]))
(define-syntax (begin-lifted stx)
(syntax-case stx ()
[(_ expr)