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)
This commit is contained in:
Robby Findler
parent
d4fa2766c2
commit
d710550f0a
|
|
@ -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
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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 (<contract-combinator> 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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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)]
|
||||
[_
|
||||
(cond
|
||||
[call-opt/unknown?
|
||||
(opt/unknown opt/i opt/info stx)]
|
||||
[else
|
||||
(opt/unknown opt/i opt/info stx)]))
|
||||
(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,7 +225,8 @@
|
|||
|
||||
(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))
|
||||
(define an-optres (opt/i info exp #:call-opt/unknown? #f))
|
||||
(if an-optres
|
||||
(bind-superlifts
|
||||
(optres-superlifts an-optres)
|
||||
(bind-lifts
|
||||
|
|
@ -197,7 +241,8 @@
|
|||
(λ (this that) #f)
|
||||
(vector)
|
||||
(begin-lifted (box #f))
|
||||
#,(optres-chaperone an-optres))))))
|
||||
#,(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'.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user