[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