Memoize static contracts and resulting contracts
This commit uses memoization not just for Name types but for static contracts for all types. It also adjusts how Name contracts are generated to increase sharing across multiple type->contract calls. original commit: 18c1f095fcf47e0b935819ecb0c3f2b7a3e7fec1
This commit is contained in:
Asumu Takikawa
parent
23d7797c26
commit
165240384b
|
|
@ -64,61 +64,75 @@
|
|||
(if reason (~a ": " reason) "."))
|
||||
to-check))
|
||||
|
||||
(define (generate-contract-def stx)
|
||||
;; The cache/sc-cache are used to share contract and static contract
|
||||
;; definitions respectively across multiple calls to type->contract.
|
||||
;; This saves computation time and zo space for excessively large types
|
||||
;; (such as mutually recursive class types).
|
||||
(define (generate-contract-def stx cache sc-cache)
|
||||
(define prop (get-contract-def-property stx))
|
||||
(match-define (contract-def type-stx flat? maker? typed-side) prop)
|
||||
(define typ (parse-type type-stx))
|
||||
(define *typ (parse-type type-stx))
|
||||
(define kind (if flat? 'flat 'impersonator))
|
||||
(syntax-parse stx #:literals (define-values)
|
||||
[(define-values (n) _)
|
||||
(let ([typ (if maker?
|
||||
((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ)
|
||||
typ)])
|
||||
(with-syntax ([cnt (type->contract
|
||||
typ
|
||||
;; this value is from the typed side (require/typed, make-predicate, etc)
|
||||
;; unless it's used for with-type
|
||||
#:typed-side (from-typed? typed-side)
|
||||
#:kind kind
|
||||
(type->contract-fail
|
||||
typ type-stx
|
||||
#:ctc-str (if flat? "predicate" "contract")))])
|
||||
(ignore ; should be ignored by the optimizer
|
||||
(quasisyntax/loc stx (define-values (n) cnt)))))]
|
||||
(define typ
|
||||
(if maker?
|
||||
((map fld-t (Struct-flds (lookup-type-name (Name-id *typ)))) #f . t:->* . *typ)
|
||||
*typ))
|
||||
(match-define (list defs ctc)
|
||||
(type->contract
|
||||
typ
|
||||
;; this value is from the typed side (require/typed, make-predicate, etc)
|
||||
;; unless it's used for with-type
|
||||
#:typed-side (from-typed? typed-side)
|
||||
#:kind kind
|
||||
#:cache cache
|
||||
#:sc-cache sc-cache
|
||||
(type->contract-fail
|
||||
typ type-stx
|
||||
#:ctc-str (if flat? "predicate" "contract"))))
|
||||
(ignore ; should be ignored by the optimizer
|
||||
(quasisyntax/loc stx
|
||||
(begin #,@defs (define-values (n) #,ctc))))]
|
||||
[_ (int-err "should never happen - not a define-values: ~a"
|
||||
(syntax->datum stx))]))
|
||||
|
||||
;; Generate a contract for a TR provide form
|
||||
(define (generate-contract-def/provide stx)
|
||||
(define (generate-contract-def/provide stx cache sc-cache)
|
||||
(match-define (list type untyped-id orig-id blame-id)
|
||||
(contract-def/provide-property stx))
|
||||
(define failure-reason #f)
|
||||
(define ctc
|
||||
(define result
|
||||
(type->contract type
|
||||
#:typed-side #t
|
||||
#:kind 'impersonator
|
||||
#:cache cache
|
||||
#:sc-cache sc-cache
|
||||
;; FIXME: get rid of this interface, make it functional
|
||||
(λ (#:reason [reason #f]) (set! failure-reason reason))))
|
||||
(syntax-parse stx
|
||||
#:literal-sets (kernel-literals)
|
||||
[(define-values ctc-id _)
|
||||
;; no need for ignore, the optimizer doesn't run on this code
|
||||
(if failure-reason
|
||||
#`(define-syntax (#,untyped-id stx)
|
||||
(tc-error/fields #:stx stx
|
||||
"could not convert type to a contract"
|
||||
#:more #,failure-reason
|
||||
"identifier" #,(symbol->string (syntax-e orig-id))
|
||||
"type" #,(pretty-format-type type #:indent 8)))
|
||||
#`(begin (define ctc-id #,ctc)
|
||||
(define-module-boundary-contract #,untyped-id
|
||||
#,orig-id ctc-id
|
||||
#:pos-source #,blame-id
|
||||
#:srcloc (vector (quote #,(syntax-source orig-id))
|
||||
#,(syntax-line orig-id)
|
||||
#,(syntax-column orig-id)
|
||||
#,(syntax-position orig-id)
|
||||
#,(syntax-span orig-id)))))]))
|
||||
(cond [failure-reason
|
||||
#`(define-syntax (#,untyped-id stx)
|
||||
(tc-error/fields #:stx stx
|
||||
"could not convert type to a contract"
|
||||
#:more #,failure-reason
|
||||
"identifier" #,(symbol->string (syntax-e orig-id))
|
||||
"type" #,(pretty-format-type type #:indent 8)))]
|
||||
[else
|
||||
(match-define (list defs ctc) result)
|
||||
#`(begin #,@defs
|
||||
(define ctc-id #,ctc)
|
||||
(define-module-boundary-contract #,untyped-id
|
||||
#,orig-id ctc-id
|
||||
#:pos-source #,blame-id
|
||||
#:srcloc (vector (quote #,(syntax-source orig-id))
|
||||
#,(syntax-line orig-id)
|
||||
#,(syntax-column orig-id)
|
||||
#,(syntax-position orig-id)
|
||||
#,(syntax-span orig-id))))])]))
|
||||
|
||||
(define extra-requires
|
||||
#'(require
|
||||
|
|
@ -135,18 +149,24 @@
|
|||
(define include-extra-requires? (box #f))
|
||||
|
||||
(define (change-contract-fixups forms)
|
||||
(for/list ((e (in-list forms)))
|
||||
(if (not (get-contract-def-property e))
|
||||
e
|
||||
(begin (set-box! include-extra-requires? #t)
|
||||
(generate-contract-def e)))))
|
||||
(define ctc-cache (make-hash))
|
||||
(define sc-cache (make-hash))
|
||||
(with-new-name-tables
|
||||
(for/list ((e (in-list forms)))
|
||||
(if (not (get-contract-def-property e))
|
||||
e
|
||||
(begin (set-box! include-extra-requires? #t)
|
||||
(generate-contract-def e ctc-cache sc-cache))))))
|
||||
|
||||
(define (change-provide-fixups forms)
|
||||
(for/list ([form (in-list forms)])
|
||||
(cond [(contract-def/provide-property form)
|
||||
(set-box! include-extra-requires? #t)
|
||||
(generate-contract-def/provide form)]
|
||||
[else form])))
|
||||
(define ctc-cache (make-hash))
|
||||
(define sc-cache (make-hash))
|
||||
(with-new-name-tables
|
||||
(for/list ([form (in-list forms)])
|
||||
(cond [(contract-def/provide-property form)
|
||||
(set-box! include-extra-requires? #t)
|
||||
(generate-contract-def/provide form ctc-cache sc-cache)]
|
||||
[else form]))))
|
||||
|
||||
;; To avoid misspellings
|
||||
(define impersonator-sym 'impersonator)
|
||||
|
|
@ -195,17 +215,25 @@
|
|||
[(untyped) 'typed]
|
||||
[(both) 'both]))
|
||||
|
||||
(define (type->contract ty init-fail #:typed-side [typed-side #t] #:kind [kind 'impersonator])
|
||||
(with-new-name-tables
|
||||
(let/ec escape
|
||||
(define (fail #:reason [reason #f]) (escape (init-fail #:reason reason)))
|
||||
(instantiate
|
||||
(optimize
|
||||
(type->static-contract ty #:typed-side typed-side fail)
|
||||
#:trusted-positive typed-side
|
||||
#:trusted-negative (not typed-side))
|
||||
fail
|
||||
kind))))
|
||||
;; type->contract : Type Procedure
|
||||
;; #:typed-side Boolean #:kind Symbol #:cache Hash
|
||||
;; -> (U Any (List (Listof Syntax) Syntax))
|
||||
(define (type->contract ty init-fail
|
||||
#:typed-side [typed-side #t]
|
||||
#:kind [kind 'impersonator]
|
||||
#:cache [cache (make-hash)]
|
||||
#:sc-cache [sc-cache (make-hash)])
|
||||
(let/ec escape
|
||||
(define (fail #:reason [reason #f]) (escape (init-fail #:reason reason)))
|
||||
(instantiate
|
||||
(optimize
|
||||
(type->static-contract ty #:typed-side typed-side fail
|
||||
#:cache sc-cache)
|
||||
#:trusted-positive typed-side
|
||||
#:trusted-negative (not typed-side))
|
||||
fail
|
||||
kind
|
||||
#:cache cache)))
|
||||
|
||||
|
||||
|
||||
|
|
@ -224,8 +252,33 @@
|
|||
(define (same sc)
|
||||
(triple sc sc sc))
|
||||
|
||||
;; Keep track of the bound names and don't cache types where those are free
|
||||
(define bound-names (make-parameter null))
|
||||
|
||||
(define (type->static-contract type init-fail #:typed-side [typed-side #t])
|
||||
;; Macro to simplify (and avoid reindentation) of the match below
|
||||
;;
|
||||
;; The sc-cache hashtable is used to memoize static contracts. The keys are
|
||||
;; a pair of the Type-seq number for a type and 'untyped or 'typed
|
||||
(define-syntax (cached-match stx)
|
||||
(syntax-case stx ()
|
||||
[(_ sc-cache type-expr typed-side-expr match-clause ...)
|
||||
#'(let ([type type-expr]
|
||||
[typed-side typed-side-expr])
|
||||
(define key (cons (Type-seq type) typed-side))
|
||||
(cond [(hash-ref sc-cache key #f)]
|
||||
[else
|
||||
(define sc (match type match-clause ...))
|
||||
(define fvs (fv type))
|
||||
(unless (or (ormap (λ (n) (member n fvs)) (bound-names))
|
||||
;; Don't cache types with applications of Name types because
|
||||
;; it does the wrong thing for recursive references
|
||||
(has-name-app? type))
|
||||
(hash-set! sc-cache key sc))
|
||||
sc]))]))
|
||||
|
||||
(define (type->static-contract type init-fail
|
||||
#:typed-side [typed-side #t]
|
||||
#:cache [sc-cache (make-hash)])
|
||||
(let/ec return
|
||||
(define (fail #:reason reason) (return (init-fail #:reason reason)))
|
||||
(let loop ([type type] [typed-side (if typed-side 'typed 'untyped)] [recursive-values (hash)])
|
||||
|
|
@ -242,13 +295,13 @@
|
|||
(if (from-typed? typed-side)
|
||||
(fail #:reason "contract generation not supported for this type")
|
||||
sc))
|
||||
(match type
|
||||
(cached-match sc-cache type typed-side
|
||||
;; Applications of implicit recursive type aliases
|
||||
;;
|
||||
;; We special case this rather than just resorting to standard
|
||||
;; App resolution (see case below) because the resolution process
|
||||
;; will make type->static-contract infinite loop.
|
||||
[(App: (Name: name _ #f) rands _)
|
||||
[(App: (Name: name _ #f) _ _)
|
||||
;; Key with (cons name 'app) instead of just name because the
|
||||
;; application of the Name is not necessarily the same as the
|
||||
;; Name type alone
|
||||
|
|
@ -352,8 +405,9 @@
|
|||
(define rv (for/fold ((rv recursive-values)) ((temp temporaries)
|
||||
(v-nm vs-nm))
|
||||
(hash-set rv v-nm (same (parametric-var/sc temp)))))
|
||||
(parametric->/sc temporaries
|
||||
(t->sc b #:recursive-values rv)))))]
|
||||
(parameterize ([bound-names (append (bound-names) vs-nm)])
|
||||
(parametric->/sc temporaries
|
||||
(t->sc b #:recursive-values rv))))))]
|
||||
[(PolyDots: (list vs ... dotted-v) b)
|
||||
(if (not (from-untyped? typed-side))
|
||||
;; in positive position, no checking needed for the variables
|
||||
|
|
@ -373,13 +427,17 @@
|
|||
(case typed-side
|
||||
[(both) (recursive-sc
|
||||
(list both-n*)
|
||||
(list (loop b 'both rv))
|
||||
(parameterize ([bound-names (cons n (bound-names))])
|
||||
(list (loop b 'both rv)))
|
||||
(recursive-sc-use both-n*))]
|
||||
[(typed untyped)
|
||||
(define (rec b side rv)
|
||||
(parameterize ([bound-names (cons n (bound-names))])
|
||||
(loop b side rv)))
|
||||
;; TODO not fail in cases that don't get used
|
||||
(define untyped (loop b 'untyped rv))
|
||||
(define typed (loop b 'typed rv))
|
||||
(define both (loop b 'both rv))
|
||||
(define untyped (rec b 'untyped rv))
|
||||
(define typed (rec b 'typed rv))
|
||||
(define both (rec b 'both rv))
|
||||
|
||||
(recursive-sc
|
||||
n*s
|
||||
|
|
@ -541,6 +599,20 @@
|
|||
((f #f) (first arrs))
|
||||
(case->/sc (map (f #t) arrs)))])]))
|
||||
|
||||
;; Predicate that checks for an App type with a recursive
|
||||
;; Name type in application position
|
||||
(define (has-name-app? type)
|
||||
(let/ec escape
|
||||
(let loop ([type type])
|
||||
(type-case
|
||||
(#:Type loop #:Filter (sub-f loop) #:Object (sub-o loop))
|
||||
type
|
||||
[#:App arg _ _
|
||||
(match arg
|
||||
[(Name: _ _ #f) (escape #t)]
|
||||
[_ type])]))
|
||||
#f))
|
||||
|
||||
(module predicates racket/base
|
||||
(require racket/extflonum)
|
||||
(provide nonnegative? nonpositive?
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
(display "#<any/sc>" port)))
|
||||
|
||||
(struct any-combinator combinator ()
|
||||
#:transparent
|
||||
#:methods gen:sc
|
||||
[(define (sc-map v f) v)
|
||||
(define (sc-traverse v f) (void))
|
||||
|
|
|
|||
|
|
@ -18,7 +18,8 @@
|
|||
(maybe/c (listof static-contract?))
|
||||
static-contract?)])
|
||||
case->/sc:
|
||||
arr/sc:)
|
||||
arr/sc:
|
||||
(rename-out [arr-combinator? arr/sc?]))
|
||||
|
||||
|
||||
(define (case->/sc arrs)
|
||||
|
|
|
|||
|
|
@ -13,10 +13,16 @@
|
|||
"../constraints.rkt"
|
||||
racket/contract
|
||||
racket/dict
|
||||
racket/match
|
||||
racket/syntax
|
||||
syntax/id-table)
|
||||
syntax/id-table
|
||||
(for-syntax racket/base
|
||||
syntax/parse))
|
||||
|
||||
(provide with-new-name-tables
|
||||
name/sc:
|
||||
lookup-name-defined
|
||||
set-name-defined
|
||||
(contract-out
|
||||
[get-all-name-defs
|
||||
(-> (listof (list/c (listof identifier?)
|
||||
|
|
@ -33,9 +39,22 @@
|
|||
(define name-sc-table (make-parameter (make-free-id-table)))
|
||||
(define name-defs-table (make-parameter (make-free-id-table)))
|
||||
|
||||
;; Use this table to track whether a contract has already been
|
||||
;; generated for this name type yet. Stores booleans.
|
||||
(define name-defined-table (make-parameter (make-free-id-table)))
|
||||
|
||||
;; Lookup whether a contract has been defined for this name
|
||||
(define (lookup-name-defined name)
|
||||
(free-id-table-ref (name-defined-table) name #f))
|
||||
|
||||
;; Use when a contract has been defined for this name
|
||||
(define (set-name-defined name)
|
||||
(free-id-table-set! (name-defined-table) name #t))
|
||||
|
||||
(define-syntax-rule (with-new-name-tables e)
|
||||
(parameterize ([name-sc-table (make-free-id-table)]
|
||||
[name-defs-table (make-free-id-table)])
|
||||
[name-defs-table (make-free-id-table)]
|
||||
[name-defined-table (make-free-id-table)])
|
||||
e))
|
||||
|
||||
(define (get-all-name-defs)
|
||||
|
|
@ -81,3 +100,7 @@
|
|||
(name-combinator-gen-name v))
|
||||
(define (sc->constraints v f)
|
||||
(variable-contract-restrict (name-combinator-gen-name v)))])
|
||||
|
||||
(define-match-expander name/sc:
|
||||
(syntax-parser
|
||||
[(_ var) #'(name-combinator _ var)]))
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
(display "#<none/sc>" port)))
|
||||
|
||||
(struct none-combinator combinator ()
|
||||
#:transparent
|
||||
#:methods gen:sc
|
||||
[(define (sc-map v f) v)
|
||||
(define (sc-traverse v f) (void))
|
||||
|
|
|
|||
|
|
@ -18,7 +18,8 @@
|
|||
[parametric-var/sc (identifier? . -> . static-contract?)])
|
||||
parametric->/sc:
|
||||
(rename-out
|
||||
[parametric-var/sc parametric-var/sc:]))
|
||||
[parametric-var/sc parametric-var/sc:]
|
||||
[parametric-combinator? parametric->/sc?]))
|
||||
|
||||
|
||||
(struct parametric-combinator combinator (vars)
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@
|
|||
|
||||
|
||||
(struct simple-contract static-contract (syntax kind name)
|
||||
#:transparent
|
||||
#:methods gen:sc
|
||||
[(define (sc-map v f) v)
|
||||
(define (sc-traverse v f) (void))
|
||||
|
|
|
|||
|
|
@ -8,8 +8,12 @@
|
|||
racket/dict
|
||||
racket/sequence
|
||||
racket/contract
|
||||
racket/syntax
|
||||
(for-template racket/base racket/contract)
|
||||
"combinators.rkt"
|
||||
"combinators/name.rkt"
|
||||
"combinators/case-lambda.rkt"
|
||||
"combinators/parametric.rkt"
|
||||
"kinds.rkt"
|
||||
"parametric-check.rkt"
|
||||
"structures.rkt"
|
||||
|
|
@ -20,7 +24,8 @@
|
|||
(contract-out
|
||||
[instantiate
|
||||
(parametric->/c (a) ((static-contract? (-> #:reason (or/c #f string?) a))
|
||||
(contract-kind?) . ->* . (or/c a syntax?)))]))
|
||||
(contract-kind? #:cache hash?)
|
||||
. ->* . (or/c a (list/c (listof syntax?) syntax?))))]))
|
||||
|
||||
;; Providing these so that tests can work directly with them.
|
||||
(module* internals #f
|
||||
|
|
@ -30,23 +35,34 @@
|
|||
|
||||
;; kind is the greatest kind of contract that is supported, if a greater kind would be produced the
|
||||
;; fail procedure is called.
|
||||
(define (instantiate sc fail [kind 'impersonator])
|
||||
;;
|
||||
;; The cache is used to share contract definitions across multiple calls to
|
||||
;; type->contract in a given contract fixup pass. If it's #f then that means don't
|
||||
;; do any sharing (useful for testing).
|
||||
(define (instantiate sc fail [kind 'impersonator] #:cache [cache #f])
|
||||
(if (parametric-check sc)
|
||||
(fail #:reason "multiple parametric contracts are not supported")
|
||||
(with-handlers [(exn:fail:constraint-failure?
|
||||
(lambda (exn) (fail #:reason (exn:fail:constraint-failure-reason exn))))]
|
||||
(instantiate/inner sc
|
||||
(compute-recursive-kinds
|
||||
(contract-restrict-recursive-values (compute-constraints sc kind)))))))
|
||||
(contract-restrict-recursive-values (compute-constraints sc kind)))
|
||||
cache))))
|
||||
|
||||
(define (compute-constraints sc max-kind)
|
||||
(define memo-table (make-hash))
|
||||
(define name-defs (get-all-name-defs))
|
||||
(define (recur sc)
|
||||
(match sc
|
||||
[(recursive-sc names values body)
|
||||
(close-loop names (map recur values) (recur body))]
|
||||
[(? sc?)
|
||||
(sc->constraints sc recur)]))
|
||||
(cond [(hash-ref memo-table sc #f)]
|
||||
[else
|
||||
(define result
|
||||
(match sc
|
||||
[(recursive-sc names values body)
|
||||
(close-loop names (map recur values) (recur body))]
|
||||
[(? sc?)
|
||||
(sc->constraints sc recur)]))
|
||||
(hash-set! memo-table sc result)
|
||||
result]))
|
||||
(define constraints
|
||||
(if (null? name-defs)
|
||||
(recur sc)
|
||||
|
|
@ -78,31 +94,85 @@
|
|||
(values name (hash-ref var-values var))))
|
||||
|
||||
|
||||
(define (instantiate/inner sc recursive-kinds)
|
||||
(define (instantiate/inner sc recursive-kinds cache)
|
||||
(define bound-names (make-parameter null))
|
||||
;; sc-queue : records the order in which to return syntax objects
|
||||
(define sc-queue null)
|
||||
(define (recur sc)
|
||||
(cond [(and cache (hash-ref cache sc #f)) => car]
|
||||
[(arr/sc? sc) (make-contract sc)]
|
||||
[(parametric->/sc? sc)
|
||||
(match-define (parametric->/sc: vars _) sc)
|
||||
(parameterize ([bound-names (append vars (bound-names))])
|
||||
(make-contract sc))]
|
||||
;; If any names are bound, the contract can't be shared
|
||||
;; becuase it depends on the scope it's in
|
||||
[(ormap (λ (n) (name-free-in? n sc)) (bound-names))
|
||||
(make-contract sc)]
|
||||
[else
|
||||
(define ctc (make-contract sc))
|
||||
(cond [cache
|
||||
(define fresh-id (generate-temporary))
|
||||
(hash-set! cache sc (cons fresh-id ctc))
|
||||
(set! sc-queue (cons sc sc-queue))
|
||||
fresh-id]
|
||||
[else ctc])]))
|
||||
(define (make-contract sc)
|
||||
(match sc
|
||||
[(recursive-sc names values body)
|
||||
(define raw-names (generate-temporaries names))
|
||||
(define raw-bindings
|
||||
(for/list ([raw-name (in-list raw-names)]
|
||||
[value (in-list values)])
|
||||
#`[#,raw-name #,(recur value)]))
|
||||
(parameterize ([bound-names (append names (bound-names))])
|
||||
(for/list ([raw-name (in-list raw-names)]
|
||||
[value (in-list values)])
|
||||
#`[#,raw-name #,(recur value)])))
|
||||
(define bindings
|
||||
(for/list ([name (in-list names)]
|
||||
[raw-name (in-list raw-names)])
|
||||
#`[#,name (recursive-contract #,raw-name
|
||||
#,(kind->keyword
|
||||
(hash-ref recursive-kinds name)))]))
|
||||
#`(letrec (#,@bindings #,@raw-bindings) #,(recur body))]
|
||||
#`(letrec (#,@bindings #,@raw-bindings)
|
||||
#,(parameterize ([bound-names (append names (bound-names))])
|
||||
(recur body)))]
|
||||
[(? sc? sc)
|
||||
(sc->contract sc recur)]))
|
||||
(define ctc (recur sc))
|
||||
(define name-defs (get-all-name-defs))
|
||||
(cond [(null? name-defs) (recur sc)]
|
||||
[else
|
||||
(define bindings
|
||||
(for/list ([name (in-list (apply append (dict-keys name-defs)))]
|
||||
[sc (in-list (apply append (dict-values name-defs)))])
|
||||
#`[#,name (recursive-contract #,(recur sc)
|
||||
#,(kind->keyword
|
||||
(hash-ref recursive-kinds name)))]))
|
||||
#`(letrec (#,@bindings) #,(recur sc))]))
|
||||
;; These are extra contract definitions for the name static contracts
|
||||
;; that are used for this type. Since these are shared across multiple
|
||||
;; contracts from a single contract fixup pass, we use the name-defined
|
||||
;; table to see if we've already defined it. If so, we avoid duplicating
|
||||
;; the definition later.
|
||||
(define extra-defs
|
||||
(cond [(null? name-defs) null]
|
||||
[else
|
||||
(define names (apply append (dict-keys name-defs)))
|
||||
(for/list ([name (in-list names)]
|
||||
[sc (in-list (apply append (dict-values name-defs)))]
|
||||
#:unless (lookup-name-defined name))
|
||||
(set-name-defined name)
|
||||
#`(define #,name
|
||||
(recursive-contract #,(recur sc)
|
||||
#,(kind->keyword (hash-ref recursive-kinds name)))))]))
|
||||
(list (append ;; These contracts are sub-contract definitions used to
|
||||
;; increase sharing among contracts in a given fixup pass
|
||||
extra-defs
|
||||
(for/list ([sc (in-list (reverse sc-queue))])
|
||||
(match-define (cons id ctc) (hash-ref cache sc))
|
||||
#`(define #,id #,ctc)))
|
||||
ctc))
|
||||
|
||||
;; determine if a given name is free in the sc
|
||||
(define (name-free-in? name sc)
|
||||
(let/ec escape
|
||||
(define/match (free? sc _)
|
||||
[((or (recursive-sc-use name*)
|
||||
(parametric-var/sc: name*)
|
||||
(name/sc: name*))
|
||||
_)
|
||||
(when (free-identifier=? name name*)
|
||||
(escape #t))]
|
||||
[(_ _) (sc-traverse sc free?)])
|
||||
(free? sc 'dummy)
|
||||
#f))
|
||||
|
|
|
|||
|
|
@ -29,8 +29,14 @@
|
|||
(define (get-rec-var id)
|
||||
(dict-ref! rec-vars id (lambda () (add-variable! eqs 0))))
|
||||
|
||||
(define seen (make-hash))
|
||||
|
||||
(define (recur sc variance)
|
||||
(define seen? #f)
|
||||
(match sc
|
||||
;; skip already seen sc
|
||||
[(? (λ (sc) (hash-ref seen (list sc variance) #f)))
|
||||
(set! seen? #t)]
|
||||
[(or (or/sc: elems ...) (and/sc: elems ...))
|
||||
(add-equation! eqs (get-var sc)
|
||||
(lambda () (for/sum ((e elems))
|
||||
|
|
@ -45,7 +51,9 @@
|
|||
(add-equation! eqs (get-var sc) (lambda () (variable-ref (get-rec-var id))))]
|
||||
[else
|
||||
(get-var sc)])
|
||||
(sc-traverse sc recur))
|
||||
(unless seen?
|
||||
(hash-set! seen (list sc variance) #t)
|
||||
(sc-traverse sc recur)))
|
||||
|
||||
(recur sc 'covariant)
|
||||
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
(submod typed-racket/private/type-contract numeric-contracts)
|
||||
(submod typed-racket/private/type-contract test-exports)
|
||||
(only-in racket/contract contract)
|
||||
racket/match
|
||||
rackunit)
|
||||
(provide tests)
|
||||
(gen-test-main)
|
||||
|
|
@ -99,16 +100,20 @@
|
|||
#`(test-case (format "~a for ~a in ~a" 'type-expr 'val-expr 'fun-expr)
|
||||
(let ([type-val type-expr] [fun-val fun-expr] [val val-expr])
|
||||
(with-check-info (['type type-val] ['test-value val])
|
||||
(define ctc-stx
|
||||
(define ctc-result
|
||||
(type->contract type-val
|
||||
#:typed-side typed-side
|
||||
(λ (#:reason [reason #f])
|
||||
(fail-check (or reason "Type could not be converted to contract")))))
|
||||
(match-define (list extra-stxs ctc-stx) ctc-result)
|
||||
(define ctced-val
|
||||
(eval #`(contract #,(syntax-shift-phase-level ctc-stx 1)
|
||||
#,val
|
||||
#,(quote (quote #,pos))
|
||||
#,(quote (quote #,neg)))
|
||||
(eval #`(let ()
|
||||
#,@(map (λ (stx) (syntax-shift-phase-level stx 1))
|
||||
extra-stxs)
|
||||
(contract #,(syntax-shift-phase-level ctc-stx 1)
|
||||
#,val
|
||||
#,(quote (quote #,pos))
|
||||
#,(quote (quote #,neg))))
|
||||
(ctc-namespace)))
|
||||
(check (λ () (fun-val ctced-val))))))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -28,8 +28,9 @@
|
|||
(if sc
|
||||
#`(with-check-info (['static '#,sc])
|
||||
(phase1-phase0-eval
|
||||
(define ctc (instantiate '#,sc
|
||||
(lambda (#:reason _) (error "static-contract could not be converted to a contract"))))
|
||||
(define ctc (cadr
|
||||
(instantiate '#,sc
|
||||
(lambda (#:reason _) (error "static-contract could not be converted to a contract")))))
|
||||
#,#'#`(with-check-info (['contract '#,ctc])
|
||||
(define runtime-contract #,ctc)
|
||||
(check-pred contract? runtime-contract))))
|
||||
|
|
|
|||
|
|
@ -48,10 +48,11 @@
|
|||
(make-check-expected expected))
|
||||
(λ ()
|
||||
(let ([ctc (syntax->datum
|
||||
(cadr
|
||||
(instantiate
|
||||
(optimize argument #:trusted-positive #t)
|
||||
(λ (#:reason [reason #f]) (error 'nyi))
|
||||
'impersonator))])
|
||||
'impersonator)))])
|
||||
(with-check-info* (list (make-check-actual ctc))
|
||||
(λ ()
|
||||
(unless (equal? ctc expected)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user