diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-scheme/base-env/base-env.rkt index 1f9f84690e..e3a410dea9 100644 --- a/collects/typed-scheme/base-env/base-env.rkt +++ b/collects/typed-scheme/base-env/base-env.rkt @@ -27,6 +27,7 @@ (only-in (types abbrev numeric-tower) [-Number N] [-Boolean B] [-Symbol Sym]) (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-ChannelTop make-VectorTop + make-ThreadCellTop make-Ephemeron make-HeterogenousVector)) @@ -447,7 +448,14 @@ [thread-try-receive (-> Univ)] [thread-rewind-receive (-> (-lst Univ) -Void)] +;Section 10.3.1 (Thread Cells) +[thread-cell? (make-pred-ty (make-ThreadCellTop))] +[make-thread-cell (-poly (a) (->opt a [Univ] (-thread-cell a)))] +[thread-cell-ref (-poly (a) (-> (-thread-cell a) a))] +[thread-cell-set! (-poly (a) (-> (-thread-cell a) a -Void))] +[current-preserved-thread-cell-values + (cl->* (-> Univ) (-> Univ -Void))] [future (-poly (A) ((-> A) . -> . (-future A)))] [touch (-poly (A) ((-future A) . -> . A))] diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 75d8f78e68..a4a550fdcc 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -495,6 +495,8 @@ (cset-meet* (list (cg s s*) (cg s* s) (cg t t*) (cg t* t)))] [((Channel: e) (Channel: e*)) (cset-meet (cg e e*) (cg e* e))] + [((ThreadCell: e) (ThreadCell: e*)) + (cset-meet (cg e e*) (cg e* e))] [((Ephemeron: e) (Ephemeron: e*)) (cg e e*)] [((Set: a) (Set: a*)) diff --git a/collects/typed-scheme/infer/promote-demote.rkt b/collects/typed-scheme/infer/promote-demote.rkt index ccc44518ce..12696a4773 100644 --- a/collects/typed-scheme/infer/promote-demote.rkt +++ b/collects/typed-scheme/infer/promote-demote.rkt @@ -26,6 +26,7 @@ [#:Vector t (make-Vector (inv t))] [#:Box t (make-Box (inv t))] [#:Channel t (make-Channel (inv t))] + [#:ThreadCell t (make-ThreadCell (inv t))] [#:Hashtable k v (if (V-in? V v) Univ @@ -60,6 +61,7 @@ [#:Vector t (make-Vector (inv t))] [#:Box t (make-Box (inv t))] [#:Channel t (make-Channel (inv t))] + [#:ThreadCell t (make-ThreadCell (inv t))] [#:Hashtable k v (if (V-in? V v) (Un) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 43994b5f3c..da1a7b2ec1 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -130,6 +130,12 @@ [#:frees (λ (f) (make-invariant (f elem)))] [#:key 'channel]) +;; elem is a Type +(def-type ThreadCell ([elem Type/c]) + [#:frees (λ (f) (make-invariant (f elem)))] + [#:key 'thread-cell]) + + ;; elem is a Type (def-type Ephemeron ([elem Type/c]) [#:key 'ephemeron]) @@ -140,6 +146,8 @@ [#:key 'set]) + + ;; name is a Symbol (not a Name) ;; contract is used when generating contracts from types ;; predicate is used to check (at compile-time) whether a value belongs @@ -315,6 +323,7 @@ (def-type HashtableTop () [#:fold-rhs #:base] [#:key 'hash]) (def-type MPairTop () [#:fold-rhs #:base] [#:key 'mpair]) (def-type StructTop ([name Struct?]) [#:key 'struct]) +(def-type ThreadCellTop () [#:fold-rhs #:base] [#:key 'thread-cell]) ;; v : Scheme Value (def-type Value (v) [#:frees #f] [#:fold-rhs #:base] [#:key (cond [(number? v) 'number] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 1f8038be5a..71999c99c9 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -31,6 +31,7 @@ (define -Param make-Param) (define -box make-Box) (define -channel make-Channel) +(define -thread-cell make-ThreadCell) (define -set make-Set) (define -vec make-Vector) (define -future make-Future) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index e3b6bce607..ab4465cbee 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -125,6 +125,7 @@ [(StructTop: st) (fp "~a" st)] [(BoxTop:) (fp "Box")] [(ChannelTop:) (fp "Channel")] + [(ThreadCellTop:) (fp "ThreadCell")] [(VectorTop:) (fp "Vector")] [(MPairTop:) (fp "MPair")] [(App: rator rands stx) @@ -171,6 +172,7 @@ [(Box: e) (fp "(Boxof ~a)" e)] [(Future: e) (fp "(Futureof ~a)" e)] [(Channel: e) (fp "(Channelof ~a)" e)] + [(ThreadCell: e) (fp "(ThreadCellof ~a)" e)] [(Ephemeron: e) (fp "(Ephemeronof ~a)" e)] [(Set: e) (fp "(Setof ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index f524720945..35e367631a 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -372,6 +372,7 @@ [((Ephemeron: s) (Ephemeron: t)) (subtype* A0 s t)] [((Box: _) (BoxTop:)) A0] + [((ThreadCell: _) (ThreadCellTop:)) A0] [((Set: t) (Set: t*)) (subtype* A0 t t*)] [((Channel: _) (ChannelTop:)) A0] [((Vector: _) (VectorTop:)) A0]