[MLton-devel] cvs commit: MLton.Finalizable
Stephen Weeks
sweeks@users.sourceforge.net
Thu, 15 May 2003 13:12:31 -0700
sweeks 03/05/15 13:12:30
Modified: basis-library/libs build
basis-library/mlton mlton.sig mlton.sml
benchmark benchmark-stubs.cm
doc changelog
doc/user-guide extensions.tex
lib/mlton-stubs mlton.sig mlton.sml sources.cm
mllex mllex-stubs.cm
mlprof mlprof-stubs.cm
mlton mlton-stubs-1997.cm mlton-stubs.cm
mlyacc mlyacc-stubs.cm
Added: basis-library/mlton finalizable.sig finalizable.sml
doc/examples/finalizable .cvsignore Makefile cons.c
finalizable.sml
lib/mlton-stubs finalizable.sig
Removed: basis-library/mlton finalize.sig finalize.sml
lib/mlton-stubs finalize.sig
Log:
Replaced MLton.Finalize with MLton.Finalizable, which has a more
robust approach to finalization.
Revision Changes Path
1.14 +2 -2 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- build 12 May 2003 08:40:49 -0000 1.13
+++ build 15 May 2003 20:12:26 -0000 1.14
@@ -217,8 +217,8 @@
mlton/vector.sig
mlton/weak.sig
mlton/weak.sml
-mlton/finalize.sig
-mlton/finalize.sml
+mlton/finalizable.sig
+mlton/finalizable.sml
mlton/word.sig
mlton/world.sig
mlton/world.sml
1.23 +1 -1 mlton/basis-library/mlton/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- mlton.sig 12 May 2003 08:40:50 -0000 1.22
+++ mlton.sig 15 May 2003 20:12:27 -0000 1.23
@@ -26,7 +26,7 @@
structure BinIO: MLTON_BIN_IO
structure Cont: MLTON_CONT
structure Exn: MLTON_EXN
- structure Finalize: MLTON_FINALIZE
+ structure Finalizable: MLTON_FINALIZABLE
structure FFI: MLTON_FFI
structure GC: MLTON_GC
structure IntInf: MLTON_INT_INF
1.22 +1 -1 mlton/basis-library/mlton/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sml,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- mlton.sml 12 May 2003 08:40:50 -0000 1.21
+++ mlton.sml 15 May 2003 20:12:27 -0000 1.22
@@ -48,7 +48,7 @@
end
structure Cont = MLtonCont
structure Exn = MLtonExn
-structure Finalize = MLtonFinalize
+structure Finalizable = MLtonFinalizable
structure FFI = MLtonFFI
structure GC = MLtonGC
structure IntInf = IntInf
1.1 mlton/basis-library/mlton/finalizable.sig
Index: finalizable.sig
===================================================================
signature MLTON_FINALIZABLE =
sig
type 'a t
val addFinalizer: 'a t * ('a -> unit) -> unit
val finalizeBefore: 'a t * 'b t -> unit
val new: 'a -> 'a t
val withValue: 'a t * ('a -> 'b) -> 'b
end
1.1 mlton/basis-library/mlton/finalizable.sml
Index: finalizable.sml
===================================================================
structure MLtonFinalizable: MLTON_FINALIZABLE =
struct
structure List =
struct
open List
fun push (l, x) = l := x :: !l
fun foreach (l, f) = app f l
end
datatype 'a t = T of {afters: (unit -> unit) list ref,
finalizers: ('a -> unit) list ref,
refCount: int ref,
value: 'a ref}
fun touch (r: 'a ref) =
if r = ref (!r)
then print "bug\n"
else ()
fun withValue (T {value, ...}, f) =
DynamicWind.wind (fn () => f (!value),
fn () => touch value)
fun addFinalizer (T {finalizers, ...}, f) =
List.push (finalizers, f)
(* dec is careful to keep "value" out of the closure. *)
fun dec (T {afters, finalizers, refCount, value}) =
let
val v = !value
in
fn () =>
let
val n = !refCount
in
if n > 0
then refCount := n - 1
else (List.foreach (!finalizers, fn f => f v)
; List.foreach (!afters, fn f => f ()))
end
end
val finalize =
let
val r: {clean: unit -> unit,
isAlive: unit -> bool} list ref = ref []
fun clean l =
List.foldl (fn (z as {clean, isAlive}, (gotOne, zs)) =>
if isAlive ()
then (gotOne, z :: zs)
else (clean (); (true, zs)))
(false, []) l
val exiting = ref false
val _ = MLtonSignal.handleGC (fn () => r := #2 (clean (!r)))
val _ =
Cleaner.addNew
(Cleaner.atExit, fn () =>
let
val l = !r
(* Must clear r so that the handler doesn't interfere and so that
* all other references to the finalizers are dropped.
*)
val _ = r := []
fun loop l =
let
val _ = MLtonGC.collect ()
val (gotOne, l) = clean l
in
if gotOne
then loop l
else ()
end
in
loop l
end)
in
fn z => r := z :: !r
end
fun new v =
let
val afters = ref []
val finalizers = ref []
val refCount = ref 0
val value = ref v
val f = T {afters = afters,
finalizers = finalizers,
refCount = refCount,
value = value}
val weak = MLtonWeak.new value
fun isAlive () = isSome (MLtonWeak.get weak)
val _ = finalize {clean = dec f, isAlive = isAlive}
in
f
end
fun finalizeBefore (T {afters, ...}, f as T {refCount, ...}) =
(refCount := 1 + !refCount
; List.push (afters, dec f))
end
1.8 +1 -1 mlton/benchmark/benchmark-stubs.cm
Index: benchmark-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark-stubs.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- benchmark-stubs.cm 12 May 2003 23:36:25 -0000 1.7
+++ benchmark-stubs.cm 15 May 2003 20:12:27 -0000 1.8
@@ -25,7 +25,7 @@
../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
-../lib/mlton-stubs/finalize.sig
+../lib/mlton-stubs/finalizable.sig
../lib/mlton-stubs/ffi.sig
../lib/mlton-stubs/gc.sig
../lib/mlton-stubs/int-inf.sig
1.32 +2 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- changelog 15 May 2003 18:23:19 -0000 1.31
+++ changelog 15 May 2003 20:12:27 -0000 1.32
@@ -3,6 +3,8 @@
* 2003-05-15
- Fixed bug in Real.class introduced on 04-28 that cause many
regression failures with reals when using newer gccs.
+ - Replaced MLton.Finalize with MLton.Finalizable, which has a more
+ robust approach to finalization.
* 2003-05-13
- Fixed bug in MLton.FFI on Cygwin that caused Thread_returnToC to
1.1 mlton/doc/examples/finalizable/.cvsignore
Index: .cvsignore
===================================================================
cons.o
finalizable
1.1 mlton/doc/examples/finalizable/Makefile
Index: Makefile
===================================================================
mlton = mlton
mlton = /home/sweeks/mlton/bin/mlton
all:
$(mlton) finalizable.sml cons.c
finalizable
.PHONY: clean
clean:
../../../bin/clean
1.1 mlton/doc/examples/finalizable/cons.c
Index: cons.c
===================================================================
#include <stdio.h>
typedef unsigned int uint;
typedef struct Cons {
struct Cons *next;
int value;
} *Cons;
Cons listCons (int n, Cons c) {
Cons res;
res = (Cons) malloc (sizeof(*res));
fprintf (stderr, "0x%08x = listCons (%d)\n", (uint)res, n);
res->next = c;
res->value = n;
return res;
}
Cons listSing (int n) {
Cons res;
res = (Cons) malloc (sizeof(*res));
fprintf (stderr, "0x%08x = listSing (%d)\n", (uint)res, n);
res->next = NULL;
res->value = n;
return res;
}
void listFree (Cons p) {
fprintf (stderr, "listFree (0x%08x)\n", (uint)p);
free (p);
}
int listSum (Cons c) {
int res;
fprintf (stderr, "listSum\n");
res = 0;
for (; c != NULL; c = c->next)
res += c->value;
return res;
}
1.1 mlton/doc/examples/finalizable/finalizable.sml
Index: finalizable.sml
===================================================================
signature CLIST =
sig
type t
val cons: int * t -> t
val sing: int -> t
val sum: t -> int
end
functor CList (structure F: MLTON_FINALIZABLE
structure Prim:
sig
val cons: int * Word32.word -> Word32.word
val free: Word32.word -> unit
val sing: int -> Word32.word
val sum: Word32.word -> int
end): CLIST =
struct
type t = Word32.word F.t
fun cons (n: int, l: t) =
F.withValue
(l, fn w' =>
let
val c = F.new (Prim.cons (n, w'))
val _ = F.addFinalizer (c, Prim.free)
val _ = F.finalizeBefore (c, l)
in
c
end)
fun sing n =
let
val c = F.new (Prim.sing n)
val _ = F.addFinalizer (c, Prim.free)
in
c
end
fun sum c = F.withValue (c, Prim.sum)
end
functor Test (structure CList: CLIST
structure MLton: sig
structure GC:
sig
val collect: unit -> unit
end
end) =
struct
fun f n =
if n = 1
then ()
else
let
val a = Array.tabulate (n, fn i => i)
val _ = Array.sub (a, 0) + Array.sub (a, 1)
in
f (n - 1)
end
val l = CList.sing 2
val l = CList.cons (2,l)
val l = CList.cons (2,l)
val l = CList.cons (2,l)
val l = CList.cons (2,l)
val l = CList.cons (2,l)
val l = CList.cons (2,l)
val _ = MLton.GC.collect ()
val _ = f 100
val _ = print (concat ["listSum(l) = ",
Int.toString (CList.sum l),
"\n"])
val _ = MLton.GC.collect ()
val _ = f 100
end
structure CList =
CList (structure F = MLton.Finalizable
structure Prim =
struct
val cons = _ffi "listCons": int * Word32.word -> Word32.word;
val free = _ffi "listFree": Word32.word -> unit;
val sing = _ffi "listSing": int -> Word32.word;
val sum = _ffi "listSum": Word32.word -> int;
end)
structure S = Test (structure CList = CList
structure MLton = MLton)
1.45 +40 -11 mlton/doc/user-guide/extensions.tex
Index: extensions.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/extensions.tex,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- extensions.tex 13 May 2003 05:20:51 -0000 1.44
+++ extensions.tex 15 May 2003 20:12:27 -0000 1.45
@@ -34,7 +34,7 @@
structure BinIO: MLTON_BIN_IO
structure Cont: MLTON_CONT
structure Exn: MLTON_EXN
- structure Finalize: MLTON_FINALIZE
+ structure Finalizable: MLTON_FINALIZABLE
structure GC: MLTON_GC
structure IntInf: MLTON_INT_INF
structure Itimer: MLTON_ITIMER
@@ -185,23 +185,52 @@
\end{description}
-\subsubsec{{\tt MLton.Finalize}}{finalize}
+\subsubsec{{\tt MLton.Finalizable}}{finalizable}
+A finalizable value is a value to which {\em finalizers} can be
+attached. A finalizer is a function that runs after a garbage
+collection determines that the value to which it is attached is
+unreachable. Reachability is the same as with weak pointers (see
+\secref{weak}). The finalizer is treated like a signal handler, in
+that it runs asynchronously in a separate thread, with signals
+blocked, and will not run within a critical section (see
+\secref{thread}).
+
+For an example, see the {\tt examples/finalizable} directory.
+
\begin{verbatim}
-signature MLTON_FINALIZE =
+signature MLTON_FINALIZABLE =
sig
- val finalize: 'a * (unit -> unit) -> unit
+ type 'a t
+
+ val finalize: 'a t * ('a -> unit) -> unit
+ val finalizeBefore: 'a t * 'b t -> unit
+ val new: 'a -> 'a t
+ val withValue: 'a t * ('a -> 'b) -> 'b
end
\end{verbatim}
\begin{description}
-\entry{finalize (a, f)}
-will run {\tt f ()} when {\tt a} becomes unreachable. The finalizer
-runs after a garbage collection determines that {\tt a} is
-unreachable, which is done by keeping a weak pointer to {\tt a} (see
-\secref{weak}). The finalizer is treated like a signal handler, in
-that it runs asynchronously in a separate thread with signals blocked
-and will not run within a critical section (see \secref{thread}).
+\entry{addFinalizer (v, f)}
+adds {\tt f} as a finalizer to {\tt v}. This means that after the
+last call to {\tt withValue} on {\tt v} completes and {\tt v} becomes
+unreachable, {\tt f x} will run.
+
+\entry{finalizeBefore (v1, v2)}
+ensures that {\tt v1} will be finalized before {\tt v2}. A cycle of
+values {\tt v} = {\tt v1}, \ldots, {\tt vn} = {\tt v} with {\tt
+finalizeBefore (vi, vi+1)} will result in none of the {\tt vi} being
+finalized.
+
+\entry{new x}
+creates a new finalizable value, {\tt v}, with value {\tt x}. The
+finalizers of {\tt v} will run after the last call to {\tt withValue}
+on {\tt v}.
+
+\entry{withValue (v, f)}
+returns the result of applying {\tt f} to the value of {\tt v} and
+ensures that {\tt v}'s finalizers will not run until {\tt f}
+completes.
\end{description}
1.13 +1 -1 mlton/lib/mlton-stubs/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sig,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- mlton.sig 12 May 2003 08:40:52 -0000 1.12
+++ mlton.sig 15 May 2003 20:12:28 -0000 1.13
@@ -26,7 +26,7 @@
structure BinIO: MLTON_BIN_IO
structure Cont: MLTON_CONT
structure Exn: MLTON_EXN
- structure Finalize: MLTON_FINALIZE
+ structure Finalizable: MLTON_FINALIZABLE
structure FFI: MLTON_FFI
structure GC: MLTON_GC
structure IntInf: MLTON_INT_INF
1.18 +7 -2 mlton/lib/mlton-stubs/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mlton.sml 12 May 2003 08:40:52 -0000 1.17
+++ mlton.sml 15 May 2003 20:12:28 -0000 1.18
@@ -97,9 +97,14 @@
val handleCallFromC = fn _ => raise Fail "FFI.handleCallFromC"
end
- structure Finalize =
+ structure Finalizable =
struct
- fun finalize _ = ()
+ type 'a t = 'a
+
+ fun addFinalizer _ = ()
+ fun finalizeBefore _ = ()
+ fun new x = x
+ fun withValue (x, f) = f x
end
structure GC =
1.10 +1 -1 mlton/lib/mlton-stubs/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/sources.cm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- sources.cm 12 May 2003 08:40:52 -0000 1.9
+++ sources.cm 15 May 2003 20:12:28 -0000 1.10
@@ -66,7 +66,7 @@
cont.sig
exn.sig
ffi.sig
-finalize.sig
+finalizable.sig
gc.sig
int-inf.sig
int-inf.sml
1.1 mlton/lib/mlton-stubs/finalizable.sig
Index: finalizable.sig
===================================================================
signature MLTON_FINALIZABLE =
sig
type 'a t
val addFinalizer: 'a t * ('a -> unit) -> unit
val finalizeBefore: 'a t * 'b t -> unit
val new: 'a -> 'a t
val withValue: 'a t * ('a -> 'b) -> 'b
end
1.8 +1 -1 mlton/mllex/mllex-stubs.cm
Index: mllex-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex-stubs.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mllex-stubs.cm 12 May 2003 23:36:25 -0000 1.7
+++ mllex-stubs.cm 15 May 2003 20:12:28 -0000 1.8
@@ -39,7 +39,7 @@
../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
-../lib/mlton-stubs/finalize.sig
+../lib/mlton-stubs/finalizable.sig
../lib/mlton-stubs/ffi.sig
../lib/mlton-stubs/gc.sig
../lib/mlton-stubs/int-inf.sig
1.12 +1 -1 mlton/mlprof/mlprof-stubs.cm
Index: mlprof-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof-stubs.cm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- mlprof-stubs.cm 12 May 2003 23:36:25 -0000 1.11
+++ mlprof-stubs.cm 15 May 2003 20:12:28 -0000 1.12
@@ -39,7 +39,7 @@
../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
-../lib/mlton-stubs/finalize.sig
+../lib/mlton-stubs/finalizable.sig
../lib/mlton-stubs/ffi.sig
../lib/mlton-stubs/gc.sig
../lib/mlton-stubs/int-inf.sig
1.16 +1 -1 mlton/mlton/mlton-stubs-1997.cm
Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- mlton-stubs-1997.cm 12 May 2003 23:36:26 -0000 1.15
+++ mlton-stubs-1997.cm 15 May 2003 20:12:29 -0000 1.16
@@ -46,7 +46,7 @@
../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
-../lib/mlton-stubs/finalize.sig
+../lib/mlton-stubs/finalizable.sig
../lib/mlton-stubs/ffi.sig
../lib/mlton-stubs/gc.sig
../lib/mlton-stubs/int-inf.sig
1.21 +1 -1 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- mlton-stubs.cm 12 May 2003 23:36:26 -0000 1.20
+++ mlton-stubs.cm 15 May 2003 20:12:29 -0000 1.21
@@ -45,7 +45,7 @@
../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
-../lib/mlton-stubs/finalize.sig
+../lib/mlton-stubs/finalizable.sig
../lib/mlton-stubs/ffi.sig
../lib/mlton-stubs/gc.sig
../lib/mlton-stubs/int-inf.sig
1.8 +1 -1 mlton/mlyacc/mlyacc-stubs.cm
Index: mlyacc-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc-stubs.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mlyacc-stubs.cm 12 May 2003 23:36:26 -0000 1.7
+++ mlyacc-stubs.cm 15 May 2003 20:12:29 -0000 1.8
@@ -66,7 +66,7 @@
../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
-../lib/mlton-stubs/finalize.sig
+../lib/mlton-stubs/finalizable.sig
../lib/mlton-stubs/ffi.sig
../lib/mlton-stubs/gc.sig
../lib/mlton-stubs/int-inf.sig
-------------------------------------------------------
Enterprise Linux Forum Conference & Expo, June 4-6, 2003, Santa Clara
The only event dedicated to issues related to Linux enterprise solutions
www.enterpriselinuxforum.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel