[MLton-commit] r5415
Vesa Karvonen
vesak at mlton.org
Sun Mar 11 08:08:34 PST 2007
Starting to work on IPC library. Preliminary implementation of
serialization to raw-memory.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/ipc/
A mltonlib/trunk/com/ssh/ipc/unstable/
A mltonlib/trunk/com/ssh/ipc/unstable/LICENSE
A mltonlib/trunk/com/ssh/ipc/unstable/detail/
A mltonlib/trunk/com/ssh/ipc/unstable/detail/internal.mlb
A mltonlib/trunk/com/ssh/ipc/unstable/detail/ipc.sml
A mltonlib/trunk/com/ssh/ipc/unstable/detail/raw-mem.sml
A mltonlib/trunk/com/ssh/ipc/unstable/lib.mlb
A mltonlib/trunk/com/ssh/ipc/unstable/public/
A mltonlib/trunk/com/ssh/ipc/unstable/public/export.sml
A mltonlib/trunk/com/ssh/ipc/unstable/public/ipc.sig
A mltonlib/trunk/com/ssh/ipc/unstable/test/
A mltonlib/trunk/com/ssh/ipc/unstable/test/raw-mem.sml
A mltonlib/trunk/com/ssh/ipc/unstable/test.mlb
----------------------------------------------------------------------
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable
___________________________________________________________________
Name: svn:ignore
+ generated
Copied: mltonlib/trunk/com/ssh/ipc/unstable/LICENSE (from rev 5409, mltonlib/trunk/com/ssh/misc-util/unstable/LICENSE)
Added: mltonlib/trunk/com/ssh/ipc/unstable/detail/internal.mlb
===================================================================
--- mltonlib/trunk/com/ssh/ipc/unstable/detail/internal.mlb 2007-03-10 13:42:02 UTC (rev 5414)
+++ mltonlib/trunk/com/ssh/ipc/unstable/detail/internal.mlb 2007-03-11 16:08:33 UTC (rev 5415)
@@ -0,0 +1,18 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(SML_LIB)/basis/mlton.mlb
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ raw-mem.sml
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable/detail/internal.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/ipc/unstable/detail/ipc.sml
===================================================================
--- mltonlib/trunk/com/ssh/ipc/unstable/detail/ipc.sml 2007-03-10 13:42:02 UTC (rev 5414)
+++ mltonlib/trunk/com/ssh/ipc/unstable/detail/ipc.sml 2007-03-11 16:08:33 UTC (rev 5415)
@@ -0,0 +1,9 @@
+(* 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 IPC : IPC = struct
+ structure Type = RawMem.Type (* XXX hash type-indices for dynamic checking *)
+end
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable/detail/ipc.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/ipc/unstable/detail/raw-mem.sml
===================================================================
--- mltonlib/trunk/com/ssh/ipc/unstable/detail/raw-mem.sml 2007-03-10 13:42:02 UTC (rev 5414)
+++ mltonlib/trunk/com/ssh/ipc/unstable/detail/raw-mem.sml 2007-03-11 16:08:33 UTC (rev 5415)
@@ -0,0 +1,142 @@
+(* 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 RawMem :> sig
+ structure Ptr : sig
+ eqtype t
+ val null : t
+ val + : t * Word.t -> t
+ end
+
+ structure Type : sig
+ type 'a t
+
+ val size : 'a t -> Word.t
+ val alignment : 'a t -> Word.t
+
+ val iso : 'b t -> ('a, 'b) Iso.t -> 'a t
+
+ type 'a p
+ val tuple : 'a p -> 'a t
+ val T : 'a t -> 'a p
+ val *` : 'a p * 'b p -> ('a, 'b) Product.t p
+
+ type 'a s
+ val data : 'a s -> 'a t
+ val C0 : Unit.t s
+ val C1 : 'a t -> 'a s
+ val +` : 'a s * 'b s -> ('a, 'b) Sum.t s
+
+ val unit : Unit.t t
+
+ val int8 : Int8.t t
+ val int16 : Int16.t t
+ val int32 : Int32.t t
+ val int64 : Int64.t t
+
+ val word8 : Word8.t t
+ val word16 : Word16.t t
+ val word32 : Word32.t t
+ val word64 : Word64.t t
+
+ val real32 : Real32.t t
+ val real64 : Real64.t t
+ end
+
+ val get : 'a Type.t -> Ptr.t -> 'a
+ val set : 'a Type.t -> Ptr.t -> 'a Effect.t
+end = struct
+ structure Word = struct
+ open Word
+ fun align (w, a) = (w + a - 0w1) andb ~a
+ end
+
+ structure Ptr = struct
+ open MLton.Pointer
+ val op + = MLton.Pointer.add
+ end
+
+ structure Type = struct
+ datatype 'a t =
+ I of {sz : Word.t, al : Word.t, rd : Ptr.t -> 'a,
+ wr : Ptr.t -> 'a Effect.t}
+
+ fun size (I {sz, ...}) = sz
+ fun alignment (I {al, ...}) = al
+ fun get (I {rd, ...}) = rd
+ fun set (I {wr, ...}) = wr
+
+ fun iso (I {sz, al, rd, wr}) (a2b, b2a) =
+ I {sz = sz, al = al, rd = b2a o rd, wr = fn a => wr a o a2b}
+
+ local
+ open Ptr
+
+ fun R get a = get (a, 0)
+ fun W set a v = set (a, 0, v)
+ in
+ val unit = I {sz = 0w0, al = 0w1, rd = const (), wr = const ignore}
+
+ val int8 = I {sz = 0w1, al = 0w1, rd = R getInt8, wr = W setInt8}
+ val int16 = I {sz = 0w2, al = 0w2, rd = R getInt16, wr = W setInt16}
+ val int32 = I {sz = 0w4, al = 0w4, rd = R getInt32, wr = W setInt32}
+ val int64 = I {sz = 0w8, al = 0w8, rd = R getInt64, wr = W setInt64}
+
+ val word8 = I {sz = 0w1, al = 0w1, rd = R getWord8, wr = W setWord8}
+ val word16 = I {sz = 0w2, al = 0w2, rd = R getWord16, wr = W setWord16}
+ val word32 = I {sz = 0w4, al = 0w4, rd = R getWord32, wr = W setWord32}
+ val word64 = I {sz = 0w8, al = 0w8, rd = R getWord64, wr = W setWord64}
+
+ val real32 = I {sz = 0w4, al = 0w4, rd = R getReal32, wr = W setReal32}
+ val real64 = I {sz = 0w8, al = 0w8, rd = R getReal64, wr = W setReal64}
+ end
+
+ type 'a p = 'a t
+ fun tuple (I {sz, al, rd, wr}) =
+ I {sz = Word.align (sz, al), al = al, rd = rd, wr = wr}
+ val T = id
+ fun (I {sz=aS,al=aA,rd=aR,wr=aW}) *` (I {sz=bS,al=bA,rd=bR,wr=bW}) = let
+ val d = Word.align (aS, bA)
+ in
+ I {sz = d+bS, al = Word.max (aA, bA),
+ rd = fn p => aR p & bR (Ptr.+ (p, d)),
+ wr = fn p => fn a & b => (aW p a ; bW (Ptr.+ (p, d)) b)}
+ end
+
+ datatype 'a s =
+ S of {n : Int32.t, sz : Word.t, al : Word.t,
+ rd : (Ptr.t -> 'a) Effect.t Effect.t,
+ wr : Word.t * Int32.t -> 'a -> Ptr.t Effect.t}
+ val tag = int32
+ fun data (S {n, sz, al, rd, wr}) = let
+ val d = Word.align (size tag, al)
+ val al = Word.max (al, alignment tag)
+ val rds = Array.array (n, undefined)
+ val i = ref 0
+ in
+ rd (fn rd => (Array.update (rds, !i, rd) ; i := !i+1))
+ ; I {sz = Word.align (sz + d, al), al = al, wr = flip (wr (d, 0)),
+ rd = fn a => Array.sub (rds, get tag a) (Ptr.+ (a, d))}
+ end
+ val C0 = S {n = 1, sz = 0w0, al = 0w1, rd = pass (const ()),
+ wr = fn (_, i) => fn () => fn a => set tag a i}
+ fun C1 (I {sz, al, rd, wr}) =
+ S {n = 1, sz = sz, al = al, rd = pass rd,
+ wr = fn (d, i) => fn v => fn a =>
+ (set tag a i ; wr (Ptr.+ (a, d)) v)}
+ fun (S {n = aN, sz = aS, al = aA, rd = aR, wr = aW}) +`
+ (S {n = bN, sz = bS, al = bA, rd = bR, wr = bW}) = let
+ fun R r i s = r (fn r => s (i o r))
+ in
+ S {n = aN + bN, sz = Word.max (aS, bS), al = Word.max (aA, bA),
+ rd = fn s => (R aR INL s ; R bR INR s),
+ wr = fn (d, i) => Sum.sum (aW (d, i), bW (d, i + aN))}
+ end
+ end
+
+ val get = Type.get
+ val set = Type.set
+end
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable/detail/raw-mem.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/ipc/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/ipc/unstable/lib.mlb 2007-03-10 13:42:02 UTC (rev 5414)
+++ mltonlib/trunk/com/ssh/ipc/unstable/lib.mlb 2007-03-11 16:08:33 UTC (rev 5415)
@@ -0,0 +1,25 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(SML_LIB)/basis/mlton.mlb
+
+ detail/internal.mlb
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ local
+ public/ipc.sig
+ detail/ipc.sml
+ in
+ public/export.sml
+ end
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable/lib.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/ipc/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/ipc/unstable/public/export.sml 2007-03-10 13:42:02 UTC (rev 5414)
+++ mltonlib/trunk/com/ssh/ipc/unstable/public/export.sml 2007-03-11 16:08:33 UTC (rev 5415)
@@ -0,0 +1,9 @@
+(* 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.
+ *)
+
+signature IPC = IPC
+
+structure IPC : IPC = IPC
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable/public/export.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/ipc/unstable/public/ipc.sig
===================================================================
--- mltonlib/trunk/com/ssh/ipc/unstable/public/ipc.sig 2007-03-10 13:42:02 UTC (rev 5414)
+++ mltonlib/trunk/com/ssh/ipc/unstable/public/ipc.sig 2007-03-11 16:08:33 UTC (rev 5415)
@@ -0,0 +1,54 @@
+(* 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.
+ *)
+
+(**
+ * Inter Process Communication library.
+ *)
+signature IPC = sig
+ (**
+ * Type indices for IPC. Only bounded-size data is allowed for
+ * efficiency and simplicity.
+ *)
+ structure Type : sig
+ type 'a t
+
+ (** == User Defined Types == *)
+
+ val iso : 'b t -> ('a, 'b) Iso.t -> 'a t
+
+ (** == Products == *)
+
+ type 'a p
+ val tuple : 'a p -> 'a t
+ val T : 'a t -> 'a p
+ val *` : 'a p * 'b p -> ('a, 'b) Product.t p
+
+ (** == Sums == *)
+
+ type 'a s
+ val data : 'a s -> 'a t
+ val C0 : Unit.t s
+ val C1 : 'a t -> 'a s
+ val +` : 'a s * 'b s -> ('a, 'b) Sum.t s
+
+ (** == Primitive Types == *)
+
+ val unit : Unit.t t
+
+ val int8 : Int8.t t
+ val int16 : Int16.t t
+ val int32 : Int32.t t
+ val int64 : Int64.t t
+
+ val word8 : Word8.t t
+ val word16 : Word16.t t
+ val word32 : Word32.t t
+ val word64 : Word64.t t
+
+ val real32 : Real32.t t
+ val real64 : Real64.t t
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable/public/ipc.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/ipc/unstable/test/raw-mem.sml
===================================================================
--- mltonlib/trunk/com/ssh/ipc/unstable/test/raw-mem.sml 2007-03-10 13:42:02 UTC (rev 5414)
+++ mltonlib/trunk/com/ssh/ipc/unstable/test/raw-mem.sml 2007-03-11 16:08:33 UTC (rev 5415)
@@ -0,0 +1,58 @@
+(* 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 UnitTest RawMem.Type
+
+ exception OutOfMem
+
+ local
+ val malloc = _import "malloc" : Word.t -> RawMem.Ptr.t ;
+ val free = _import "free" : RawMem.Ptr.t Effect.t ;
+
+ fun alloc s = let
+ val p = malloc s
+ in
+ if RawMem.Ptr.null = p then raise OutOfMem else p
+ end
+ in
+ fun withMem s = With.around (fn () => alloc s) free
+ end
+in
+ unitTests
+ (title "RawMem")
+
+ (test (fn () => let
+ datatype t = A
+ | B of Int8.t * Int8.t * Word16.t
+ | C of Word32.t
+ val t =
+ iso (data (C0
+ +` C1 (tuple (T int8 *` T int8 *` T word16))
+ +` C1 word32))
+ (fn A => INL (INL ())
+ | B (i8, i8', w16) => INL (INR (i8 & i8' & w16))
+ | C w32 => INR w32,
+ fn INL (INL ()) => A
+ | INL (INR (i8 & i8' & w16)) => B (i8, i8', w16)
+ | INR w32 => C w32)
+ in
+ verifyTrue (size t = 0w8)
+ ; With.for
+ (withMem (size t))
+ (fn m => let
+ fun tst v =
+ verifyTrue (v = (RawMem.set t m v
+ ; RawMem.get t m))
+ in
+ tst A
+ ; tst (B (0x12, 0x34, 0wx5678))
+ ; tst (C 0wxFEDCBA98)
+ end)
+ end))
+
+ $
+end
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable/test/raw-mem.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/ipc/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/ipc/unstable/test.mlb 2007-03-10 13:42:02 UTC (rev 5414)
+++ mltonlib/trunk/com/ssh/ipc/unstable/test.mlb 2007-03-11 16:08:33 UTC (rev 5415)
@@ -0,0 +1,21 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/misc-util/unstable/unit-test.mlb
+
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/misc-util/unstable/lib.mlb
+
+ lib.mlb
+
+ detail/internal.mlb
+
+ ann "allowFFI true" in
+ test/raw-mem.sml
+ end
+in
+end
Property changes on: mltonlib/trunk/com/ssh/ipc/unstable/test.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list