Do not update subtype and resolve caches when subtyping.
Closes PR13412. original commit: 13ff5883fe097f8b37e6a7663e3e0d8baf8c466b
This commit is contained in:
parent
ae3a41a9ab
commit
e9e54d41a8
12
collects/tests/typed-racket/succeed/pr13412.rkt
Normal file
12
collects/tests/typed-racket/succeed/pr13412.rkt
Normal file
|
@ -0,0 +1,12 @@
|
|||
#lang typed/racket
|
||||
|
||||
(define-type (Tree A) (U (Listof A) (node A)))
|
||||
(struct: (A) node ([val : A]
|
||||
[left : (Tree A)]
|
||||
[right : (Tree A)]))
|
||||
|
||||
(: tree-set (All (A) (A (Tree A) -> (Tree A))))
|
||||
(define (tree-set y t)
|
||||
(cond [(node? t) (node y (node-left t) (node-right t))]
|
||||
[else (list y)]))
|
||||
|
13
collects/typed-racket/types/current-seen.rkt
Normal file
13
collects/typed-racket/types/current-seen.rkt
Normal file
|
@ -0,0 +1,13 @@
|
|||
#lang racket/base
|
||||
(require "../utils/utils.rkt")
|
||||
(require (rep type-rep))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define current-seen (make-parameter null))
|
||||
(define (currently-subtyping?) (not (null? (current-seen))))
|
||||
|
||||
(define (seen-before s t) (cons (Type-seq s) (Type-seq t)))
|
||||
(define (remember s t A) (cons (seen-before s t) A))
|
||||
(define (seen? s t) (member (seen-before s t) (current-seen)))
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
(require (rep type-rep rep-utils free-variance)
|
||||
(env type-name-env)
|
||||
(utils tc-utils)
|
||||
(types utils)
|
||||
(types utils current-seen)
|
||||
racket/match
|
||||
racket/contract
|
||||
racket/format)
|
||||
|
@ -82,7 +82,7 @@
|
|||
[(App: r r* s)
|
||||
(resolve-app r r* s)]
|
||||
[(Name: _) (resolve-name t)])])
|
||||
(when r*
|
||||
(when (and r* (not (currently-subtyping?)))
|
||||
(hash-set! resolver-cache seq r*))
|
||||
r*)))
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
(require (except-in "../utils/utils.rkt" infer)
|
||||
(rep type-rep filter-rep object-rep rep-utils)
|
||||
(utils tc-utils)
|
||||
(types utils resolve base-abbrev numeric-tower substitute)
|
||||
(types utils resolve base-abbrev numeric-tower substitute current-seen)
|
||||
(env type-name-env)
|
||||
racket/match unstable/match
|
||||
racket/function
|
||||
|
@ -24,14 +24,6 @@
|
|||
(syntax-rules ()
|
||||
[(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))]))
|
||||
|
||||
;; data structures for remembering things on recursive calls
|
||||
(define (empty-set) '())
|
||||
|
||||
(define current-seen (make-parameter (empty-set)))
|
||||
|
||||
(define (seen-before s t) (cons (Type-seq s) (Type-seq t)))
|
||||
(define (remember s t A) (cons (seen-before s t) A))
|
||||
(define (seen? s t) (member (seen-before s t) (current-seen)))
|
||||
|
||||
(define subtype-cache (make-hash))
|
||||
(define (cache-types s t)
|
||||
|
@ -54,7 +46,8 @@
|
|||
(define result (handle-failure (and (subtype* (current-seen) s t) #t)))
|
||||
;(printf "subtype cache miss ~a ~a\n" s t)
|
||||
result)
|
||||
(hash-ref! subtype-cache k new-val))
|
||||
((if (currently-subtyping?) hash-ref hash-ref!)
|
||||
subtype-cache k new-val))
|
||||
|
||||
;; are all the s's subtypes of all the t's?
|
||||
;; [type] [type] -> boolean
|
||||
|
@ -162,7 +155,7 @@
|
|||
(define (subtypes/varargs args dom rst)
|
||||
(with-handlers
|
||||
([exn:subtype? (lambda _ #f)])
|
||||
(subtypes*/varargs (empty-set) args dom rst)))
|
||||
(subtypes*/varargs null args dom rst)))
|
||||
|
||||
(define (subtypes*/varargs A0 argtys dom rst)
|
||||
(let loop-varargs ([dom dom] [argtys argtys] [A A0])
|
||||
|
|
Loading…
Reference in New Issue
Block a user