[MLton-devel] cvs commit: finalization

Stephen Weeks sweeks@users.sourceforge.net
Mon, 12 May 2003 01:40:54 -0700


sweeks      03/05/12 01:40:54

  Modified:    basis-library/libs build
               basis-library/mlton mlton.sig mlton.sml signal.sig
                        signal.sml thread.sml
               basis-library/posix primitive.sml
               doc/user-guide extensions.tex
               lib/mlton-stubs mlton.sig mlton.sml signal.sig sources.cm
               runtime  gc.c gc.h
               runtime/Posix/Signal isPending.c
  Added:       basis-library/mlton finalize.sig finalize.sml
               lib/mlton-stubs finalize.sig
               regression finalize.ok finalize.sml
  Log:
  Added MLton.Finalize, which implements finalization.  The only
  function there currently is
  
  	val MLton.Finalize.finalize: 'a * (unit -> unit) -> unit
  
  finalize (x, f) causes f () to be run when x becomes unreachable. The
  finalizer runs asynchronously in a separate thread after a garbage
  collection determines that x is unreachable, which is done by
  keeping a weak pointer to x.
  
  The implementation works by treating GC as causing a signal, and
  having a special signal handler for handling the GC signal.  So, the
  finalizer runs in the usual signal handler thread.  This approach
  required no new primitives, and only one new field in gcState,
  gcSignalIsPending, to keep track of when a GC has been done and the
  GC signal needs to be sent.
  
  For now the GC signal is kept internal to the basis library
  implementation and is not exposed to the user.

Revision  Changes    Path
1.13      +2 -0      mlton/basis-library/libs/build

Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- build	18 Apr 2003 22:44:52 -0000	1.12
+++ build	12 May 2003 08:40:49 -0000	1.13
@@ -217,6 +217,8 @@
 mlton/vector.sig
 mlton/weak.sig
 mlton/weak.sml
+mlton/finalize.sig
+mlton/finalize.sml
 mlton/word.sig
 mlton/world.sig
 mlton/world.sml



1.22      +1 -0      mlton/basis-library/mlton/mlton.sig

Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- mlton.sig	18 Apr 2003 22:44:53 -0000	1.21
+++ mlton.sig	12 May 2003 08:40:50 -0000	1.22
@@ -26,6 +26,7 @@
       structure BinIO: MLTON_BIN_IO
       structure Cont: MLTON_CONT
       structure Exn: MLTON_EXN
+      structure Finalize: MLTON_FINALIZE
       structure FFI: MLTON_FFI
       structure GC: MLTON_GC
       structure IntInf: MLTON_INT_INF



1.21      +1 -0      mlton/basis-library/mlton/mlton.sml

Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sml,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- mlton.sml	18 Apr 2003 22:44:53 -0000	1.20
+++ mlton.sml	12 May 2003 08:40:50 -0000	1.21
@@ -48,6 +48,7 @@
    end
 structure Cont = MLtonCont
 structure Exn = MLtonExn
+structure Finalize = MLtonFinalize
 structure FFI = MLtonFFI
 structure GC = MLtonGC
 structure IntInf = IntInf



1.8       +7 -0      mlton/basis-library/mlton/signal.sig

Index: signal.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- signal.sig	11 Feb 2003 22:13:27 -0000	1.7
+++ signal.sig	12 May 2003 08:40:50 -0000	1.8
@@ -52,3 +52,10 @@
        *)
       val suspend: Mask.t -> unit
    end
+
+signature MLTON_SIGNAL_EXTRA =
+   sig
+      include MLTON_SIGNAL
+
+      val handleGC: (unit -> unit) -> unit
+   end



1.21      +23 -9     mlton/basis-library/mlton/signal.sml

Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sml,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- signal.sml	10 Apr 2003 01:45:22 -0000	1.20
+++ signal.sml	12 May 2003 08:40:50 -0000	1.21
@@ -5,7 +5,7 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
-structure MLtonSignal: MLTON_SIGNAL =
+structure MLtonSignal: MLTON_SIGNAL_EXTRA =
 struct
 
 open Posix.Signal
@@ -104,6 +104,8 @@
        handlers)
    end
 
+val gcHandler = ref Ignore
+   
 val getHandler = get
 
 fun isHandledDefault s =
@@ -157,13 +159,22 @@
 	    val () =
 	       MLtonThread.setHandler
 	       (fn t =>
-		Array.foldli
-		(fn (s, h, t) =>
-		 case h of
-		    Handler f => if Prim.isPending s then f t else t
-		  | _ => t)
-		t
-		handlers)
+		let
+		   val t =
+		      Array.foldli
+		      (fn (s, h, t) =>
+		       case h of
+			  Handler f => if Prim.isPending s then f t else t
+			| _ => t)
+		      t
+		      handlers
+		   val t =
+		      case !gcHandler of
+			 Handler f => if Prim.isGCPending () then f t else t
+		       | _ => t
+		in
+		   t
+		end)
 	 in
 	    Handler
 	 end
@@ -195,5 +206,8 @@
    (Mask.create m
     ; Prim.suspend ()
     ; MLtonThread.switchToHandler ())
-   
+
+fun handleGC f =
+   gcHandler := Handler.handler (fn t => (f (); t))
+
 end



1.16      +0 -2      mlton/basis-library/mlton/thread.sml

Index: thread.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/thread.sml,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- thread.sml	25 Mar 2003 04:31:23 -0000	1.15
+++ thread.sml	12 May 2003 08:40:50 -0000	1.16
@@ -176,7 +176,5 @@
 	  NONE => raise Fail "no signal handler installed"
 	| SOME t => Prim.switchTo t))
 
-type 'a thread = 'a t
-
 end
 



1.1                  mlton/basis-library/mlton/finalize.sig

Index: finalize.sig
===================================================================
signature MLTON_FINALIZE =
   sig
      val finalize: 'a * (unit -> unit) -> unit
   end



1.1                  mlton/basis-library/mlton/finalize.sml

Index: finalize.sml
===================================================================
structure MLtonFinalize: MLTON_FINALIZE =
struct

val finalize =
   let
      val r: {clean: unit -> unit,
	      isAlive: unit -> bool} list ref = ref []
      val _ =
	 MLtonSignal.handleGC
	 (fn () =>
	  r := (List.foldl (fn (z as {clean, isAlive}, ac) =>
			    if isAlive ()
			       then z :: ac
			    else (clean (); ac))
		[] (!r)))
   in
      fn z => r := z :: !r
   end

val finalize =
   fn (a: 'a, f: unit -> unit) =>
   let
      val w = MLtonWeak.new a
      fun isAlive () = isSome (MLtonWeak.get w)
   in
      finalize {clean = f, isAlive = isAlive}
   end

end



1.11      +1 -0      mlton/basis-library/posix/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- primitive.sml	8 Feb 2003 21:12:16 -0000	1.10
+++ primitive.sml	12 May 2003 08:40:50 -0000	1.11
@@ -156,6 +156,7 @@
 	    val ignore = _ffi "Posix_Signal_ignore": signal -> int;
 	    val isDefault =
 	       _ffi "Posix_Signal_isDefault": signal * bool ref -> int;
+	    val isGCPending = _ffi "Posix_Signal_isGCPending": unit -> bool;
 	    val isPending = _ffi "Posix_Signal_isPending": signal -> bool;
 	    val numSignals = _const "Posix_Signal_numSignals": int;
 	    val setmask = _const "Posix_Signal_setmask": how;



1.42      +21 -2     mlton/doc/user-guide/extensions.tex

Index: extensions.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/extensions.tex,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- extensions.tex	18 Apr 2003 22:44:55 -0000	1.41
+++ extensions.tex	12 May 2003 08:40:51 -0000	1.42
@@ -34,6 +34,7 @@
       structure BinIO: MLTON_BIN_IO
       structure Cont: MLTON_CONT
       structure Exn: MLTON_EXN
+      structure Finalize: MLTON_FINALIZE
       structure GC: MLTON_GC
       structure IntInf: MLTON_INT_INF
       structure Itimer: MLTON_ITIMER
@@ -177,13 +178,31 @@
 \begin{description}
 
 \entry{history e}
-the file positions that have raised the exception {\tt e}, in reverse
+returns the file positions that have raised the exception {\tt e}, in reverse
 chronological order.   A {\tt handle} expression that implicitly reraises counts
 as a raise.  {\tt history} will return {\tt []} unless the program is compiled
 with {\tt -exn-history true}.
 
 \end{description}
 
+\subsubsec{{\tt MLton.Finalize}}{finalize}
+\begin{verbatim}
+signature MLTON_FINALIZE =
+   sig
+      val finalize: 'a * (unit -> unit) -> unit
+   end
+\end{verbatim}
+
+\begin{description}
+
+\entry{finalize (a, f)}
+will run {\tt f ()} when {\tt a} becomes unreachable.  The finalizer
+runs asynchronously in a separate thread after a garbage collection
+determines that {\tt a} is unreachable, which is done by keeping a
+weak pointer to {\tt a}, see \secref{weak} for details.
+
+\end{description}
+
 \subsubsection{{\tt MLton.GC}}
 \begin{verbatim}
 signature MLTON_GC =
@@ -880,7 +899,7 @@
 
 \end{description}
 
-\subsubsection{\tt MLton.Weak}
+\subsubsec{\tt MLton.Weak}{weak}
 \begin{verbatim}
 signature MLTON_WEAK =
    sig



1.12      +1 -0      mlton/lib/mlton-stubs/mlton.sig

Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- mlton.sig	18 Apr 2003 22:44:55 -0000	1.11
+++ mlton.sig	12 May 2003 08:40:52 -0000	1.12
@@ -26,6 +26,7 @@
       structure BinIO: MLTON_BIN_IO
       structure Cont: MLTON_CONT
       structure Exn: MLTON_EXN
+      structure Finalize: MLTON_FINALIZE
       structure FFI: MLTON_FFI
       structure GC: MLTON_GC
       structure IntInf: MLTON_INT_INF



1.17      +5 -0      mlton/lib/mlton-stubs/mlton.sml

Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- mlton.sml	18 Apr 2003 22:44:56 -0000	1.16
+++ mlton.sml	12 May 2003 08:40:52 -0000	1.17
@@ -96,6 +96,11 @@
 	 struct
 	    val handleCallFromC = fn _ => raise Fail "FFI.handleCallFromC"
 	 end
+
+      structure Finalize =
+	 struct
+	    fun finalize _ = ()
+	 end
       
       structure GC =
 	 struct



1.5       +7 -0      mlton/lib/mlton-stubs/signal.sig

Index: signal.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/signal.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- signal.sig	11 Feb 2003 22:13:28 -0000	1.4
+++ signal.sig	12 May 2003 08:40:52 -0000	1.5
@@ -52,3 +52,10 @@
        *)
       val suspend: Mask.t -> unit
    end
+
+signature MLTON_SIGNAL_EXTRA =
+   sig
+      include MLTON_SIGNAL
+
+      val handleGC: (unit -> unit) -> unit
+   end



1.9       +1 -0      mlton/lib/mlton-stubs/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/sources.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- sources.cm	18 Apr 2003 22:44:56 -0000	1.8
+++ sources.cm	12 May 2003 08:40:52 -0000	1.9
@@ -66,6 +66,7 @@
 cont.sig
 exn.sig
 ffi.sig
+finalize.sig
 gc.sig
 int-inf.sig
 int-inf.sml



1.1                  mlton/lib/mlton-stubs/finalize.sig

Index: finalize.sig
===================================================================
signature MLTON_FINALIZE =
   sig
      val finalize: 'a * (unit -> unit) -> unit
   end



1.1                  mlton/regression/finalize.ok

Index: finalize.ok
===================================================================
3 gone.
2 gone.
1
1 gone.
0
0 gone.



1.1                  mlton/regression/finalize.sml

Index: finalize.sml
===================================================================
structure F = MLton.Finalize

structure Weak = MLton.Weak

val n = 4
val rs = Array.tabulate (n, ref)
fun sub i = ! (Array.sub (rs, i))
val r = ref 13
fun clear i = Array.update (rs, i, r)
val () =
   Array.appi
   (fn (i, r) =>
    F.finalize (r, fn () =>
		print (concat [Int.toString i, " gone.\n"])))
   rs
val _ = clear 3
val _ = clear 2
val _ = MLton.GC.collect ()
fun pi x = print (concat [Int.toString x, "\n"])
val _ = pi (sub 0 + sub 1)
val _ = clear 1
val _ = MLton.GC.collect ()
val _ = pi (sub 0)
val _ = clear 0
val _ = MLton.GC.collect ()



1.132     +28 -13    mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.131
retrieving revision 1.132
diff -u -r1.131 -r1.132
--- gc.c	9 May 2003 18:21:45 -0000	1.131
+++ gc.c	12 May 2003 08:40:53 -0000	1.132
@@ -2941,13 +2941,12 @@
 	s->canHandle = 2;
 }
 
-
 /* GC_startHandler does not do an enter()/leave(), even though it is exported.
- * The basis library uses it as via _ffi, not _prim, and so does not treat it
- * as a runtime call -- so the invariant in enter would fail miserably. 
- * It simulates the relevant part of enter() by blocking signals and resetting
- * the limit.  The leave() wouldn't do anything upon exit  because we are in a
- * signal handler.
+ * The basis library uses it via _ffi, not _prim, and so does not treat it as a
+ * runtime call -- so the invariant in enter would fail miserably. It simulates
+ * the relevant part of enter() by blocking signals and resetting the limit.
+ * The leave() wouldn't do anything upon exit because we are in a signal
+ * handler.
  */
 void GC_startHandler (GC_state s) {
 	blockSignals (s);
@@ -2971,7 +2970,15 @@
 		or bytesRequested > s->limitPlusSlop - s->frontier
 		or not (stackTopIsOk (s, s->currentThread->stack))) {
 		/* This GC will grow the stack, if necessary. */
-		doGC (s, 0, bytesRequested, force, TRUE);
+		doGC (s, 0, bytesRequested, force, TRUE);	
+		/* Send a GC signal. */
+		if (BOGUS_THREAD != s->signalHandler) {
+			if (DEBUG_SIGNALS)
+				fprintf (stderr, "GC Signal pending\n");
+			s->gcSignalIsPending = TRUE;
+			unless (s->inSignalHandler)
+				s->signalIsPending = TRUE;
+		}
 	} else {
 		startHandler (s);
 		switchToThread (s, s->signalHandler);
@@ -4028,6 +4035,7 @@
 	s->copyRatio = 4.0;
 	s->copyGenerationalRatio = 4.0;
 	s->currentThread = BOGUS_THREAD;
+	s->gcSignalIsPending = FALSE;
 	s->growRatio = 8.0;
 	s->inSignalHandler = FALSE;
 	s->isOriginal = TRUE;
@@ -4289,10 +4297,22 @@
 	heapRelease (s, &s->heap2);
 }
 
+static void signalPending (GC_state s) {
+	if (0 == s->canHandle) {
+		if (DEBUG_SIGNALS)
+			fprintf (stderr, "setting limit = 0\n");
+		s->limit = 0;
+	}
+	s->signalIsPending = TRUE;
+}
+
 void GC_finishHandler (GC_state s) {
+	if (DEBUG_SIGNALS)
+		fprintf (stderr, "GC_finishHandler ()\n");
 	assert (s->canHandle == 1);
 	s->inSignalHandler = FALSE;	
 	sigemptyset (&s->signalsPending);
+	s->gcSignalIsPending = FALSE;
 	unblockSignals (s);
 }
 
@@ -4304,13 +4324,8 @@
 void GC_handler (GC_state s, int signum) {
 	if (DEBUG_SIGNALS)
 		fprintf (stderr, "GC_handler  signum = %d\n", signum);
-	if (0 == s->canHandle) {
-		if (DEBUG_SIGNALS)
-			fprintf (stderr, "setting limit = 0\n");
-		s->limit = 0;
-	}
+	signalPending (s);
 	sigaddset (&s->signalsPending, signum);
-	s->signalIsPending = TRUE;
 	if (DEBUG_SIGNALS)
 		fprintf (stderr, "GC_handler done\n");
 }



1.61      +2 -0      mlton/runtime/gc.h

Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -r1.60 -r1.61
--- gc.h	2 May 2003 23:47:49 -0000	1.60
+++ gc.h	12 May 2003 08:40:54 -0000	1.61
@@ -348,6 +348,7 @@
 	 */
 	uint *frameSources;
 	uint frameSourcesSize;
+	bool gcSignalIsPending;
 	pointer *globals;
 	uint globalsSize;
 	float growRatio;
@@ -533,6 +534,7 @@
  * Prints out gc statistics if s->summary is set.
  */
 void GC_done (GC_state s);
+
 
 /* GC_finishHandler should be called by the mutator signal handler thread when
  * it is done handling the signal.



1.2       +16 -2     mlton/runtime/Posix/Signal/isPending.c

Index: isPending.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Signal/isPending.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- isPending.c	18 Jul 2001 05:51:06 -0000	1.1
+++ isPending.c	12 May 2003 08:40:54 -0000	1.2
@@ -2,8 +2,22 @@
 #include "gc.h"
 #include "mlton-posix.h"
 
+enum {
+	DEBUG_SIGNALS = FALSE,
+};
+
 extern struct GC_state gcState;
 
-bool Posix_Signal_isPending(Int signum) {
-      return sigismember(&gcState.signalsPending, signum);
+bool Posix_Signal_isGCPending () {
+	Bool res;
+
+	res = gcState.gcSignalIsPending;
+	if (DEBUG_SIGNALS)
+		fprintf (stderr, "%s = Posix_Signal_isGCPending ()\n",
+				boolToString (res));
+ 	return res;
+}
+
+bool Posix_Signal_isPending (Int signum) {
+	return sigismember (&gcState.signalsPending, signum);
 }





-------------------------------------------------------
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