[MLton-commit] r4894
Vesa Karvonen
vesak at mlton.org
Fri Dec 1 06:25:36 PST 2006
Added lazy promises.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/extended-basis/unstable/detail/promise.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm
U mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
U mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
U mltonlib/trunk/com/ssh/extended-basis/unstable/public/export.sml
A mltonlib/trunk/com/ssh/extended-basis/unstable/public/promise.sig
----------------------------------------------------------------------
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/promise.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/promise.sml 2006-12-01 12:32:07 UTC (rev 4893)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/promise.sml 2006-12-01 14:25:32 UTC (rev 4894)
@@ -0,0 +1,44 @@
+(* Copyright (C) 2006 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 Promise :> PROMISE = struct
+ datatype 'a status = LAZY of 'a t Thunk.t
+ | EAGER of (Exn.t, 'a) Sum.t
+ withtype 'a t = 'a status ref ref
+
+ fun lazy th = ref (ref (LAZY th))
+ fun eager x = ref (ref (EAGER (Sum.INR x)))
+ fun delay th = lazy (ref o ref o EAGER o (fn () => Exn.eval th))
+
+ fun replay s = Sum.sum (Exn.throw, Fn.id) s
+
+ fun force promise =
+ case !(!promise) of
+ EAGER x => replay x
+ | LAZY th => let
+ val promise' = th ()
+ in
+ case !(!promise) of
+ LAZY _ => (!promise := !(!promise')
+ ; promise := !promise'
+ ; force promise)
+ | EAGER x => replay x
+ end
+
+ fun thunk promise =
+ case !(!promise) of
+ EAGER s => Sum.sum (Fn.failing, Fn.const) s
+ | LAZY _ => fn () => force promise
+
+ fun tie s k =
+ case !(!s) of
+ EAGER _ => raise Fix.Fix
+ | LAZY _ => s := !k
+
+ fun Y ? =
+ Tie.tier (fn () => Pair.map (Fn.id, tie)
+ (Sq.mk (lazy (Fn.failing Fix.Fix)))) ?
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/promise.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm 2006-12-01 12:32:07 UTC (rev 4893)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm 2006-12-01 14:25:32 UTC (rev 4894)
@@ -44,11 +44,9 @@
../../public/sum.sig
../../public/text.sig
../../public/thunk.sig
- ../../public/tie.sig
../../public/un-op.sig
../../public/un-pr.sig
../../public/unit.sig
- ../../public/univ.sig
../../public/vector-slice.sig
../../public/vector.sig
../../public/with.sig
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm 2006-12-01 12:32:07 UTC (rev 4893)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm 2006-12-01 14:25:32 UTC (rev 4894)
@@ -8,6 +8,9 @@
group(sigs.cm)
source(-)
is
+ ../../public/promise.sig
+ ../../public/tie.sig
+ ../../public/univ.sig
../array-slice.sml
../array.sml
../bin-op.sml
@@ -29,6 +32,7 @@
../order.sml
../pair.sml
../product.sml
+ ../promise.sml
../reader.sml
../ref.sml
../smlnj/ints.sml
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb 2006-12-01 12:32:07 UTC (rev 4893)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb 2006-12-01 14:25:32 UTC (rev 4894)
@@ -177,6 +177,11 @@
detail/$(SML_COMPILER)/mono-array-slices.sml
detail/$(SML_COMPILER)/texts.sml
end
+ basis Promise = let
+ open Exn Fix Fn Products Sq Sum Tie
+ in
+ bas public/promise.sig detail/promise.sml end
+ end
open BinOp BinPr Bool Buffer
open Cmp
@@ -186,7 +191,7 @@
open List
open MonoSeqs
open Option Order
- open Products
+ open Products Promise
open Reader Ref
open Scalars Seqs Sq Sum
open Thunk Tie
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use 2006-12-01 12:32:07 UTC (rev 4893)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use 2006-12-01 14:25:32 UTC (rev 4894)
@@ -87,6 +87,7 @@
"detail/"^compiler^"/mono-arrays.sml",
"detail/"^compiler^"/mono-array-slices.sml",
"detail/"^compiler^"/texts.sml",
+ "public/promise.sig", "detail/promise.sml",
"detail/"^compiler^"/forget.use",
"public/export-"^compiler^".sml",
"public/export.sml",
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/export.sml 2006-12-01 12:32:07 UTC (rev 4893)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export.sml 2006-12-01 14:25:32 UTC (rev 4894)
@@ -34,6 +34,7 @@
signature PAIR = PAIR
signature PRODUCT = PRODUCT
signature PRODUCT_TYPE = PRODUCT_TYPE
+signature PROMISE = PROMISE
signature READER = READER
signature REAL = REAL
signature REF = REF
@@ -54,6 +55,11 @@
signature WORD = WORD
signature WRITER = WRITER
+structure Univ : UNIV = Univ
+structure Vector : VECTOR = Vector
+structure Writer : WRITER = Writer
+structure With : WITH = With
+
structure Array : ARRAY = Array
structure ArraySlice : ARRAY_SLICE = ArraySlice
structure BinOp : BIN_OP = BinOp
@@ -84,6 +90,7 @@
structure Pair : PAIR = Pair
structure Position : INTEGER = Position
structure Product : PRODUCT = Product
+structure Promise : PROMISE = Promise
structure Reader : READER = Reader
structure Real : REAL = Real
structure Ref : REF where type 'a t = 'a ref = Ref
@@ -97,14 +104,10 @@
structure UnOp : UN_OP = UnOp
structure UnPr : UN_PR = UnPr
structure Unit : UNIT = Unit
-structure Univ : UNIV = Univ
-structure Vector : VECTOR = Vector
structure VectorSlice : VECTOR_SLICE = VectorSlice
-structure With : WITH = With
structure Word : WORD = Word
structure Word8 : WORD = Word8
structure Word8Array : MONO_ARRAY = Word8Array
structure Word8ArraySlice : MONO_ARRAY_SLICE = Word8ArraySlice
structure Word8Vector : MONO_VECTOR = Word8Vector
structure Word8VectorSlice : MONO_VECTOR_SLICE = Word8VectorSlice
-structure Writer : WRITER = Writer
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/promise.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/promise.sig 2006-12-01 12:32:07 UTC (rev 4893)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/promise.sig 2006-12-01 14:25:32 UTC (rev 4894)
@@ -0,0 +1,80 @@
+(* Copyright (C) 2006 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.
+ *)
+
+(**
+ * Lazy promises.
+ *
+ * The design is based on SRFI-45 ``Primitives for Expressing Iterative Lazy
+ * Algorithms'' by André van Tonder:
+ *
+ * http://srfi.schemers.org/srfi-45/srfi-45.html
+ *
+ * The general recipe to express lazy algorithms is to
+ * - wrap all constructors with {delay (fn () => ...)},
+ * - apply {force} to arguments of destructors, and
+ * - wrap function bodies with {lazy (fn () => ...)}.
+ *)
+signature PROMISE = sig
+ type 'a t
+ (** The abstract type of promises. *)
+
+ val delay : 'a Thunk.t -> 'a t
+ (**
+ * Takes a thunk of type {'a thunk} and returns a promise of type
+ * {'a t} which at some point in the future may be asked (by the
+ * {force} procedure) to evaluate the thunk and deliver the
+ * resulting value.
+ *)
+
+ val eager : 'a -> 'a t
+ (**
+ * Takes an argument of type {'a} and returns a promise of type
+ * {'a t}. As opposed to {delay}, the argument is evaluated eagerly.
+ *
+ * Semantically, writing
+ *
+ *> eager expression
+ *
+ * is equivalent to writing
+ *
+ *> let val value = expression in delay (fn () => value) end
+ *
+ * However, the former is more efficient since it does not require
+ * unnecessary creation and evaluation of thunks. We also have the
+ * equivalence
+ *
+ *> delay (fn () => expression) = lazy (eager expression)
+ *
+ * assuming that evaluation of the expression does not raise an
+ * exception.
+ *)
+
+ val force : 'a t -> 'a
+ (**
+ * Takes a promise of type {'a t} and returns a value of type {'a}
+ * as follows: If a value of type {'a} has been computed for the
+ * promise, this value is returned. Otherwise, the promise is first
+ * evaluated, then overwritten by the obtained promise or value, and
+ * then force is again applied (iteratively) to the promise.
+ *)
+
+ val lazy : 'a t Thunk.t -> 'a t
+ (**
+ * Takes a thunk returning a promise of type {'a t} and returns a
+ * promise of type {'a t} which at some point in the future may be
+ * asked (by the {force} procedure) to evaluate the thunk and
+ * deliver the resulting promise.
+ *)
+
+ val thunk : 'a t -> 'a Thunk.t
+ (**
+ * Converts a promise into a thunk. This can be useful for working
+ * around the value restriction, for example.
+ *)
+
+ val Y : 'a t Tie.t
+ (** Fixpoint tier for promises. *)
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/public/promise.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list