[MLton-commit] r5357
Vesa Karvonen
vesak at mlton.org
Wed Feb 28 01:37:13 PST 2007
Changed Async to use Queues for fairness. Changed Node.filter and
Node.filterOut to return the tail of the list. Moved the implementation
specific QUEUE extensions to the Queue module signature.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
U mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
U mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig
U mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml 2007-02-27 21:25:03 UTC (rev 5356)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml 2007-02-28 09:37:05 UTC (rev 5357)
@@ -67,38 +67,38 @@
structure Ch = struct
datatype 'a t
- = 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 ()}
+ = 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 ()}
fun take (T {gs, ts}) =
E (fn () =>
- (Node.filterOut (Handler.scheduled o #handler) gs
- ; case Node.take gs of
- NONE => INL (Node.push ts)
+ (Queue.filterOut (Handler.scheduled o #handler) gs
+ ; case Queue.deque gs of
+ NONE => INL (Queue.enque ts)
| SOME {handler, value} =>
(Handler.schedule () handler ; INR value)))
fun give (T {ts, gs}) v =
E (fn () =>
- (Node.filterOut Handler.scheduled ts
- ; case Node.take ts of
+ (Queue.filterOut Handler.scheduled ts
+ ; case Queue.deque ts of
SOME th => (Handler.schedule v th ; INR ())
| NONE =>
- INL (fn h => Node.push gs {handler = h, value = v})))
+ INL (fn h => Queue.enque gs {handler = h, value = v})))
end
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 ()}
+ datatype 'a t = T of {ts : 'a Handler.t Queue.t, vs : 'a Queue.t}
+ fun new () = T {ts = Queue.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))
+ NONE => (Queue.filterOut Handler.scheduled ts
+ ; INL (Queue.enque 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
+ ; Queue.filterOut Handler.scheduled ts
+ ; case Queue.deque ts of
NONE => ()
| SOME th =>
case Queue.deque vs of
@@ -107,32 +107,32 @@
end
structure IVar = struct
- 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}
+ 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}
fun read (T {rs, st}) =
E (fn () =>
case !st of
SOME v => INR v
- | NONE => (Node.filterOut Handler.scheduled rs
- ; INL (Node.push rs)))
+ | NONE => (Queue.filterOut Handler.scheduled rs
+ ; INL (Queue.enque rs)))
fun fill (T {rs, st}) v =
case !st of
SOME _ => raise Full
- | NONE => (st := SOME v ; Node.clearWith (Handler.schedule v) rs)
+ | NONE => (st := SOME v ; Queue.appClear (Handler.schedule v) rs)
end
structure MVar = struct
- 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}
+ 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}
fun take (T {ts, st}) =
E (fn () =>
case !st of
SOME v => (st := NONE ; INR v)
- | NONE => (Node.filterOut Handler.scheduled ts
- ; INL (Node.push ts)))
+ | NONE => (Queue.filterOut Handler.scheduled ts
+ ; INL (Queue.enque ts)))
fun give (T {ts, st}) v =
- (Node.filterOut Handler.scheduled ts
- ; case Node.take ts of
+ (Queue.filterOut Handler.scheduled ts
+ ; case Queue.deque ts of
NONE => st := SOME v
| SOME h => Handler.schedule v h)
fun fill (t as T {st, ...}) v =
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/node.sml 2007-02-27 21:25:03 UTC (rev 5356)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/node.sml 2007-02-28 09:37:05 UTC (rev 5357)
@@ -91,16 +91,18 @@
val length : 'a t -> Int.t
(** Returns the length of the given imperative list. *)
- val filter : 'a UnPr.t -> 'a t Effect.t
+ val filter : 'a UnPr.t -> 'a t UnOp.t
(**
* Drops all nodes from the imperative list whose elements do not
- * satisfy the given predicate.
+ * satisfy the given predicate. Returns the last, and always empty,
+ * node of the remaining list.
*)
- val filterOut : 'a UnPr.t -> 'a t Effect.t
+ val filterOut : 'a UnPr.t -> 'a t UnOp.t
(**
* Drops all nodes from the imperative list whose elements satisfy the
- * given predicate.
+ * given predicate. Returns the last, and always empty, node of the
+ * remaining list.
*)
val foldl : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
@@ -185,7 +187,7 @@
fun filter p t =
case get t of
- NONE => ()
+ NONE => t
| SOME (x, t') => (if p x then () else drop t ; filter p t')
fun filterOut p = filter (negate p)
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig 2007-02-27 21:25:03 UTC (rev 5356)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig 2007-02-28 09:37:05 UTC (rev 5357)
@@ -4,10 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-(*
- * Signature for an imperative polymorphic queue.
- *)
-
+(** Signature for imperative polymorphic queues. *)
signature QUEUE = sig
type 'a t
@@ -19,7 +16,4 @@
val deque : 'a t -> 'a Option.t
val enque : 'a t -> 'a Effect.t
-
- val foldClear : ('a * 's -> 's) -> 's -> 'a t -> 's
- val appClear : 'a Effect.t -> 'a t Effect.t
end
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml 2007-02-27 21:25:03 UTC (rev 5356)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml 2007-02-28 09:37:05 UTC (rev 5357)
@@ -5,12 +5,19 @@
*)
(*
- * An implementation of the {QUEUE} signature. This is based on a space
- * safe implementation by Stephen Weeks posted on the MLton developers
- * mailing list.
+ * An implementation of an extended version of the {QUEUE} signature. The
+ * extensions aren't part of the {QUEUE} signature, because they don't
+ * make sense for all possible implementations of the signature. This
+ * implementation is based on a space safe implementation by Stephen Weeks
+ * posted on the MLton developers mailing list.
*)
-
-structure Queue :> QUEUE = struct
+structure Queue :> sig
+ include QUEUE
+ val filter : 'a UnPr.t -> 'a t Effect.t
+ val filterOut : 'a UnPr.t -> 'a t Effect.t
+ val foldClear : ('a * 's -> 's) -> 's -> 'a t -> 's
+ val appClear : 'a Effect.t -> 'a t Effect.t
+end = struct
structure N = Node
datatype 'a t = IN of {back : 'a N.t Ref.t,
@@ -42,6 +49,12 @@
NONE => NONE
| SOME (a, n) => (front := n ; SOME a)
+ fun filter p (IN {back, front}) =
+ back := Node.filter p (!front)
+
+ fun filterOut p =
+ filter (negate p)
+
fun foldClear f s q =
case deque q of
NONE => s
More information about the MLton-commit
mailing list