mlton-commit Mailing List for MLton

Going to 64-bit headers and array lengths on 64-bit executables.

See commit r5322 for more details on preliminary 64-bit executables.

This commit "fixes" the mark-compact collector.  The issue is that the
mark-compact collector threads object pointers through headers.

We might be able to get by with 32-bit headers, if every object was
required to have 32-bits of non-object-pointers after the header.  (It
would be o.k. if these bits were from object data.)  However, this
wouldn't suffice for an array of object pointers, since adding another
32-bits at the beginning of the array would break offsets; and adding
32-bits to every element (just to get 32-bits at the beginning of the
object) is too much of a space waste.

So, we need to go with 64-bit headers.  However, advanceToObjectData
assumes that one can distinguish between the beginning of a normal
object header and the beginning of an array object header by looking
for the 0 of the array counter word.  So, array counters need to be
64-bits, and since the compiler currently assumes that the array
counter and the array length fields of an array header are the same
size, array lengths need to be 64-bits.

Note that the default integer size is still Int32.int, so Array.maxLen
(and array indexes) are still only 32-bits (from user code).

Haven't tested very large arrays with -default-ty int64.


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

U   mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h

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

Modified: mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun	2007-03-01 01:53:20 UTC (rev 5369)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/main/main.fun	2007-03-01 02:10:46 UTC (rev 5370)
@@ -694,10 +694,10 @@
                    cpointer = word64,
                    cptrdiff = word64,
                    csize = word64,
-                   header = word32,
+                   header = word64,
                    mplimb = word64,
                    objptr = word64,
-                   seqIndex = word32}
+                   seqIndex = word64}
                end
           | _ =>
                let

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.h	2007-03-01 01:53:20 UTC (rev 5369)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.h	2007-03-01 02:10:46 UTC (rev 5370)
@@ -20,15 +20,28 @@
  * the number of elements in the array.  Array elements have the same
  * individual layout as normal objects, omitting the header word.
  */
+#ifdef GC_MODEL_NATIVE32
 typedef uint32_t GC_arrayLength;
 #define GC_ARRAY_LENGTH_SIZE sizeof(GC_arrayLength)
 #define PRIxARRLEN PRIu32
 #define FMTARRLEN "%"PRIxARRLEN
 typedef GC_arrayLength GC_arrayCounter;
 #define GC_ARRAY_COUNTER_SIZE sizeof(GC_arrayCounter)
-#define PRIxARRCTR PRIu32
+#define PRIxARRCTR PRIxARRLEN
 #define FMTARRCTR "%"PRIxARRCTR
 #define GC_ARRAY_HEADER_SIZE (GC_ARRAY_COUNTER_SIZE + GC_ARRAY_LENGTH_SIZE + GC_HEADER_SIZE)
+#endif
+#ifdef GC_MODEL_NATIVE64
+typedef uint64_t GC_arrayLength;
+#define GC_ARRAY_LENGTH_SIZE sizeof(GC_arrayLength)
+#define PRIxARRLEN PRIu64
+#define FMTARRLEN "%"PRIxARRLEN
+typedef GC_arrayLength GC_arrayCounter;
+#define GC_ARRAY_COUNTER_SIZE sizeof(GC_arrayCounter)
+#define PRIxARRCTR PRIxARRLEN
+#define FMTARRCTR "%"PRIxARRCTR
+#define GC_ARRAY_HEADER_SIZE (GC_ARRAY_COUNTER_SIZE + GC_ARRAY_LENGTH_SIZE + GC_HEADER_SIZE)
+#endif
 
 #endif /* (defined (MLTON_GC_INTERNAL_TYPES)) */
 

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h	2007-03-01 01:53:20 UTC (rev 5369)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h	2007-03-01 02:10:46 UTC (rev 5370)
@@ -39,20 +39,32 @@
  * 20 - 30   : counter bits, used by mark compact GC (initially 0)
  *      31   : mark bit, used by mark compact GC (initially 0)
  */
+#ifdef GC_MODEL_NATIVE32
 typedef uint32_t GC_header;
 #define GC_HEADER_SIZE sizeof(GC_header)
 #define PRIxHDR PRIx32
 #define FMTHDR "0x%08"PRIxHDR
+#endif
+#ifdef GC_MODEL_NATIVE64
+typedef uint64_t GC_header;
+#define GC_HEADER_SIZE sizeof(GC_header)
+#define PRIxHDR PRIx64
+#define FMTHDR "0x%08"PRIxHDR
+#endif
+#ifdef GC_HEADER_SIZE
+#else
+#error GC_header undefined
+#endif
 
 #define GC_VALID_HEADER_MASK ((GC_header)0x1)
 #define TYPE_INDEX_BITS    19
-#define TYPE_INDEX_MASK    0x000FFFFE
+#define TYPE_INDEX_MASK    ((GC_header)0x000FFFFE)
 #define TYPE_INDEX_SHIFT   1
 #define COUNTER_BITS       10
-#define COUNTER_MASK       0x7FF00000
+#define COUNTER_MASK       ((GC_header)0x7FF00000)
 #define COUNTER_SHIFT      20
 #define MARK_BITS          1
-#define MARK_MASK          0x80000000
+#define MARK_MASK          ((GC_header)0x80000000)
 #define MARK_SHIFT         31
 
 #endif /* (defined (MLTON_GC_INTERNAL_TYPES)) */

Ensure that setInitExtra and setExtendExtra are initialized.

This is required for situation where the Basis Library raises (and
handles) exceptions during initialization.

(For example, raising and handling Overflow to compute Array.maxLen
from SeqIndex.maxInt using SeqIndex.toInt.  Thraises Overflow if
SeqIndex == Int64 and Int == Int32, which indicates that we should use
Int.maxInt for Array.maxLen.  On the other hand, this does not raise
Overflow if SeqIndex == Int32 and Int == Int64, which indicates that
we should use SeqIndex.toInt (SeqIndex.maxInt) for Array.maxLen.)

Befor this commit, when such a program is compiled with "-const
'Exn.keepHistory true'", it would immediately terminate with
'MLton_bug "setExtendExtra unimplemented"'.  This corresponds to
trying to raise an exception before basis-library/mlton/exn.sml
executed, which would setExtendExtra.

Now, such a program is able to raise an exception during
initialization (without an associated call-stack).


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

U   mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml

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

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml	2007-02-28 18:13:37 UTC (rev 5368)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-mlton.sml	2007-03-01 01:53:20 UTC (rev 5369)
@@ -90,6 +90,22 @@
       val setExtendExtra: (extra -> extra) -> unit = setExtendExtra
       val setInitExtra = _prim "Exn_setInitExtra": 'a -> unit;
       val setInitExtra: extra -> unit = setInitExtra
+
+      (* Ensure that setInitExtra and setExtendExtra are initialized.
+       * Important for -const 'Exn.keepHistory true', so that 
+       * exceptions can be raised (and handled) during Basis Library
+       * initialization.
+       *)
+      val setInitExtra : extra -> unit =
+         if keepHistory
+            then (setInitExtra (NONE: extra)
+                  ; fn _ => ())
+         else fn _ => ()
+      val setExtendExtra : (extra -> extra) -> unit =
+         if keepHistory
+            then (setExtendExtra (fn _ => NONE)
+                  ; setExtendExtra)
+         else fn _ => ()
    end
 
 structure FFI =

Set Basis Library header-word and seqindex-int according to target
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml

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

Modified: mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml	2007-02-28 18:12:10 UTC (rev 5367)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/control/control-flags.sml	2007-02-28 18:13:37 UTC (rev 5368)
@@ -1062,9 +1062,15 @@
                          | 64 => "objptr-rep64.sml"
                          | _ => Error.bug "Control.mlbPathMap")},
                {var = "HEADER_WORD",
-                path = "header-word32.sml"},
+                path = (case Bits.toInt (Target.Size.header ()) of
+                           32 => "header-word32.sml"
+                         | 64 => "header-word64.sml"
+                         | _ => Error.bug "Control.mlbPathMap")},
                {var = "SEQINDEX_INT",
-                path = "seqindex-int32.sml"},
+                path = (case Bits.toInt (Target.Size.seqIndex ()) of
+                           32 => "seqindex-int32.sml"
+                         | 64 => "seqindex-int64.sml"
+                         | _ => Error.bug "Control.mlbPathMap")},
                {var = "DEFAULT_CHAR",
                 path = concat ["default-", !defaultChar, ".sml"]},
                {var = "DEFAULT_WIDECHAR",

Use correct format string
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/dfs-mark.c

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

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/dfs-mark.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/dfs-mark.c	2007-02-28 16:49:42 UTC (rev 5366)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/dfs-mark.c	2007-02-28 18:12:10 UTC (rev 5367)
@@ -187,7 +187,7 @@
     todo += bytesNonObjptrs;
 markInArray:
     if (DEBUG_DFS_MARK)
-      fprintf (stderr, "markInArray arrayIndex = %"PRIu32" objptrIndex = %"PRIu32"\n",
+      fprintf (stderr, "markInArray arrayIndex = %"PRIxARRCTR" objptrIndex = %"PRIu32"\n",
                arrayIndex, objptrIndex);
     assert (arrayIndex < getArrayLength (cur));
     assert (objptrIndex < numObjptrs);

Added convenience type alias t to flags substructures.

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

U   mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
U   mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
U   mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig

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

Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-02-28 15:27:02 UTC (rev 5365)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-02-28 16:49:42 UTC (rev 5366)
@@ -28,7 +28,6 @@
                     end
       val opt = option
       val int = int
-      val dbl = real
       val w32 = word32
       val bool = bool
       val time = iso largeReal (Time.toReal, Time.fromReal)
@@ -116,6 +115,7 @@
 
    structure Key = struct
       open Word32Flags
+      type t = flags
       val allAccess        = wc_KEY_ALL_ACCESS
       val createLink       = wc_KEY_CREATE_LINK
       val createSubKey     = wc_KEY_CREATE_SUB_KEY
@@ -281,6 +281,7 @@
    structure EventLog = struct
       structure Type = struct
          open Word16Flags
+         type t = flags
          val auditFailure = wc_EVENTLOG_AUDIT_FAILURE
          val auditSuccess = wc_EVENTLOG_AUDIT_SUCCESS
          val error        = wc_EVENTLOG_ERROR_TYPE
@@ -425,6 +426,7 @@
    structure FileChange = struct
       structure Filter = struct
          open Word32Flags
+         type t = flags
          val attributes = wc_FILE_NOTIFY_CHANGE_ATTRIBUTES
          val dirName    = wc_FILE_NOTIFY_CHANGE_DIR_NAME
          val fileName   = wc_FILE_NOTIFY_CHANGE_FILE_NAME

Modified: mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-02-28 15:27:02 UTC (rev 5365)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-02-28 16:49:42 UTC (rev 5366)
@@ -13,11 +13,12 @@
    structure EventLog : sig
       structure Type : sig
          include FLAGS where type flags_word = Word16.t
-         val auditFailure : flags
-         val auditSuccess : flags
-         val error : flags
-         val information : flags
-         val warning : flags
+         type t = flags
+         val auditFailure : t
+         val auditSuccess : t
+         val error : t
+         val information : t
+         val warning : t
       end
    end
 
@@ -76,12 +77,13 @@
    structure FileChange : sig
       structure Filter : sig
          include FLAGS where type flags_word = Word32.t
-         val fileName : flags
-         val dirName : flags
-         val attributes : flags
-         val size : flags
-         val lastWrite : flags
-         val security : flags
+         type t = flags
+         val fileName : t
+         val dirName : t
+         val attributes : t
+         val size : t
+         val lastWrite : t
+         val security : t
       end
 
       type t

Modified: mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig	2007-02-28 15:27:02 UTC (rev 5365)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig	2007-02-28 16:49:42 UTC (rev 5366)
@@ -14,16 +14,17 @@
 signature WINDOWS = sig
    structure Key : sig
       include FLAGS where type flags_word = Word32.t
-      val allAccess : flags
-      val createLink : flags
-      val createSubKey : flags
-      val enumerateSubKeys : flags
-      val execute : flags
-      val notify : flags
-      val queryValue : flags
-      val read : flags
-      val setValue : flags
-      val write : flags
+      type t = flags
+      val allAccess : t
+      val createLink : t
+      val createSubKey : t
+      val enumerateSubKeys : t
+      val execute : t
+      val notify : t
+      val queryValue : t
+      val read : t
+      val setValue : t
+      val write : t
    end
 
    structure Reg : sig
@@ -42,12 +43,12 @@
       val keyOf : create_result -> hkey
 
       val closeKey : hkey Effect.t
-      val createKeyEx : hkey * String.t * Key.flags -> create_result
+      val createKeyEx : hkey * String.t * Key.t -> create_result
       val deleteKey : (hkey * String.t) Effect.t
       val deleteValue : (hkey * String.t) Effect.t
       val enumKeyEx : hkey * Int.t -> String.t Option.t
       val enumValueEx : hkey * Int.t -> String.t Option.t
-      val openKeyEx : hkey * String.t * Key.flags -> hkey
+      val openKeyEx : hkey * String.t * Key.t -> hkey
 
       datatype value
         = BINARY of Word8Vector.t

Changed to use Time.  Added Timer.setAbs and Timer.setRel.

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

U   mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
U   mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig

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

Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-02-28 13:52:11 UTC (rev 5364)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-02-28 15:27:02 UTC (rev 5365)
@@ -31,6 +31,7 @@
       val dbl = real
       val w32 = word32
       val bool = bool
+      val time = iso largeReal (Time.toReal, Time.fromReal)
    end
 
    val op >>& = With.>>&
@@ -336,8 +337,10 @@
                ; let val res =
                          F_win_WaitForMultipleObjects.f'
                             (n, C.Ptr.ro' hs, toCBool all,
-                             if Real.== (t, Real.posInf) then infinite
-                             else Word.fromInt (Real.round (t * 1000.0)))
+                             case t of
+                                NONE => infinite
+                              | SOME t =>
+                                Word.fromLargeInt (Time.toMilliseconds t))
                      fun get off = #2 (List.sub (ws, Word.toIntX (res - off)))
                  in
                     if res = timeout then
@@ -348,7 +351,8 @@
                        ABANDONED (get abandoned)
                     else if res = failed then
                        raiseLastError
-                          (fn () => F name [A (lst ptr) (map #1 ws), A dbl t])
+                          (fn () => F name [A (lst ptr) (map #1 ws),
+                                            A (opt time) t])
                     else
                        raise Fail "Unsupported WaitForMultipleObjects\
                                   \ functionality"
@@ -400,7 +404,20 @@
                     (fn () => F"Timer.create"[A bool manual, A (opt str) name])
                     F_win_CreateWaitableTimer.f' (null, toCBool manual, n'))
       val close = ptrToBool "Timer.close" F_win_CloseHandle.f'
-      val set = undefined
+      fun mk name toDue {timer, due, period} = let
+         val due' = toDue o Int64.fromLarge
+                               |< LargeInt.quot (Time.toNanoseconds due, 100)
+         val period' =
+             case period of
+                NONE => 0
+              | SOME p => Int32.fromLarge (Time.toMilliseconds p)
+      in
+         raiseOnFalse
+            (fn () => F name [A ptr timer, A time due, A (opt time) period])
+            F_win_SetWaitableTimer.f' (timer, due', period', 0)
+      end
+      val setAbs = mk "Timer.setAbs" id
+      val setRel = mk "Timer.setRel" op ~
       val cancel = ptrToBool "Timer.cancel" F_win_CancelWaitableTimer.f'
       val toWait = id
    end

Modified: mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-02-28 13:52:11 UTC (rev 5364)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-02-28 15:27:02 UTC (rev 5365)
@@ -40,8 +40,8 @@
         | OBJECT of 'a
         | TIMEOUT
 
-      val any : (t * 'a) List.t -> Real.t -> 'a result
-      val all : (t * 'a) List.t -> Real.t -> 'a result
+      val any : (t * 'a) List.t -> Time.time Option.t -> 'a result
+      val all : (t * 'a) List.t -> Time.time Option.t -> 'a result
    end
 
    structure Semaphore : sig
@@ -63,7 +63,12 @@
       type t
       val create : {manual : Bool.t, name : String.t Option.t} -> t
       val close : t Effect.t
-      val set : {timer : t, due : Int64.t, period : Int32.t} Effect.t
+      val setAbs : {timer : t,
+                    due : Time.time,
+                    period : Time.time Option.t} Effect.t
+      val setRel : {timer : t,
+                    due : Time.time,
+                    period : Time.time Option.t} Effect.t
       val cancel : t Effect.t
       val toWait : t -> Wait.t
    end

Simplification.

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

U   mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
U   mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
U   mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml

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

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-02-28 13:34:55 UTC (rev 5363)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-02-28 13:52:11 UTC (rev 5364)
@@ -59,10 +59,11 @@
     * the list.  Otherwise does nothing.
     *)
 
-   val clearWith : 'a Effect.t -> 'a t Effect.t
+   val appClear : 'a Effect.t -> 'a t UnOp.t
    (**
     * Takes all elements of the imperative list of nodes one-by-one and
-    * performs the given effect on the removed elements.
+    * performs the given effect on the removed elements.  Returns the
+    * last, and always empty, node of the remaining list.
     *)
 
    val fromList : 'a List.t -> 'a t
@@ -160,10 +161,10 @@
    fun drop t =
        ignore (take t)
 
-   fun clearWith e t =
-       case take t of
-          NONE => ()
-        | SOME x => (e x : unit ; clearWith e t)
+   fun appClear e t =
+       case get t of
+          NONE => t
+        | SOME (x, t') => (e x : unit ; t <- get t' ; appClear e t)
 
    fun foldl f x t =
        case get t of

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-28 13:34:55 UTC (rev 5363)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-28 13:52:11 UTC (rev 5364)
@@ -15,7 +15,6 @@
    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
@@ -49,19 +48,12 @@
           NONE => NONE
         | SOME (a, n) => (front := n ; SOME a)
 
-   fun filter p (q as IN {back, front}) =
-       case N.get (!front) of
-          NONE => ()
-        | SOME (v, n) => if p v then back := Node.filter p n
-                         else (front := n ; filter p q)
+   fun filter p (IN {back, front}) =
+       back := N.filter p (!front)
 
    fun filterOut p =
        filter (negate p)
 
-   fun foldClear f s q =
-       case deque q of
-          NONE => s
-        | SOME v => foldClear f (f (v, s)) q
-
-   fun appClear ef = foldClear (ef o #1) ()
+   fun appClear ef (IN {back, front}) =
+       back := N.appClear ef (!front)
 end

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml	2007-02-28 13:34:55 UTC (rev 5363)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml	2007-02-28 13:52:11 UTC (rev 5364)
@@ -46,7 +46,8 @@
          (* Theoretically speaking, it should be possible to
           * execute the following code in constant space.
           *)
-       ; V.app (N.clearWith
+       ; V.app (ignore o
+                N.appClear
                    (fn entry as (key, _) => putAt t (keyToIdx t key) entry))
                oldTable
       end

Simplification.

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

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-28 13:04:32 UTC (rev 5362)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-28 13:34:55 UTC (rev 5363)
@@ -54,8 +54,10 @@
                       case e () of
                          INL ef => lp (es & ef::efs)
                        | result => result))
-      fun once (E t) = Sum.app (fn ef => ef (Handler.new ()),
-                                Queue.enque Handler.handlers o const) (t ())
+      fun once (E t) =
+          case t () of
+             INL ef => ef (Handler.new ())
+           | INR () => ()
       fun when ? = once (on ?)
       fun each e = when (e, fn () => each e)
       fun every ? = each (on ?)

Bug fix.

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

U   mltonlib/trunk/com/ssh/misc-util/unstable/node.sml

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

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-02-28 12:37:07 UTC (rev 5361)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-02-28 13:04:32 UTC (rev 5362)
@@ -188,7 +188,8 @@
    fun filter p t =
        case get t of
           NONE => t
-        | SOME (x, t') => (if p x then () else drop t ; filter p t')
+        | SOME (x, t') =>
+          if p x then filter p t' else (t <- get t' ; filter p t)
 
    fun filterOut p = filter (negate p)
 end

Yet another test case.

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

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

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

Modified: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-28 12:32:36 UTC (rev 5360)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-28 12:37:07 UTC (rev 5361)
@@ -128,5 +128,25 @@
                  ; when (take c, eq /> 3) ; runAll ()
                 end))
 
+      (title "Async")
+
+      (test (fn () => let
+                   val v = IVar.new ()
+                   val c = SkipCh.new ()
+                   val l = ref []
+                   fun lp () =
+                       any [on (SkipCh.take c, lp o push l),
+                            on (IVar.read v, push l)]
+                in
+                   lp ()
+                 ; runAll ()
+                 ; SkipCh.send c 1 ; runAll ()
+                 ; SkipCh.send c 2
+                 ; SkipCh.send c 3
+                 ; SkipCh.send c 4 ; runAll ()
+                 ; IVar.fill v 5 ; runAll ()
+                 ; eql (!l, [5, 4, 2, 1])
+                end))
+
       $
 end

Fixed a bug.  Something tells me there must be a better implementation
technique...

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

U   mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml

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

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-28 09:55:47 UTC (rev 5359)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-28 12:32:36 UTC (rev 5360)
@@ -49,8 +49,11 @@
           NONE => NONE
         | SOME (a, n) => (front := n ; SOME a)
 
-   fun filter p (IN {back, front}) =
-       back := Node.filter p (!front)
+   fun filter p (q as IN {back, front}) =
+       case N.get (!front) of
+          NONE => ()
+        | SOME (v, n) => if p v then back := Node.filter p n
+                         else (front := n ; filter p q)
 
    fun filterOut p =
        filter (negate p)

Oops, too hasty.  The space safety thing works and the problem is
somewhere else.

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

U   mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml

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

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-28 09:44:59 UTC (rev 5358)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-28 09:55:47 UTC (rev 5359)
@@ -7,7 +7,9 @@
 (*
  * 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.
+ * 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 :> sig
    include QUEUE
@@ -33,13 +35,14 @@
    fun length (IN {front, ...}) =
        N.length (!front)
 
-   fun enque (IN {back, ...}) a = let
-      val r = !back
-      val n = N.new ()
-   in
-      N.<- (r, SOME (a, n))
+   fun enque (IN {back, ...}) =
+    fn a => let
+          val r = !back
+          val n = N.new ()
+       in
+          N.<- (r, SOME (a, n))
         ; back := n
-   end
+       end
 
    fun deque (IN {front, ...}) =
        case N.get (!front) of

Removed the space safety feature from enque, because it breaks when
multiple agents are mutating the queue at the same time.

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

U   mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml

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

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-28 09:37:05 UTC (rev 5357)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-28 09:44:59 UTC (rev 5358)
@@ -7,9 +7,7 @@
 (*
  * 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.
+ * make sense for all possible implementations of the signature.
  *)
 structure Queue :> sig
    include QUEUE
@@ -35,14 +33,13 @@
    fun length (IN {front, ...}) =
        N.length (!front)
 
-   fun enque (IN {back, ...}) =
-       fn a => let
-          val r = !back
-          val n = N.new ()
-       in
-          N.<- (r, SOME (a, n))
+   fun enque (IN {back, ...}) a = let
+      val r = !back
+      val n = N.new ()
+   in
+      N.<- (r, SOME (a, n))
         ; back := n
-       end
+   end
 
    fun deque (IN {front, ...}) =
        case N.get (!front) of

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

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

A Mailbox test.
----------------------------------------------------------------------

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

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

Modified: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 20:37:22 UTC (rev 5354)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 21:13:03 UTC (rev 5355)
@@ -51,7 +51,7 @@
                  ; runAll () ; eq (!n, 2)
                 end))
 
-      (title "Async.Event.choose")
+      (title "Async.choose")
 
       (test (fn () => let
                    open Mailbox
@@ -71,6 +71,25 @@
                  ; runAll () ; eq (!n, 3)
                 end))
 
+      (title "Async.Mailbox")
+
+      (test (fn () => let
+                   open Mailbox
+                   val b = new ()
+                   val s = ref []
+                in
+                   send b 1
+                 ; send b 2
+                 ; when (take b, push s) ; runAll ()
+                 ; when (take b, push s)
+                 ; when (take b, push s) ; runAll ()
+                 ; send b 3
+                 ; send b 4
+                 ; send b 5
+                 ; every (take b, push s) ; runAll ()
+                 ; eql (!s, [5,4,3,2,1])
+                end))
+
       (title "Async.Multicast")
 
       (test (fn () => let

A few useful additions.
----------------------------------------------------------------------

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/misc-util/unstable/node.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-02-27 15:45:43 UTC (rev 5353)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-02-27 20:37:22 UTC (rev 5354)
@@ -88,6 +88,21 @@
     * recursively.
     *)
 
+   val length : 'a t -> Int.t
+   (** Returns the length of the given imperative list. *)
+
+   val filter : 'a UnPr.t -> 'a t Effect.t
+   (**
+    * Drops all nodes from the imperative list whose elements do not
+    * satisfy the given predicate.
+    *)
+
+   val filterOut : 'a UnPr.t -> 'a t Effect.t
+   (**
+    * Drops all nodes from the imperative list whose elements satisfy the
+    * given predicate.
+    *)
+
    val foldl : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
    (**
     * Folds the imperative lists with the given function and starting
@@ -165,4 +180,13 @@
           NONE => INL t
         | SOME (x, t') =>
           if p x then INR t else find p t'
+
+   fun length n = foldl (1 <\ op + o #2) 0 n
+
+   fun filter p t =
+       case get t of
+          NONE => ()
+        | SOME (x, t') => (if p x then () else drop t ; filter p t')
+
+   fun filterOut p = filter (negate p)
 end

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig	2007-02-27 15:45:43 UTC (rev 5353)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig	2007-02-27 20:37:22 UTC (rev 5354)
@@ -15,6 +15,8 @@
 
    val isEmpty : 'a t UnPr.t
 
+   val length : 'a t -> Int.t
+
    val deque : 'a t -> 'a Option.t
    val enque : 'a t -> 'a Effect.t
 

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-27 15:45:43 UTC (rev 5353)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-27 20:37:22 UTC (rev 5354)
@@ -25,6 +25,9 @@
    fun isEmpty (IN {front, ...}) =
        not (isSome (N.get (!front)))
 
+   fun length (IN {front, ...}) =
+       N.length (!front)
+
    fun enque (IN {back, ...}) =
        fn a => let
           val r = !back

Added toList.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/misc-util/unstable/node.sml

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

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-02-27 15:44:27 UTC (rev 5352)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-02-27 15:45:43 UTC (rev 5353)
@@ -68,6 +68,12 @@
    val fromList : 'a List.t -> 'a t
    (** Constructs an imperative list from a functional list. *)
 
+   val toList : 'a t -> 'a List.t
+   (**
+    * Returns a functional list containing the same elements as the imperative
+    * list.
+    *)
+
    val app : 'a Effect.t -> 'a t Effect.t
    (**
     * Applies the given effect to all elements of the imperative list.
@@ -148,6 +154,9 @@
         | SOME (y, t) =>
           foldl f (f (y, x)) t
 
+   fun toList n =
+       rev (foldl op :: [] n)
+
    fun app e =
        foldl (e o #1) ()
 

Added SkipCh (skip channels) and a non-exhaustive ad hoc test.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
U   mltonlib/trunk/com/ssh/async/unstable/public/async.sig
U   mltonlib/trunk/com/ssh/async/unstable/test/async.sml

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

Modified: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-27 14:13:59 UTC (rev 5351)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-27 15:44:27 UTC (rev 5352)
@@ -116,8 +116,17 @@
              case Queue.dequeWhile Handler.scheduled ts of
                 NONE => st := SOME v
               | SOME h => Handler.schedule v h
+      fun send (T {ts, 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
    end
 
+   structure SkipCh = MVar
+
    structure Multicast = struct
       datatype 'a n = N of 'a * 'a n IVar.t
       datatype 'a t = T of 'a n IVar.t Ref.t

Modified: mltonlib/trunk/com/ssh/async/unstable/public/async.sig
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/public/async.sig	2007-02-27 14:13:59 UTC (rev 5351)
+++ mltonlib/trunk/com/ssh/async/unstable/public/async.sig	2007-02-27 15:44:27 UTC (rev 5352)
@@ -94,6 +94,13 @@
       val give : 'a t -> 'a -> Unit.t Event.t
    end
 
+   structure SkipCh : sig
+      type 'a t
+      val new : 'a t Thunk.t
+      val take : 'a t -> 'a Event.t
+      val send : 'a t -> 'a Effect.t
+   end
+
    structure IVar : sig
       type 'a t
       val new : 'a t Thunk.t

Modified: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 14:13:59 UTC (rev 5351)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 15:44:27 UTC (rev 5352)
@@ -96,5 +96,18 @@
                  ; eql (!s3, [4])
                 end))
 
+      (title "Async.SkipCh")
+
+      (test (fn () => let
+                   open SkipCh
+                   val c = new ()
+                in
+                   send c 1
+                 ; when (take c, eq /> 1) ; runAll ()
+                 ; send c 2
+                 ; send c 3
+                 ; when (take c, eq /> 3) ; runAll ()
+                end))
+
       $
 end

Extended Option with the collate function.

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

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/option.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/data/option.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/option.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/option.sml	2007-02-27 13:16:50 UTC (rev 5350)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/option.sml	2007-02-27 14:13:59 UTC (rev 5351)
@@ -8,4 +8,10 @@
    open Option
    val isNone = fn NONE   => true
                  | SOME _ => false
+
+   fun collate cmp = fn (NONE, NONE)       => EQUAL
+                      | (SOME _, NONE)     => GREATER
+                      | (NONE, SOME _)     => LESS
+                      | (SOME x1, SOME x2) => cmp (x1, x2) 
+
 end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/data/option.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/data/option.sig	2007-02-27 13:16:50 UTC (rev 5350)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/data/option.sig	2007-02-27 14:13:59 UTC (rev 5351)
@@ -13,4 +13,11 @@
 
    val isNone : 'a t UnPr.t
    (** Returns {true} if given option is {NONE}; otherwise returns {false}. *)
+
+   val collate : 'a Cmp.t -> 'a t Cmp.t
+   (** 
+     * Returns {EQUAL} if given {(NONE,NONE)}; {GREATER} if given 
+     * {(SOME _, NONE)}; {LESS} if given {(NONE, SOME _)}; for 
+     * {(SOME _, SOME _)} it uses the provided comparison function. *)
+
 end

An unspecified total order on wait(able) objects.

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

U   mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
U   mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig

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

Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-02-27 12:20:35 UTC (rev 5349)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml	2007-02-27 13:16:50 UTC (rev 5350)
@@ -312,6 +312,8 @@
    structure Wait = struct
       type t = C.voidptr
 
+      val compare = C.Ptr.compare'
+
       datatype 'a result
         = ABANDONED of 'a
         | OBJECT of 'a

Modified: mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-02-27 12:20:35 UTC (rev 5349)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig	2007-02-27 13:16:50 UTC (rev 5350)
@@ -33,6 +33,8 @@
    structure Wait : sig
       type t
 
+      val compare : t Cmp.t
+
       datatype 'a result
         = ABANDONED of 'a
         | OBJECT of 'a

One more ad hoc test.
----------------------------------------------------------------------

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

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

Modified: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 12:15:23 UTC (rev 5348)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 12:20:35 UTC (rev 5349)
@@ -4,6 +4,9 @@
  * See the LICENSE file or http://mlton.org/License for details.
  *)
 
+(*
+ * Ad hoc tests against the Async module.
+ *)
 val () = let
    open UnitTest Async Async.Handler
    fun eq (ac, ex) = verifyEq Type.int {actual = ac, expect = ex}
@@ -16,31 +19,51 @@
       (title "Async.IVar")
 
       (test (fn () => let
-                   val v = IVar.new ()
+                   open IVar
+                   val v = new ()
                    val n = ref 0
                 in
-                   IVar.fill v ()
-                 ; full (IVar.fill v)
-                 ; when (IVar.read v, inc n) ; eq (!n, 0)
+                   fill v ()
+                 ; full (fill v)
+                 ; when (read v, inc n) ; eq (!n, 0)
                  ; runAll () ; eq (!n, 1)
-                 ; full (IVar.fill v)
-                 ; when (IVar.read v, inc n) ; eq (!n, 1)
+                 ; full (fill v)
+                 ; when (read v, inc n) ; eq (!n, 1)
                  ; runAll () ; eq (!n, 2)
                  ; runAll () ; eq (!n, 2)
                 end))
 
+      (title "Async.MVar")
+
+      (test (fn () => let
+                   open MVar
+                   val v = new ()
+                   val n = ref 0
+                in
+                   fill v ()
+                 ; full (fill v)
+                 ; when (take v, inc n) ; eq (!n, 0)
+                 ; runAll () ; eq (!n, 1)
+                 ; fill v ()
+                 ; full (fill v)
+                 ; when (take v, inc n) ; eq (!n, 1)
+                 ; runAll () ; eq (!n, 2)
+                 ; runAll () ; eq (!n, 2)
+                end))
+
       (title "Async.Event.choose")
 
       (test (fn () => let
-                   val b1 = Mailbox.new ()
-                   val b2 = Mailbox.new ()
+                   open Mailbox
+                   val b1 = new ()
+                   val b2 = new ()
                    val n = ref 0
-                   val e = choose [on (Mailbox.take b1, inc n),
-                                   on (Mailbox.take b2, inc n)]
+                   val e = choose [on (take b1, inc n),
+                                   on (take b2, inc n)]
                 in
-                   Mailbox.send b1 ()
-                 ; Mailbox.send b1 ()
-                 ; Mailbox.send b2 ()
+                   send b1 ()
+                 ; send b1 ()
+                 ; send b2 ()
                  ; once e ; eq (!n, 0)
                  ; runAll () ; eq (!n, 1)
                  ; each e ; eq (!n, 1)

Moved values from the Event substructure to the top-level of the ASYNC
signature for convenience.

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

U   mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
U   mltonlib/trunk/com/ssh/async/unstable/public/async.sig
U   mltonlib/trunk/com/ssh/async/unstable/test/async.sml

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

Modified: mltonlib/trunk/com/ssh/async/unstable/detail/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-27 10:04:30 UTC (rev 5347)
+++ mltonlib/trunk/com/ssh/async/unstable/detail/async.sml	2007-02-27 12:15:23 UTC (rev 5348)
@@ -28,9 +28,9 @@
    end
 
    structure Event = struct
-      datatype 'a t = T of ('a Handler.t Effect.t, 'a) Sum.t Thunk.t
-      fun on (T t, f) =
-          T (fn () =>
+      datatype 'a t = E of ('a Handler.t Effect.t, 'a) Sum.t Thunk.t
+      fun on (E t, f) =
+          E (fn () =>
                 INL (fn h => let
                            val h = Handler.prepend f h
                         in
@@ -40,7 +40,7 @@
                               Handler.schedule () (Handler.prepend (const v) h)
                         end))
       fun choose es =
-          T (fn () =>
+          E (fn () =>
                 recur (es & []) (fn lp =>
                    fn [] & efs =>
                       INL (fn h =>
@@ -50,11 +50,11 @@
                                     (ef h
                                    ; if Handler.scheduled h then ()
                                      else lp efs)))
-                    | T e::es & efs =>
+                    | E e::es & efs =>
                       case e () of
                          INL ef => lp (es & ef::efs)
                        | result => result))
-      fun once (T t) = Sum.app (fn ef => ef (Handler.new ()),
+      fun once (E t) = Sum.app (fn ef => ef (Handler.new ()),
                                 Queue.enque Handler.handlers o const) (t ())
       fun when ? = once (on ?)
       fun each e = when (e, fn () => each e)
@@ -63,23 +63,25 @@
       val all = each o choose
    end
 
+   open Event
+
    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 ()}
       fun take (T {gs, ts}) =
-          Event.T (fn () =>
-                      case Queue.dequeWhile (Handler.scheduled o #handler) gs of
-                         NONE => INL (Queue.enque ts)
-                       | SOME {handler, value} =>
-                         (Handler.schedule () handler ; INR value))
+          E (fn () =>
+                case Queue.dequeWhile (Handler.scheduled o #handler) gs of
+                   NONE => INL (Queue.enque ts)
+                 | SOME {handler, value} =>
+                   (Handler.schedule () handler ; INR value))
       fun give (T {ts, gs}) v =
-          Event.T (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}))
+          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
    end
 
@@ -89,10 +91,10 @@
       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}) =
-          Event.T (fn () =>
-                      case !st of
-                         SOME v => INR v
-                       | NONE => INL (Queue.enque rs))
+          E (fn () =>
+                case !st of
+                   SOME v => INR v
+                 | NONE => INL (Queue.enque rs))
       fun fill (T {rs, st}) v =
           case !st of
              SOME _ => raise Full
@@ -103,10 +105,10 @@
       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}) =
-          Event.T (fn () =>
-                      case !st of
-                         SOME v => (st := NONE ; INR v)
-                       | NONE => INL (Queue.enque ts))
+          E (fn () =>
+                case !st of
+                   SOME v => (st := NONE ; INR v)
+                 | NONE => INL (Queue.enque ts))
       fun fill (T {ts, st}) v =
           case !st of
              SOME _ => raise Full
@@ -123,10 +125,10 @@
       fun taker (T st) = let
          val ch = Ch.new ()
          fun lp st =
-             Event.when (IVar.read st,
-                         fn N (v, st) =>
-                            Event.when (Ch.give ch v,
-                                        fn () => lp st))
+             when (IVar.read st,
+                   fn N (v, st) =>
+                      when (Ch.give ch v,
+                            fn () => lp st))
       in
          lp (!st) ; Ch.take ch
       end

Modified: mltonlib/trunk/com/ssh/async/unstable/public/async.sig
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/public/async.sig	2007-02-27 10:04:30 UTC (rev 5347)
+++ mltonlib/trunk/com/ssh/async/unstable/public/async.sig	2007-02-27 12:15:23 UTC (rev 5348)
@@ -27,53 +27,54 @@
 
    structure Event : sig
       type 'a t
+      (** The type of asynchronous events. *)
+   end
 
-      (** == Combinators == *)
+   (** == Combinators == *)
 
-      val on : 'a t * ('a -> 'b) -> 'b t
-      (**
-       * Creates an event that acts like the given event and also executes
-       * the given function on the event value when the created event is
-       * committed.
-       *)
+   val on : 'a Event.t * ('a -> 'b) -> 'b Event.t
+   (**
+    * Creates an event that acts like the given event and also executes
+    * the given function on the event value when the created event is
+    * committed.
+    *)
 
-      val choose : 'a t List.t -> 'a t
-      (**
-       * Creates an event that chooses, in an unspecified manner, an
-       * occured event from the given list of events to commit.
-       *)
+   val choose : 'a Event.t List.t -> 'a Event.t
+   (**
+    * Creates an event that chooses, in an unspecified manner, an occured
+    * event from the given list of events to commit.
+    *)
 
-      (** == Handling Events == *)
+   (** == Handling Events == *)
 
-      val once : Unit.t t Effect.t
-      (**
-       * Commit to the given event once when it occurs.  The handlers
-       * attached to a committed event are executed when {Handler.runAll}
-       * is called.
-       *)
+   val once : Unit.t Event.t Effect.t
+   (**
+    * Commit to the given event once when it occurs.  The handlers
+    * attached to a committed event are executed when {Handler.runAll} is
+    * called.
+    *)
 
-      (** == Utilities == *)
+   (** == Utilities == *)
 
-      val each : Unit.t t Effect.t
-      (**
-       * Commit to the given event each time it occurs.  {each} can be
-       * implemented as
-       *
-       *> fun each e = when (e, fn () => each e)
-       *)
+   val each : Unit.t Event.t Effect.t
+   (**
+    * Commit to the given event each time it occurs.  {each} can be
+    * implemented as
+    *
+    *> fun each e = when (e, fn () => each e)
+    *)
 
-      val when : ('a t * 'a Effect.t) Effect.t
-      (** {when (e, h) = once (on (e, h))} *)
+   val when : ('a Event.t * 'a Effect.t) Effect.t
+   (** {when (e, h) = once (on (e, h))} *)
 
-      val every : ('a t * 'a Effect.t) Effect.t
-      (** {every (e, h) = each (on (e, h))} *)
+   val every : ('a Event.t * 'a Effect.t) Effect.t
+   (** {every (e, h) = each (on (e, h))} *)
 
-      val any : Unit.t t List.t Effect.t
-      (** {any = once o choose} *)
+   val any : Unit.t Event.t List.t Effect.t
+   (** {any = once o choose} *)
 
-      val all : Unit.t t List.t Effect.t
-      (** {all = each o choose} *)
-   end
+   val all : Unit.t Event.t List.t Effect.t
+   (** {all = each o choose} *)
 
    (** == Communication Mechanisms ==
     *

Modified: mltonlib/trunk/com/ssh/async/unstable/test/async.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 10:04:30 UTC (rev 5347)
+++ mltonlib/trunk/com/ssh/async/unstable/test/async.sml	2007-02-27 12:15:23 UTC (rev 5348)
@@ -5,7 +5,7 @@
  *)
 
 val () = let
-   open UnitTest Async Async.Event Async.Handler
+   open UnitTest Async Async.Handler
    fun eq (ac, ex) = verifyEq Type.int {actual = ac, expect = ex}
    fun eql (ac, ex) = verifyEq (Type.list Type.int) {actual = ac, expect = ex}
    val full = verifyFailsWith (fn Full => true | _ => false)

Ignore generated directory.
----------------------------------------------------------------------

_U  mltonlib/trunk/com/ssh/async/unstable/

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


Property changes on: mltonlib/trunk/com/ssh/async/unstable
___________________________________________________________________
Name: svn:ignore
   + generated

Added foldClear.
----------------------------------------------------------------------

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/misc-util/unstable/queue.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig	2007-02-27 08:02:20 UTC (rev 5345)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig	2007-02-27 10:03:04 UTC (rev 5346)
@@ -18,5 +18,6 @@
    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 08:02:20 UTC (rev 5345)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-02-27 10:03:04 UTC (rev 5346)
@@ -39,8 +39,10 @@
           NONE => NONE
         | SOME (a, n) => (front := n ; SOME a)
 
-   fun appClear ef q =
+   fun foldClear f s q =
        case deque q of
-          NONE => ()
-        | SOME v => (ef v : Unit.t ; appClear ef q)
+          NONE => s
+        | SOME v => foldClear f (f (v, s)) q
+
+   fun appClear ef = foldClear (ef o #1) ()
 end