[MLton-commit] r5442

[Vesa Karvonen]

First cut at an example generic poll loop for OS.IO.  Untested and
unoptimized.

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

A   mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/
A   mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/lib.mlb
A   mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml

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

Added: mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/lib.mlb	2007-03-15 23:06:22 UTC (rev 5441)
+++ mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/lib.mlb	2007-03-15 23:41:43 UTC (rev 5442)
@@ -0,0 +1,17 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+in
+   ann
+      "forceUsed"
+      "sequenceNonUnit warn"
+      "warnUnused true"
+   in
+      poll-loop.sml
+   end
+end


Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/lib.mlb
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml	2007-03-15 23:06:22 UTC (rev 5441)
+++ mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml	2007-03-15 23:41:43 UTC (rev 5442)
@@ -0,0 +1,65 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure PollLoop :> sig
+   val run : Unit.t Effect.t Effect.t
+
+   val stop : Unit.t Effect.t
+
+   val addDesc : (OS.IO.poll_desc * OS.IO.poll_info Effect.t) Effect.t
+   val remDesc : OS.IO.poll_desc Effect.t
+
+   val absTimeout : (Time.time * Unit.t Effect.t) Effect.t
+   val relTimeout : (Time.time * Unit.t Effect.t) Effect.t
+end = struct
+   val doStop = ref false
+   fun stop () = doStop := true
+
+   val descs : (OS.IO.poll_desc * OS.IO.poll_info Effect.t) List.t Ref.t =
+       ref []
+   fun findDesc d k =
+       recur ([] & !descs) (fn lp =>
+          fn _ & [] => fail "findDesc"
+           | fs & e::es => if #1e=d then k (fs, e, es) else lp (e::fs & es))
+   val addDesc = List.push descs
+   fun remDesc d =
+       findDesc d (fn (fs, _, es) => descs := List.revAppend (fs, es))
+
+   val timeouts : (Time.time * Unit.t Effect.t) List.t Ref.t = ref []
+   fun absTimeout (absTime, action) = let
+      fun here fs es = timeouts := List.revAppend (fs, es)
+   in
+      recur ([] & !timeouts) (fn lp =>
+         fn fs & [] => here fs [(absTime, action)]
+          | fs & e::es => if Time.<= (#1e, absTime) then lp (e::fs & es)
+                             else here fs ((absTime, action)::es))
+   end
+   fun relTimeout (relTime, action) =
+       absTimeout (Time.+ (Time.now (), relTime), action)
+
+   fun run ef =
+       (ef () : Unit.t
+      ; if null (!descs) orelse !doStop then doStop := false else let
+           val ds = map #1 (!descs)
+           fun doPoll timeout = OS.IO.poll (ds, timeout)
+           fun noTimeout ids =
+               (app (fn id =>
+                        findDesc (OS.IO.infoToPollDesc id)
+                                 (fn (_, (_, action), _) =>
+                                     action id)) ids
+              ; run ef)
+        in
+           case List.pop timeouts of
+              NONE => noTimeout (doPoll NONE)
+            | SOME (absTime, action) =>
+              case doPoll let
+                      open Time
+                   in SOME (Cmp.max compare (zeroTime, absTime - now ()))
+                   end of
+                 [] => (action () ; run ef)
+               | is => (List.push timeouts (absTime, action) ; noTimeout is)
+        end)
+end


Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml
___________________________________________________________________
Name: svn:eol-style
   + native