[MLton-commit] r5200

Vesa Karvonen vesak at mlton.org
Thu Feb 15 05:20:06 PST 2007


Refactored CeeCache to a MkIntObjCache (INT_OBJ) functor and a default
instantiation named PtrCache.

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

D   mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache-test.sml
D   mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache.sml
A   mltonlib/trunk/com/ssh/misc-util/unstable/int-obj.sig
U   mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb
A   mltonlib/trunk/com/ssh/misc-util/unstable/mk-int-obj-cache.fun
A   mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache-test.sml
A   mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache.sml
U   mltonlib/trunk/com/ssh/misc-util/unstable/test.mlb

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

Deleted: mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache-test.sml	2007-02-15 11:59:28 UTC (rev 5199)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache-test.sml	2007-02-15 13:20:05 UTC (rev 5200)
@@ -1,38 +0,0 @@
-(* 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.
- *)
-
-val () = let
-   open Type UnitTest
-   val notFound = verifyFailsWith (fn CeeCache.NotFound => true | _ => false)
-   fun eq (e, a) = verifyEq int {actual = a, expect = e}
-in
-   unitTests
-      (title "CeeCache")
-
-      (test (fn () => let
-                   open CeeCache
-                   val c = new ()
-                   val () = eq (0, size c)
-                   val k5 = put c 5
-                   val () = eq (1, size c)
-                   val k2 = put c 2
-                   val () = (eq (2, size c)
-                           ; eq (5, use c k5)
-                           ; notFound (fn () => get c k5)
-                           ; eq (1, size c))
-                   val k3 = put c 3
-                   val () = (eq (2, use c k2)
-                           ; notFound (fn () => use c k2)
-                           ; eq (1, size c)
-                           ; eq (3, use c k3)
-                           ; notFound (fn () => get c k3)
-                           ; eq (0, size c))
-                in
-                   ()
-                end))
-
-      $
-end

Deleted: mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache.sml	2007-02-15 11:59:28 UTC (rev 5199)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache.sml	2007-02-15 13:20:05 UTC (rev 5200)
@@ -1,85 +0,0 @@
-(* 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 CeeCache :> CACHE where type Key.t = C.voidptr = struct
-   structure Key = struct
-      type t = C.voidptr
-
-      val unused = ref [] (* XXX free these at some point *)
-      fun new () =
-          case List.pop unused of
-             SOME v => v
-           | NONE => C.Ptr.inject' (C.Ptr.|&! (C.new' C.S.sint))
-      val free = unused <\ List.push
-      val get = C.Get.sint' o C.Ptr.|*! o C.Ptr.cast'
-      fun set k = C.Ptr.|*! (C.Ptr.cast' k) <\ C.Set.sint'
-   end
-
-   datatype 'a t =
-      IN of {size : Int.t Ref.t,
-             table : {key : Key.t, value : 'a} Option.t Array.t Ref.t}
-   fun g s (IN r) = ! (s r)
-   fun set s (IN r) v = s r := v
-
-   exception NotFound
-
-   fun size c = g#size c
-
-   fun sub c i = valOf (Array.sub (g#table c, i))
-   fun update c (i, v) = Array.update (g#table c, i, v)
-
-   fun new () = IN {size = ref 0, table = ref (Array.tabulate (0, undefined))}
-
-   fun ensureCapacity (IN {size, table}) reqCap = let
-      val curCap = Array.length (!table)
-   in
-      if reqCap <= curCap
-      then ()
-      else table := Array.tabulate
-                       (Int.max (reqCap, curCap*2+1),
-                        fn i => if i < !size
-                                then Array.sub (!table, i)
-                                else NONE)
-   end
-
-   fun putWith c k2v = let
-      val n = size c
-      val k = Key.new ()
-   in
-      (ensureCapacity c (n+1)
-     ; let val v = k2v k
-       in set#size c (n+1)
-        ; update c (n, SOME {key = k, value = v})
-        ; Key.set k n
-        ; (k, v)
-       end)
-      handle e => (Key.free k ; raise e)
-   end
-
-   fun put c = #1 o putWith c o const
-   fun get c k = let
-      val i = Key.get k
-   in
-      if size c <= i then raise NotFound else let
-         val {value, key} = sub c i
-      in
-         if k <> key then raise NotFound else value
-      end
-   end
-   fun rem c k = let
-      val n = size c - 1
-      val i = Key.get k
-      val r = sub c n
-   in
-      if n < i orelse #key (sub c i) <> k then raise NotFound else ()
-    ; Key.free k
-    ; update c (i, SOME r)
-    ; Key.set (#key r) i
-    ; update c (n, NONE)
-    ; set#size c n
-   end
-   fun use c k = get c k before rem c k
-end

Added: mltonlib/trunk/com/ssh/misc-util/unstable/int-obj.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/int-obj.sig	2007-02-15 11:59:28 UTC (rev 5199)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/int-obj.sig	2007-02-15 13:20:05 UTC (rev 5200)
@@ -0,0 +1,14 @@
+(* 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.
+ *)
+
+(** A mutable integer object holds an integer value. *)
+signature INT_OBJ = sig
+   eqtype t                      (** The type of mutable integer objects. *)
+   val new : Int.t -> t          (** Allocates a new object with given value. *)
+   val discard : t Effect.t      (** Deallocates the object. *)
+   val get : t -> Int.t          (** Returns the value of the object. *)
+   val set : t -> Int.t Effect.t (** Sets the value of the object. *)
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/int-obj.sig
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb	2007-02-15 11:59:28 UTC (rev 5199)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb	2007-02-15 13:20:05 UTC (rev 5200)
@@ -42,12 +42,15 @@
    word-table.sig
    word-table.sml
 
+   int-obj.sig
+
    cache.sig
    local
       $(SML_LIB)/mlnlffi-lib/mlnlffi-lib.mlb
    in
       cache.sml
-      cee-cache.sml
+      mk-int-obj-cache.fun
+      ptr-cache.sml
    end
 
    (* SML *)

Added: mltonlib/trunk/com/ssh/misc-util/unstable/mk-int-obj-cache.fun
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/mk-int-obj-cache.fun	2007-02-15 11:59:28 UTC (rev 5199)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/mk-int-obj-cache.fun	2007-02-15 13:20:05 UTC (rev 5200)
@@ -0,0 +1,76 @@
+(* 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.
+ *)
+
+(** Makes a cache module whose keys are int objects. *)
+functor MkIntObjCache (Key : INT_OBJ) :> CACHE
+      where type Key.t = Key.t = struct
+   structure Key = Key
+
+   datatype 'a t =
+      IN of {size : Int.t Ref.t,
+             table : {key : Key.t, value : 'a} Option.t Array.t Ref.t}
+   fun gt s (IN r) = ! (s r)
+   fun st s (IN r) v = s r := v
+
+   exception NotFound
+
+   fun size c = gt#size c
+
+   fun sub c i = valOf (Array.sub (gt#table c, i))
+   fun update c (i, v) = Array.update (gt#table c, i, v)
+
+   fun new () = IN {size = ref 0, table = ref (Array.tabulate (0, undefined))}
+
+   fun realloc (IN {size, table}) newCap =
+       table := Array.tabulate
+                   (newCap,
+                    fn i => if i < !size then Array.sub (!table, i) else NONE)
+
+   fun maybeAdjustCap c reqCap = let
+      val curCap = Array.length (gt#table c)
+   in
+      if curCap   < reqCap then realloc c (Int.max (reqCap, curCap*2+1)) else
+      if reqCap*4 < curCap then realloc c (curCap div 2)                 else ()
+   end
+
+   fun putWith c k2v = let
+      val n = size c
+      val k = Key.new n
+   in
+      (maybeAdjustCap c (n+1)
+     ; let val v = k2v k
+       in st#size c (n+1)
+        ; update c (n, SOME {key = k, value = v})
+        ; (k, v)
+       end)
+      handle e => (Key.set k ~1 ; Key.discard k ; raise e)
+   end
+
+   fun put c = #1 o putWith c o const
+   fun get c k = let
+      val i = Key.get k
+   in
+      if i<0 orelse size c <= i then raise NotFound else let
+         val {value, key} = sub c i
+      in
+         if k <> key then raise NotFound else value
+      end
+   end
+   fun rem c k = let
+      val n = size c - 1
+      val i = Key.get k
+      val r = sub c n
+   in
+      if i<0 orelse n<i orelse #key (sub c i) <> k then raise NotFound else ()
+    ; Key.set k ~1 ; Key.discard k
+    ; update c (i, SOME r)
+    ; Key.set (#key r) i
+    ; update c (n, NONE)
+    ; st#size c n
+    ; maybeAdjustCap c n
+   end
+   fun use c k = get c k before rem c k
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/mk-int-obj-cache.fun
___________________________________________________________________
Name: svn:eol-style
   + native

Copied: mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache-test.sml (from rev 5199, mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache-test.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache-test.sml	2007-02-15 11:59:28 UTC (rev 5199)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache-test.sml	2007-02-15 13:20:05 UTC (rev 5200)
@@ -0,0 +1,38 @@
+(* 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.
+ *)
+
+val () = let
+   open Type UnitTest
+   val notFound = verifyFailsWith (fn PtrCache.NotFound => true | _ => false)
+   fun eq (e, a) = verifyEq int {actual = a, expect = e}
+in
+   unitTests
+      (title "PtrCache")
+
+      (test (fn () => let
+                   open PtrCache
+                   val c = new ()
+                   val () = eq (0, size c)
+                   val k5 = put c 5
+                   val () = eq (1, size c)
+                   val k2 = put c 2
+                   val () = (eq (2, size c)
+                           ; eq (5, use c k5)
+                           ; notFound (fn () => get c k5)
+                           ; eq (1, size c))
+                   val k3 = put c 3
+                   val () = (eq (2, use c k2)
+                           ; notFound (fn () => use c k2)
+                           ; eq (1, size c)
+                           ; eq (3, use c k3)
+                           ; notFound (fn () => get c k3)
+                           ; eq (0, size c))
+                in
+                   ()
+                end))
+
+      $
+end

Copied: mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache.sml (from rev 5198, mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache.sml)
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/cee-cache.sml	2007-02-15 11:37:28 UTC (rev 5198)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/ptr-cache.sml	2007-02-15 13:20:05 UTC (rev 5200)
@@ -0,0 +1,24 @@
+(* 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 PtrCache =
+   MkIntObjCache
+      (type t = C.voidptr
+       local
+          val unused = ref [] (* XXX free these at some point *)
+       in
+          fun set k = C.Ptr.|*! (C.Ptr.cast' k) <\ C.Set.sint'
+          fun new value =
+              case List.pop unused of
+                 SOME v => v
+               | NONE => let
+                    val k = C.Ptr.inject' (C.Ptr.|&! (C.new' C.S.sint))
+                 in
+                    set k value ; k
+                 end
+          val discard = unused <\ List.push
+          val get = C.Get.sint' o C.Ptr.|*! o C.Ptr.cast'
+       end)

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/test.mlb	2007-02-15 11:59:28 UTC (rev 5199)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/test.mlb	2007-02-15 13:20:05 UTC (rev 5200)
@@ -14,10 +14,10 @@
    $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
    lib.mlb
 
-   cee-cache-test.sml
    misc-test.sml
    prettier-test.sml
    promise-test.sml
+   ptr-cache-test.sml
    qc-test-example.sml
    show-test.sml
    sorted-list-test.sml




More information about the MLton-commit mailing list