[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