diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 4c4ab846c1..8d3383a90c 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -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) diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt index bc7d95ce82..20cf5174a8 100644 --- a/collects/racket/contract/private/opt.rkt +++ b/collects/racket/contract/private/opt.rkt @@ -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])) - +(define-syntax (opt/c stx) (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)