Beginning of ephemeron patch

collects/tests/typed-scheme/succeed/ephemerons.rkt

@@ -0,0 +1,14 @@
+#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)
+ (ephemeron-value e))

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))]
+          [((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

collects/typed-scheme/private/base-env.rkt

@@ -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))]
@@ -1028,3 +1030,10 @@
      (-opt (make-HeterogenousVector (list -Module-Path -Symbol Univ))))]
 
 [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)))]
+

collects/typed-scheme/private/base-types.rkt

@@ -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)]

collects/typed-scheme/rep/type-rep.rkt

@@ -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])

collects/typed-scheme/types/printer.rkt

@@ -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) 

collects/typed-scheme/types/subtype.rkt

@@ -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]