From 2847ac86bd6db934300edc5b9ca7af50e8b3a319 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 17 Aug 2010 16:45:12 -0400 Subject: [PATCH] Rearrange ->d appropriately to use proxies/chaperones. Also remove the old tests for tail-call behavior with ->d. I think it was a faulty way of doing the optimization, and we can't even do it in the same way now, since we can't get the original "raw" arguments to the right place via continuation marks. ->i has a much better chance of having this optimization where possible, and when I start converting ->i, I'll make sure to add appropriate tests. --- collects/racket/contract/private/arrow.rkt | 427 ++++++++++----------- collects/tests/racket/contract-test.rktl | 92 ----- 2 files changed, 208 insertions(+), 311 deletions(-) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index b544f45844..11ea68b28b 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -1170,14 +1170,14 @@ v4 todo: (define ->d-tail-key (gensym '->d-tail-key)) -(define (->d-proj ->d-stct) - (let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))] - [mandatory-count (+ (length (->d-mandatory-dom-ctcs ->d-stct)) - (if (->d-mtd? ->d-stct) 1 0))] +(define ((->d-proj wrap-procedure) ->d-stct) + (let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))] + [mandatory-count (+ (length (base-->d-mandatory-dom-ctcs ->d-stct)) + (if (base-->d-mtd? ->d-stct) 1 0))] [non-kwd-ctc-count (+ mandatory-count opt-count)] [arity (cond - [(->d-rest-ctc ->d-stct) + [(base-->d-rest-ctc ->d-stct) (make-arity-at-least mandatory-count)] [else (let loop ([i 0]) @@ -1189,150 +1189,131 @@ v4 todo: (λ (blame) (let ([this->d-id (gensym '->d-tail-key)]) (λ (val) - (if (->d-rest-ctc ->d-stct) + (if (base-->d-rest-ctc ->d-stct) (check-procedure/more val - (->d-mtd? ->d-stct) - (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (->d-mandatory-keywords ->d-stct) - (->d-optional-keywords ->d-stct) + (base-->d-mtd? ->d-stct) + (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length + (base-->d-mandatory-keywords ->d-stct) + (base-->d-optional-keywords ->d-stct) blame) (check-procedure val - (->d-mtd? ->d-stct) - (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length - (->d-mandatory-keywords ->d-stct) - (->d-optional-keywords ->d-stct) + (base-->d-mtd? ->d-stct) + (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length + (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length + (base-->d-mandatory-keywords ->d-stct) + (base-->d-optional-keywords ->d-stct) blame)) - (let ([kwd-proc - (λ (kwd-args kwd-arg-vals . raw-orig-args) - (let* ([orig-args (if (->d-mtd? ->d-stct) - (cdr raw-orig-args) - raw-orig-args)] - [this (and (->d-mtd? ->d-stct) (car raw-orig-args))] - [dep-pre-args - (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct) - (->d-keywords ->d-stct) kwd-args kwd-arg-vals)] - [thunk - (λ () - (keyword-apply - val - kwd-args - - ;; contracted keyword arguments - (let loop ([all-kwds (->d-keywords ->d-stct)] - [kwd-ctcs (->d-keyword-ctcs ->d-stct)] - [building-kwd-args kwd-args] - [building-kwd-arg-vals kwd-arg-vals]) - (cond - [(or (null? building-kwd-args) (null? all-kwds)) '()] - [else (if (eq? (car all-kwds) - (car building-kwd-args)) - (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame)) - (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) - (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))])) - - (append - ;; this parameter (if necc.) - (if (->d-mtd? ->d-stct) - (list (car raw-orig-args)) - '()) - - ;; contracted ordinary arguments - (let loop ([args orig-args] - [non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct) - (->d-optional-dom-ctcs ->d-stct))]) - (cond - [(null? args) - (if (->d-rest-ctc ->d-stct) - (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame)) - '())] - [(null? non-kwd-ctcs) - (if (->d-rest-ctc ->d-stct) - (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame)) - - ;; ran out of arguments, but don't have a rest parameter. - ;; procedure-reduce-arity (or whatever the new thing is - ;; going to be called) should ensure this doesn't happen. - (error 'shouldnt\ happen))] - [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame)) - (loop (cdr args) - (cdr non-kwd-ctcs)))])))))] - [rng (let ([rng (->d-range ->d-stct)]) + (wrap-procedure + val + (make-keyword-procedure + (λ (kwd-args kwd-arg-vals . raw-orig-args) + (let* ([orig-args (if (base-->d-mtd? ->d-stct) + (cdr raw-orig-args) + raw-orig-args)] + [this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))] + [dep-pre-args + (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (base-->d-rest-ctc ->d-stct) + (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) + (when (base-->d-pre-cond ->d-stct) + (unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args) + (raise-blame-error (blame-swap blame) + val + "#:pre violation~a" + (build-values-string ", argument" dep-pre-args)))) + (apply + values + + (append + + (let ([rng (let ([rng (base-->d-range ->d-stct)]) (cond [(not rng) #f] [(box? rng) (map (λ (val) (apply val dep-pre-args)) (unbox rng))] [else rng]))] - [rng-underscore? (box? (->d-range ->d-stct))]) - (when (->d-pre-cond ->d-stct) - (unless (apply (->d-pre-cond ->d-stct) dep-pre-args) - (raise-blame-error (blame-swap blame) - val - "#:pre violation~a" - (build-values-string ", argument" dep-pre-args)))) - (call-with-immediate-continuation-mark - ->d-tail-key - (λ (first-mark) - (cond - [(and rng - (not (and first-mark - (eq? this->d-id (car first-mark)) - (andmap eq? raw-orig-args (cdr first-mark))))) - (call-with-values - (λ () - (with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args) - (thunk))) - (λ orig-results - (let* ([range-count (length rng)] - [post-args (append orig-results raw-orig-args)] - [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] - [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count - post-args (->d-rest-ctc ->d-stct) - (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) - (when (->d-post-cond ->d-stct) - (unless (apply (->d-post-cond ->d-stct) dep-post-args) + [rng-underscore? (box? (base-->d-range ->d-stct))]) + (if rng + (list (λ orig-results + (let* ([range-count (length rng)] + [post-args (append orig-results raw-orig-args)] + [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] + [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count + post-args (base-->d-rest-ctc ->d-stct) + (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) + (when (base-->d-post-cond ->d-stct) + (unless (apply (base-->d-post-cond ->d-stct) dep-post-args) + (raise-blame-error blame + val + "#:post violation~a~a" + (build-values-string ", argument" dep-pre-args) + (build-values-string (if (null? dep-pre-args) + ", result" + "\n result") + orig-results)))) + + (unless (= range-count (length orig-results)) (raise-blame-error blame val - "#:post violation~a~a" - (build-values-string ", argument" dep-pre-args) - (build-values-string (if (null? dep-pre-args) - ", result" - "\n result") - orig-results)))) - - (unless (= range-count (length orig-results)) - (raise-blame-error blame - val - "expected ~a results, got ~a" - range-count - (length orig-results))) - (apply - values - (let loop ([results orig-results] - [result-contracts rng]) + "expected ~a results, got ~a" + range-count + (length orig-results))) + (apply + values + (let loop ([results orig-results] + [result-contracts rng]) + (cond + [(null? result-contracts) '()] + [else + (cons + (invoke-dep-ctc (car result-contracts) + (if rng-underscore? #f dep-post-args) + (car results) + blame) + (loop (cdr results) (cdr result-contracts)))])))))) + null)) + + ;; contracted keyword arguments + (let ([kwd-res (let loop ([all-kwds (base-->d-keywords ->d-stct)] + [kwd-ctcs (base-->d-keyword-ctcs ->d-stct)] + [building-kwd-args kwd-args] + [building-kwd-arg-vals kwd-arg-vals]) (cond - [(null? result-contracts) '()] - [else - (cons - (invoke-dep-ctc (car result-contracts) - (if rng-underscore? #f dep-post-args) - (car results) - blame) - (loop (cdr results) (cdr result-contracts)))]))))))] - [else - (thunk)])))))]) - (make-contracted-function - (procedure-reduce-keyword-arity - (make-keyword-procedure kwd-proc - ((->d-name-wrapper ->d-stct) - (λ args - (apply kwd-proc '() '() args)))) - - arity - (->d-mandatory-keywords ->d-stct) - (->d-keywords ->d-stct)) - ->d-stct))))))) + [(or (null? building-kwd-args) (null? all-kwds)) '()] + [else (if (eq? (car all-kwds) + (car building-kwd-args)) + (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame)) + (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) + (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))]) + (if (null? kwd-res) null (list kwd-res))) + + + ;; this parameter (if necc.) + (if (base-->d-mtd? ->d-stct) + (list (car raw-orig-args)) + '()) + + ;; contracted ordinary arguments + (let loop ([args orig-args] + [non-kwd-ctcs (append (base-->d-mandatory-dom-ctcs ->d-stct) + (base-->d-optional-dom-ctcs ->d-stct))]) + (cond + [(null? args) + (if (base-->d-rest-ctc ->d-stct) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame)) + '())] + [(null? non-kwd-ctcs) + (if (base-->d-rest-ctc ->d-stct) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame)) + + ;; ran out of arguments, but don't have a rest parameter. + ;; procedure-reduce-arity (or whatever the new thing is + ;; going to be called) should ensure this doesn't happen. + (error 'shouldnt\ happen))] + [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame)) + (loop (cdr args) + (cdr non-kwd-ctcs)))]))))))) + proxy-prop:contracted ->d-stct)))))) (define (build-values-string desc dep-pre-args) (cond @@ -1396,14 +1377,73 @@ v4 todo: (append mandatory-kwds optional-kwds) (append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs)) (λ (x y) (keywordd mtd? - mandatory-dom-ctcs optional-dom-ctcs - (map cdr kwd/ctc-pairs) - rest-ctc pre-cond range post-cond - (map car kwd/ctc-pairs) - mandatory-kwds - optional-kwds - name-wrapper))) + (make-proxy-->d mtd? + mandatory-dom-ctcs optional-dom-ctcs + (map cdr kwd/ctc-pairs) + rest-ctc pre-cond range post-cond + (map car kwd/ctc-pairs) + mandatory-kwds + optional-kwds + name-wrapper))) + +(define (->d-name ctc) + (let* ([counting-id 'x] + [ids '(x y z w)] + [next-id + (λ () + (cond + [(pair? ids) + (begin0 (car ids) + (set! ids (cdr ids)))] + [(null? ids) + (begin0 + (string->symbol (format "~a0" counting-id)) + (set! ids 1))] + [else + (begin0 + (string->symbol (format "~a~a" counting-id ids)) + (set! ids (+ ids 1)))]))]) + `(->d (,@(map (λ (x) `(,(next-id) ...)) (base-->d-mandatory-dom-ctcs ctc)) + ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (base-->d-mandatory-keywords ctc)))) + (,@(map (λ (x) `(,(next-id) ...)) (base-->d-optional-dom-ctcs ctc)) + ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (base-->d-optional-keywords ctc)))) + ,@(if (base-->d-rest-ctc ctc) + (list '#:rest (next-id) '...) + '()) + ,@(if (base-->d-pre-cond ctc) + (list '#:pre '...) + (list)) + ,(let ([range (base-->d-range ctc)]) + (cond + [(not range) 'any] + [(box? range) + (let ([range (unbox range)]) + (cond + [(and (not (null? range)) + (null? (cdr range))) + `[_ ...]] + [else + `(values ,@(map (λ (x) `(_ ...)) range))]))] + [(and (not (null? range)) + (null? (cdr range))) + `[,(next-id) ...]] + [else + `(values ,@(map (λ (x) `(,(next-id) ...)) range))])) + ,@(if (base-->d-post-cond ctc) + (list '#:post '...) + (list))))) + +(define (->d-first-order ctc) + (let* ([mtd? (base-->d-mtd? ctc)] + [dom-length (length (base-->d-mandatory-dom-ctcs ctc))] + [optionals (length (base-->d-optional-dom-ctcs ctc))] + [mandatory-kwds (base-->d-mandatory-keywords ctc)] + [optional-kwds (base-->d-optional-keywords ctc)]) + (λ (val) + (if (base-->d-rest-ctc ctc) + (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f) + (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f))))) +(define (->d-stronger? this that) (eq? this that)) ;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that ;; is under the contract, and "dr???" refers to the arguments & the results of the function that @@ -1411,84 +1451,33 @@ v4 todo: ;; the `box' in the range only serves to differentiate between range contracts that depend on ;; both the domain and the range from those that depend only on the domain (and thus, those ;; that can be applied early) -(define-struct ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes. - mandatory-dom-ctcs ;; (listof (-> d??? ctc)) - optional-dom-ctcs ;; (listof (-> d??? ctc)) - keyword-ctcs ;; (listof (-> d??? ctc)) - rest-ctc ;; (or/c false/c (-> d??? ctc)) - pre-cond ;; (-> d??? boolean) - range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc)))) - post-cond ;; (-> dr??? boolean) - keywords ;; (listof keywords) -- sorted by keyword< - mandatory-keywords ;; (listof keywords) -- sorted by keyword< - optional-keywords ;; (listof keywords) -- sorted by keyword< - name-wrapper) ;; (-> proc proc) - - #:omit-define-syntaxes +(define-struct base-->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes. + mandatory-dom-ctcs ;; (listof (-> d??? ctc)) + optional-dom-ctcs ;; (listof (-> d??? ctc)) + keyword-ctcs ;; (listof (-> d??? ctc)) + rest-ctc ;; (or/c false/c (-> d??? ctc)) + pre-cond ;; (-> d??? boolean) + range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc)))) + post-cond ;; (-> dr??? boolean) + keywords ;; (listof keywords) -- sorted by keyword< + mandatory-keywords ;; (listof keywords) -- sorted by keyword< + optional-keywords ;; (listof keywords) -- sorted by keyword< + name-wrapper)) ;; (-> proc proc) +;; Factored out in case there are ever chaperone ->d contracts. +;; However, to do that, you'd either a) have to somehow check +;; that the subcontracts are chaperones or b) allow contract +;; application-time failures if the subpieces did not convert +;; appropriately. b) might be okay, but we should think about +;; it first. At the very least, the projection function would +;; need to add checks in the appropriate places. +(define-struct (proxy-->d base-->d) () #:property prop:contract (build-contract-property - #:projection ->d-proj - #:name - (λ (ctc) - (let* ([counting-id 'x] - [ids '(x y z w)] - [next-id - (λ () - (cond - [(pair? ids) - (begin0 (car ids) - (set! ids (cdr ids)))] - [(null? ids) - (begin0 - (string->symbol (format "~a0" counting-id)) - (set! ids 1))] - [else - (begin0 - (string->symbol (format "~a~a" counting-id ids)) - (set! ids (+ ids 1)))]))]) - `(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc)) - ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc)))) - (,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc)) - ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc)))) - ,@(if (->d-rest-ctc ctc) - (list '#:rest (next-id) '...) - '()) - ,@(if (->d-pre-cond ctc) - (list '#:pre '...) - (list)) - ,(let ([range (->d-range ctc)]) - (cond - [(not range) 'any] - [(box? range) - (let ([range (unbox range)]) - (cond - [(and (not (null? range)) - (null? (cdr range))) - `[_ ...]] - [else - `(values ,@(map (λ (x) `(_ ...)) range))]))] - [(and (not (null? range)) - (null? (cdr range))) - `[,(next-id) ...]] - [else - `(values ,@(map (λ (x) `(,(next-id) ...)) range))])) - ,@(if (->d-post-cond ctc) - (list '#:post '...) - (list))))) - - #:first-order (λ (ctc) - (λ (val) - (let* ([mtd? (->d-mtd? ctc)] - [dom-length (length (->d-mandatory-dom-ctcs ctc))] - [optionals (length (->d-optional-dom-ctcs ctc))] - [mandatory-kwds (->d-mandatory-keywords ctc)] - [optional-kwds (->d-optional-keywords ctc)]) - (if (->d-rest-ctc ctc) - (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f) - (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f))))) - #:stronger (λ (this that) (eq? this that)))) - + #:projection (->d-proj proxy-procedure) + #:name ->d-name + #:first-order ->d-first-order + #:stronger ->d-stronger?)) ; ; diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 0c9fc2ad95..f6746f065b 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -9828,98 +9828,6 @@ so that propagation occurs. (c))) - ;; this one is not tail recursive, since the contract system - ;; cannot tell that the range contract doesn't depend on 'arg' - (ctest 8 - 'tail-arrow-d1/changing-args - (let ([c (counter)]) - (letrec ([f - (contract (->d ([arg any/c]) () (values [_ c] [_ c])) - (λ (x) (if (zero? x) (values x x) (f (- x 1)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - (ctest 2 - 'tail-arrow-d1 - (let ([c (counter)]) - (letrec ([x 5] - [f - (contract (->d ([arg any/c]) () (values [_ c] [_ c])) - (λ (_ignored) (if (zero? x) (values x x) (begin (set! x (- x 1)) (f _ignored)))) - 'pos - 'neg)]) - (f 'ignored)) - (c))) - - - ;; this one is just like the one two above. - (ctest 4 - 'tail-arrow-d2/changing-args - (let ([c (counter)]) - (letrec ([f - (contract (->d ([arg any/c]) () [rng c]) - (λ (x) (if (zero? x) x (f (- x 1)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - (ctest 1 - 'tail-arrow-d2 - (let ([c (counter)]) - (letrec ([x 3] - [f - (contract (->d ([arg any/c]) () [rng c]) - (λ (ignored) (if (zero? x) x (begin (set! x (- x 1)) (f ignored)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - ;; the tail-call optimization cannot handle two different - ;; contracts on the stack one after the other one, so this - ;; returns '(4 4) instead of '(1 1) (which would indicate - ;; the optimization had happened). - (ctest '(4 4) - 'tail->d-mut-rec - (letrec ([odd-count 0] - [pos-count 0] - [count-odd? - (λ (x) - (set! odd-count (+ odd-count 1)) - (odd? x))] - [count-positive? - (λ (x) - (set! pos-count (+ pos-count 1)) - (positive? x))] - [returns-odd - (contract (->d ([x any/c]) () [_ count-odd?]) - (λ (x) (returns-pos x)) - 'pos - 'neg)] - [returns-pos - (contract (->d ([x any/c]) () [_ count-positive?]) - (λ (x) (if (zero? x) 1 (returns-odd (- x 1)))) - 'pos - 'neg)]) - (returns-odd 3) - (list odd-count pos-count))) - - ;; this one is not tail recursive, since the contract system - ;; cannot tell that the range contract doesn't depend on 'arg' - (ctest 8 - 'tail-arrow-d1/changing-args - (let ([c (counter)]) - (letrec ([f - (contract (->i ([arg any/c]) () (values [_ (arg) c] [_ (arg) c])) - (λ (x) (if (zero? x) (values x x) (f (- x 1)))) - 'pos - 'neg)]) - (f 3)) - (c))) - (ctest 1 'case->-regular (let ([c (counter)])