Typed Racket support for Ephemerons #5

Closed
wants to merge 2 commits into
from
Jump to file or symbol
Failed to load files and symbols.
+41 −1
Split
@@ -0,0 +1,16 @@
+#lang typed/scheme
+
+(define key (gensym))
+
+(: eph-one (Ephemeronof Integer))
+(define eph-one (make-ephemeron key 1))
+
+(ephemeron? eph-one)
+
+(ephemeron-value eph-one)
+
+(: get-number ((Ephemeronof Number) -> Number))
+(define (get-number e)
+ (or (ephemeron-value e) 0))
+
+(get-number eph-one)
@@ -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))]
+ [((Ephemeron: e) (Ephemeron: e*))
+ (cg e e*)]
;; we assume all HTs are mutable at the moment
[((Hashtable: s1 s2) (Hashtable: t1 t2))
;; for mutable hash tables, both are invariant
@@ -25,6 +25,8 @@
(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-EphemeronTop
+ make-Ephemeron
make-HeterogenousVector))
[raise (Univ . -> . (Un))]
@@ -1027,4 +1029,11 @@
(-> -Compiled-Module-Expression
(-opt (make-HeterogenousVector (list -Module-Path -Symbol Univ))))]
-[compose (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))]
+[compose (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))]
+
+
+;ephemerons
+[make-ephemeron (-poly (k v) (-> k v (make-Ephemeron v)))]
+[ephemeron? (make-pred-ty (make-EphemeronTop))]
+[ephemeron-value (-poly (v) (-> (make-Ephemeron v) (Un (-val #f) v)))]
+
@@ -111,6 +111,7 @@
[Pair (-poly (a b) (-pair a b))]
[Boxof (-poly (a) (make-Box a))]
[Channelof (-poly (a) (make-Channel a))]
+[Ephemeronof (-poly (a) (make-Ephemeron a))]
[Continuation-Mark-Set -Cont-Mark-Set]
[False (-val #f)]
[True (-val #t)]
@@ -130,6 +130,11 @@
[#:frees (λ (f) (make-invariant (f elem)))]
[#:key 'channel])
+;; elem is a Type
+(dt Ephemeron ([elem Type/c])
+ [#:key 'ephemeron])
+
+
;; 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
@@ -301,6 +306,7 @@
;; the supertype of all of these values
(dt BoxTop () [#:fold-rhs #:base] [#:key 'box])
(dt ChannelTop () [#:fold-rhs #:base] [#:key 'channel])
+(dt EphemeronTop () [#:fold-rhs #:base] [#:key 'ephemeron])
(dt VectorTop () [#:fold-rhs #:base] [#:key 'vector])
(dt HashtableTop () [#:fold-rhs #:base] [#:key 'hash])
(dt MPairTop () [#:fold-rhs #:base] [#:key 'mpair])
@@ -125,6 +125,7 @@
[(StructTop: st) (fp "~a" st)]
[(BoxTop:) (fp "Box")]
[(ChannelTop:) (fp "Channel")]
+ [(EphemeronTop:) (fp "Ephemeron")]
[(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)]
+ [(Ephemeron: e) (fp "(Ephemeronof ~a)" e)]
[(Union: elems) (fp "~a" (cons 'U elems))]
[(Pair: l r) (fp "(Pairof ~a ~a)" l r)]
[(ListDots: dty dbound)
@@ -357,6 +357,10 @@
(subtype/flds* A flds flds*))]
[((Struct: _ _ _ _ _ _ _ _) (StructTop: (== s type-equal?)))
A0]
+ ;ephemerons are covariant
+ [((Ephemeron: s) (Ephemeron: t))
+ (subtype* A0 s t)]
+ [((Ephemeron: _) (EphemeronTop:)) A0]
[((Box: _) (BoxTop:)) A0]
[((Channel: _) (ChannelTop:)) A0]
[((Vector: _) (VectorTop:)) A0]