[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