From d710550f0a8aee04eb2a7107f232e40b6e2b8bcc Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 10 Apr 2013 14:47:51 -0500 Subject: [PATCH] make opt/c use a more comprehensive list of known-to-be-good predicate contracts also make it just evaporate when the contract is unknown (instead of leaving a wrapper behind around the contract) --- .../racket/contract/private/basic-opters.rkt | 29 ------ collects/racket/contract/private/helpers.rkt | 4 +- collects/racket/contract/private/opt-guts.rkt | 20 ++-- collects/racket/contract/private/opt.rkt | 91 ++++++++++++++----- 4 files changed, 83 insertions(+), 61 deletions(-) diff --git a/collects/racket/contract/private/basic-opters.rkt b/collects/racket/contract/private/basic-opters.rkt index 379c783f60..cb525cf38e 100644 --- a/collects/racket/contract/private/basic-opters.rkt +++ b/collects/racket/contract/private/basic-opters.rkt @@ -7,35 +7,6 @@ (require (for-syntax racket/base "opt-guts.rkt")) -;; -;; opt/pred helper -;; -(define-for-syntax (opt/pred opt/info pred #:name [name (syntax-e pred)]) - (with-syntax ((pred pred)) - (build-optres - #:exp - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (blame (opt/info-blame opt/info))) - (syntax (if (pred val) - val - (raise-opt/pred-error blame val 'pred)))) - #:lifts null - #:superlifts null - #:partials null - #:flat (syntax (pred val)) - #:opt #f - #:stronger-ribs null - #:chaperone #t - #:name #`'#,name))) - -(define (raise-opt/pred-error blame val pred-name) - (raise-blame-error - blame - val - '(expected: "~a") - pred-name)) - ;; ;; built-in predicate opters ;; diff --git a/collects/racket/contract/private/helpers.rkt b/collects/racket/contract/private/helpers.rkt index dfdcd5ee6f..8319450281 100644 --- a/collects/racket/contract/private/helpers.rkt +++ b/collects/racket/contract/private/helpers.rkt @@ -164,6 +164,8 @@ #| ;; the code below builds the known-good-syms-ht +;; it should contain only predicates or else +;; opt/c will misbehave (define cm (parameterize ([read-accept-compiled #t]) @@ -366,5 +368,5 @@ (define (known-good-contract? id) (define r-id (syntax-e id)) (and (symbol? r-id) - (hash-ref known-good-syms-ht (syntax-e id) #t) + (hash-ref known-good-syms-ht r-id #f) (free-identifier=? id (datum->syntax #'here r-id)))) diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt index 674de51604..54f93eba56 100644 --- a/collects/racket/contract/private/opt-guts.rkt +++ b/collects/racket/contract/private/opt-guts.rkt @@ -38,7 +38,8 @@ build-optres combine-two-chaperone?s - combine-two-no-negative-blame) + combine-two-no-negative-blame + log-unknown-contract-warning) ;; (define/opter ( opt/i opt/info stx) body) ;; @@ -248,13 +249,7 @@ ;; opt/unknown : opt/i id id syntax ;; (define (opt/unknown opt/i opt/info uctc [extra-warning ""]) - (log-warning (string-append (format "warning in ~a:~a: opt/c doesn't know the contract ~s" - (syntax-source uctc) - (if (syntax-line uctc) - (format "~a:~a" (syntax-line uctc) (syntax-column uctc)) - (format ":~a" (syntax-position uctc))) - (syntax->datum uctc)) - extra-warning)) + (log-unknown-contract-warning uctc extra-warning) (with-syntax ([(lift-var partial-var partial-flat-var) (generate-temporaries '(lift partial partial-flat))] [val (opt/info-val opt/info)] @@ -282,6 +277,15 @@ #:chaperone #'(chaperone-contract? lift-var) #:name #'(contract-name lift-var)))) +(define (log-unknown-contract-warning exp [extra-warning ""]) + (log-warning (string-append (format "warning in ~a:~a: opt/c doesn't know the contract ~s" + (syntax-source exp) + (if (syntax-line exp) + (format "~a:~a" (syntax-line exp) (syntax-column exp)) + (format ":~a" (syntax-position exp))) + (syntax->datum exp)) + extra-warning))) + (define opt-error-name (make-parameter 'opt/c)) diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt index 6f147d69c0..a6a070ce46 100644 --- a/collects/racket/contract/private/opt.rkt +++ b/collects/racket/contract/private/opt.rkt @@ -2,15 +2,18 @@ (require "prop.rkt" "misc.rkt" "blame.rkt" + "guts.rkt" racket/stxparam) -(require (for-syntax racket/base) - (for-syntax "opt-guts.rkt") - (for-syntax racket/stxparam)) +(require (for-syntax racket/base + "helpers.rkt" + "opt-guts.rkt" + racket/stxparam)) (provide opt/c define-opt/c define/opter - opt/direct + opt/direct begin-lifted (for-syntax + opt/pred define-opt/recursive-fn? define-opt/recursive-fn-neg-blame?-id)) @@ -106,7 +109,8 @@ ;; 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) +;; if call-opt/unknown is #f, then this may just return #f instead of an optres +(define-for-syntax (opt/i opt/info stx #:call-opt/unknown? [call-opt/unknown? #t]) ;; the case dispatch here must match what top-level-unknown? is doing (syntax-case stx () [(ctc arg ...) @@ -115,6 +119,9 @@ [argless-ctc (and (identifier? #'argless-ctc) (opter #'argless-ctc)) ((opter #'argless-ctc) opt/i opt/info stx)] + [predicate? + (and (identifier? #'predicate?) (known-good-contract? #'predicate?)) + (opt/pred opt/info #'predicate?)] [(f arg ...) (and (identifier? #'f) (define-opt/recursive-fn? (syntax-local-value #'f (λ () #f)))) @@ -143,8 +150,13 @@ [konst (coerecable-constant? #'konst) (opt-constant-contract (syntax->datum #'konst) opt/info)] - [else - (opt/unknown opt/i opt/info stx)])) + [_ + (cond + [call-opt/unknown? + (opt/unknown opt/i opt/info stx)] + [else + (log-unknown-contract-warning stx) + #f])])) ;; top-level-unknown? : syntax -> boolean ;; this must match what opt/i is doing @@ -156,6 +168,9 @@ [argless-ctc (and (identifier? #'argless-ctc) (opter #'argless-ctc)) #f] + [predicate? + (and (identifier? #'predicate?) (known-good-contract? #'predicate?)) + #f] [konst (coerecable-constant? #'konst) #f] @@ -166,6 +181,34 @@ [else #t])) +(define-for-syntax (opt/pred opt/info pred #:name [name (syntax-e pred)]) + (with-syntax ((pred pred)) + (build-optres + #:exp + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (blame (opt/info-blame opt/info))) + (syntax (if (pred val) + val + (raise-opt/pred-error blame val 'pred)))) + #:lifts null + #:superlifts null + #:partials null + #:flat (syntax (pred val)) + #:opt #f + #:stronger-ribs null + #:chaperone #t + #:name #`'#,name))) + +(define (raise-opt/pred-error blame val pred-name) + (raise-blame-error + blame + val + '(expected: "~a") + pred-name)) + + + ;; 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 @@ -182,22 +225,24 @@ (parameterize ([opt-error-name error-name-sym]) (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that)) - (define an-optres (opt/i info exp)) - (bind-superlifts - (optres-superlifts an-optres) - (bind-lifts - (optres-lifts an-optres) - #`(make-opt-contract - (λ (ctc) - (λ (blame) - #,(bind-superlifts - (optres-partials an-optres) - #`(λ (val) #,(optres-exp an-optres))))) - #,(optres-name an-optres) - (λ (this that) #f) - (vector) - (begin-lifted (box #f)) - #,(optres-chaperone an-optres)))))) + (define an-optres (opt/i info exp #:call-opt/unknown? #f)) + (if an-optres + (bind-superlifts + (optres-superlifts an-optres) + (bind-lifts + (optres-lifts an-optres) + #`(make-opt-contract + (λ (ctc) + (λ (blame) + #,(bind-superlifts + (optres-partials an-optres) + #`(λ (val) #,(optres-exp an-optres))))) + #,(optres-name an-optres) + (λ (this that) #f) + (vector) + (begin-lifted (box #f)) + #,(optres-chaperone an-optres)))) + #`(coerce-contract '#,error-name-sym #,exp)))) ;; this macro optimizes 'e' as a contract, ;; using otherwise-id if it does not recognize 'e'.