[MLton-commit] r5356

[Vesa Karvonen]

Changed code to clean up handler lists to eliminate space leaks.

Different Mailbox implementation to ensure that messages arrive in the
correct order.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/async/unstable/detail/async.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-27 21:13:03 UTC (rev 5355)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-27 21:25:03 UTC (rev 5356)
@@ -67,62 +67,82 @@
 
    structure Ch = struct
       datatype 'a t
-        = T of {ts : 'a Handler.t Queue.t,
-                gs : {handler : Unit.t Handler.t, value : 'a} Queue.t}
-      fun new () = T {ts = Queue.new (), gs = Queue.new ()}
+        = T of {ts : 'a Handler.t Node.t,
+                gs : {handler : Unit.t Handler.t, value : 'a} Node.t}
+      fun new () = T {ts = Node.new (), gs = Node.new ()}
       fun take (T {gs, ts}) =
           E (fn () =>
-                case Queue.dequeWhile (Handler.scheduled o #handler) gs of
-                   NONE => INL (Queue.enque ts)
-                 | SOME {handler, value} =>
-                   (Handler.schedule () handler ; INR value))
+                (Node.filterOut (Handler.scheduled o #handler) gs
+               ; case Node.take gs of
+                    NONE => INL (Node.push ts)
+                  | SOME {handler, value} =>
+                    (Handler.schedule () handler ; INR value)))
       fun give (T {ts, gs}) v =
           E (fn () =>
-                case Queue.dequeWhile Handler.scheduled ts of
-                   SOME th => (Handler.schedule v th ; INR ())
-                 | NONE =>
-                   INL (fn h => Queue.enque gs {handler = h, value = v}))
-      fun send m = Event.once o give m
+                (Node.filterOut Handler.scheduled ts
+               ; case Node.take ts of
+                    SOME th => (Handler.schedule v th ; INR ())
+                  | NONE =>
+                    INL (fn h => Node.push gs {handler = h, value = v})))
    end
 
-   structure Mailbox = Ch
+   structure Mailbox = struct
+      datatype 'a t = T of {ts : 'a Handler.t Node.t, vs : 'a Queue.t}
+      fun new () = T {ts = Node.new (), vs = Queue.new ()}
+      fun take (T {ts, vs}) =
+          E (fn () =>
+                case Queue.deque vs of
+                   NONE => (Node.filterOut Handler.scheduled ts
+                          ; INL (Node.push ts))
+                 | SOME v => INR v)
+      fun send (T {ts, vs}) v =
+          (Queue.enque vs v
+         ; Node.filterOut Handler.scheduled ts
+         ; case Node.take ts of
+              NONE => ()
+            | SOME th =>
+              case Queue.deque vs of
+                 NONE => raise Fail "impossible"
+               | SOME v => Handler.schedule v th)
+   end
 
    structure IVar = struct
-      datatype 'a t = T of {rs : 'a Handler.t Queue.t, st : 'a Option.t Ref.t}
-      fun new () = T {rs = Queue.new (), st = ref NONE}
+      datatype 'a t = T of {rs : 'a Handler.t Node.t, st : 'a Option.t Ref.t}
+      fun new () = T {rs = Node.new (), st = ref NONE}
       fun read (T {rs, st}) =
           E (fn () =>
                 case !st of
                    SOME v => INR v
-                 | NONE => INL (Queue.enque rs))
+                 | NONE => (Node.filterOut Handler.scheduled rs
+                          ; INL (Node.push rs)))
       fun fill (T {rs, st}) v =
           case !st of
              SOME _ => raise Full
-           | NONE => (st := SOME v ; Queue.appClear (Handler.schedule v) rs)
+           | NONE => (st := SOME v ; Node.clearWith (Handler.schedule v) rs)
    end
 
    structure MVar = struct
-      datatype 'a t = T of {ts : 'a Handler.t Queue.t, st : 'a Option.t Ref.t}
-      fun new () = T {ts = Queue.new (), st = ref NONE}
+      datatype 'a t = T of {ts : 'a Handler.t Node.t, st : 'a Option.t Ref.t}
+      fun new () = T {ts = Node.new (), st = ref NONE}
       fun take (T {ts, st}) =
           E (fn () =>
                 case !st of
                    SOME v => (st := NONE ; INR v)
-                 | NONE => INL (Queue.enque ts))
-      fun fill (T {ts, st}) v =
+                 | NONE => (Node.filterOut Handler.scheduled ts
+                          ; INL (Node.push ts)))
+      fun give (T {ts, st}) v =
+          (Node.filterOut Handler.scheduled ts
+         ; case Node.take ts of
+              NONE => st := SOME v
+            | SOME h => Handler.schedule v h)
+      fun fill (t as T {st, ...}) v =
           case !st of
              SOME _ => raise Full
-           | NONE =>
-             case Queue.dequeWhile Handler.scheduled ts of
-                NONE => st := SOME v
-              | SOME h => Handler.schedule v h
-      fun send (T {ts, st}) v =
+           | NONE => give t v
+      fun send (t as T {st, ...}) v =
           case !st of
              SOME _ => st := SOME v
-           | NONE =>
-             case Queue.dequeWhile Handler.scheduled ts of
-                NONE => st := SOME v
-              | SOME h => Handler.schedule v h
+           | NONE => give t v
    end
 
    structure SkipCh = MVar