[MLton-devel] cvs commit: added support for weak pointers
Stephen Weeks
sweeks@users.sourceforge.net
Fri, 18 Apr 2003 15:45:05 -0700
sweeks 03/04/18 15:45:05
Modified: basis-library/libs build
basis-library/misc primitive.sml
basis-library/mlton mlton.sig mlton.sml
benchmark benchmark-stubs.cm
bin check-basis
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 mlton.cm
mlton/ast prim-tycons.fun prim-tycons.sig
mlton/atoms atoms.fun atoms.sig prim.fun prim.sig sources.cm
type-ops.fun type-ops.sig
mlton/backend machine-atoms.fun machine-atoms.sig
representation.fun runtime.fun runtime.sig
ssa-to-rssa.fun
mlton/closure-convert abstract-value.fun abstract-value.sig
closure-convert.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/ssa constant-propagation.fun ssa-tree.fun ssa-tree.sig
useless.fun
mlyacc mlyacc-stubs.cm
runtime gc.c gc.h
Added: basis-library/mlton weak.sig weak.sml
lib/mlton-stubs weak.sig
regression weak.ok weak.sml
Log:
Added MLton.Weak: MLTON_WEAK.
Added a new primitive unary type constructor, 'a weak.
Added the following primitives, which are eventually turned into a C
call, but need to be primitives because various analyses (flow
analysis, constant propagation, ...) need to handle the primitives
specially.
MLton prim GC C call
----------- -------------
Weak_canGet GC_weakCanGet
Weak_get GC_weakGet
Weak_new GC_weakNew
Weak_new allocates a new weak, Weak_get returns the weak pointer
(which may be bogus), and Weak_canGet tells whether the weak pointer
is bogus or not.
Extended the flow analysis, constant propagation, and useless passes
to handle weaks, essentially treating them like references.
SsaToRssa implements the weak primitives. Representation analysis
determines if the weak type is a pointer, and if so, SsaToRssa inserts
the appropriate call to the C function. Otherwise, SsaToRssa
implements Weak_canGet to always return false.
Added two new ObjectType.t to Rssa/Machine.
| Weak of Type.t (* in Weak t, must have Type.isPointer t *)
| WeakGone
Weak t is the type of weak objects where the pointer points to an
object of type t. I had initially use "Weak of PointerTycon.t", but
that didn't work because it also makes sense for IntInfs to have weak
pointers to them. WeakGone is used by the runtime system to indicate
a weak object whose pointer has been nulled.
Recall that ObjectType.t corresponds to the runtime GC_objectType, and
that there is a per-program array of GC_objectTypes that is indexed
into by object headers. For each Weak t, the backend adds an entry to
the objectTypes array with WEAK_TAG, numPointers = 1, and
numNonPointers = 1. It also arranges to put an objectType at the
WEAK_GONE_TYPE_INDEX with WEAK_TAG, numPointers = 0, and
numNonPointers = 2 -- this runtime replaces a weak object header with
WEAK_GONE_HEADER when a weak pointer is nulled.
Only the runtime knows how weaks are represented. A 'a Weak.t is
represented as a GC object with a header and two words. The header
indexes into an element of objectTypes with WEAK_TAG. If the the weak
pointer is valid, then the numPointers = 1 and numNonPointers = 1.
Otherwise, it is the special WEAK_GONE_HEADER, and the type has
numPointers = 0 and numNonPointers = 2. In a weak object, the first
word is a link pointer, which is only used during copying collection.
The second word is the weak pointer, or is BOGUS_POINTER if the weak
pointer is invalid.
The runtime is responsible for forwarding or nulling weak pointers,
depending on whether the object pointed to is retained by the GC.
Depending on the gc strategy, copying or mark-compact, this is done in
different ways.
For copying gc (major or minor), the copying phase treats a weak
object as an object with no pointers. However, whenever a weak object
is forwarded, if the weak pointer points to an object in from space,
i.e. it points into the nursery or we are doing a major gc, then the
forwarded copy is linked into a linked list of all weak objects with
pointers that need to be updated. After the forwarding is done,
updateWeaks () traverses the linked list and either updates the weak
pointer if it points to a forwarded object or nulls the weak pointer
otherwise. For now, there can't be intergenerational weak pointers
since we don't have Weak.set. If we ever add Weak.set, we will need
to have forwardInterGenerationalPointers link weak objects it finds
into the weak list.
Mark-compact GC is simpler. The mark phase treats a weak object as an
object with no pointers. Then, the updateForwardPointers phase clears
the weak pointer if it points to an unmarked object. Otherwise, the
weak object is treated according to what the objectType says about the
numPointers.
Revision Changes Path
1.12 +2 -0 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- build 11 Apr 2003 04:31:09 -0000 1.11
+++ build 18 Apr 2003 22:44:52 -0000 1.12
@@ -215,6 +215,8 @@
mlton/syslog.sig
mlton/syslog.sml
mlton/vector.sig
+mlton/weak.sig
+mlton/weak.sml
mlton/word.sig
mlton/world.sig
mlton/world.sml
1.49 +10 -0 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- primitive.sml 11 Apr 2003 04:31:09 -0000 1.48
+++ primitive.sml 18 Apr 2003 22:44:53 -0000 1.49
@@ -29,6 +29,7 @@
type word8 = word8
type word32 = word
type 'a vector = 'a vector
+type 'a weak = 'a weak
type string = char vector
type nullString = string
@@ -403,6 +404,15 @@
(* val serialize = _prim "MLton_serialize": 'a ref -> Word8Vector.vector; *)
val size = fn x => _prim "MLton_size": 'a ref -> int; x
+
+ structure Weak =
+ struct
+ type 'a t = 'a weak
+
+ val canGet = fn x => _prim "Weak_canGet": 'a t -> bool; x
+ val get = fn x => _prim "Weak_get": 'a t -> 'a; x
+ val new = fn x => _prim "Weak_new" : 'a -> 'a t; x
+ end
end
structure Net =
1.21 +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.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- mlton.sig 11 Apr 2003 04:31:09 -0000 1.20
+++ mlton.sig 18 Apr 2003 22:44:53 -0000 1.21
@@ -44,6 +44,7 @@
structure TextIO: MLTON_TEXT_IO
structure Thread: MLTON_THREAD
structure Vector: MLTON_VECTOR
+ structure Weak: MLTON_WEAK
structure Word:
sig
include MLTON_WORD
1.20 +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.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- mlton.sml 11 Apr 2003 04:31:09 -0000 1.19
+++ mlton.sml 18 Apr 2003 22:44:53 -0000 1.20
@@ -66,6 +66,7 @@
structure TextIO = MLtonIO (TextIO)
structure Thread = MLtonThread
structure Vector = Vector
+structure Weak = MLtonWeak
structure World = MLtonWorld
structure Word = Primitive.Word32
structure Word8 = Primitive.Word8
1.1 mlton/basis-library/mlton/weak.sig
Index: weak.sig
===================================================================
signature MLTON_WEAK =
sig
type 'a t
val get: 'a t -> 'a option
val new: 'a -> 'a t
end
1.1 mlton/basis-library/mlton/weak.sml
Index: weak.sml
===================================================================
structure MLtonWeak =
struct
structure Weak = Primitive.MLton.Weak
type 'a t = 'a Weak.t
val new = Weak.new
fun get (w: 'a t): 'a option =
let
(* Need to do the canGet after the get. If you did the canGet first,
* there could be a GC that invalidates the pointer between the
* canGet and the get.
*)
val x = Weak.get w
in
if Weak.canGet w
then SOME x
else NONE
end
end
1.6 +1 -0 mlton/benchmark/benchmark-stubs.cm
Index: benchmark-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark-stubs.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- benchmark-stubs.cm 11 Apr 2003 04:31:09 -0000 1.5
+++ benchmark-stubs.cm 18 Apr 2003 22:44:54 -0000 1.6
@@ -5,6 +5,7 @@
../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
+../lib/mlton-stubs/weak.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
../lib/mlton-stubs/io.sig
1.14 +1 -0 mlton/bin/check-basis
Index: check-basis
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/check-basis,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- check-basis 10 Apr 2003 01:48:41 -0000 1.13
+++ check-basis 18 Apr 2003 22:44:54 -0000 1.14
@@ -110,6 +110,7 @@
datatype ref = datatype ref
datatype preThread = T
datatype thread = T
+ datatype 'a weak = T of 'a
type word = Word32.word
type word8 = Word8.word
type 'a vector = 'a vector
1.22 +4 -1 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- changelog 11 Apr 2003 04:31:09 -0000 1.21
+++ changelog 18 Apr 2003 22:44:54 -0000 1.22
@@ -1,4 +1,7 @@
-Here are the changes since version 20030312
+Here are the changes since version 20030312.
+
+* 2003-04-18
+ - Added MLton.Weak, which supports weak pointers.
* 2003-04-10
- Replaced the basis library's MLton.hostType with
1.41 +33 -0 mlton/doc/user-guide/extensions.tex
Index: extensions.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/extensions.tex,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- extensions.tex 10 Apr 2003 02:03:04 -0000 1.40
+++ extensions.tex 18 Apr 2003 22:44:55 -0000 1.41
@@ -49,6 +49,7 @@
structure TextIO: MLTON_TEXT_IO
structure Thread: MLTON_THREAD
structure Vector: MLTON_VECTOR
+ structure Weak: MLTON_WEAK
structure Word: MLTON_WORD where type word = Word.word
structure Word8: MLTON_WORD where type word = Word8.word
structure World: MLTON_WORLD
@@ -877,6 +878,38 @@
construct a vector $v$ of a length {\tt n}, whose elements $v_i$ are determined
by the equations $b_0 = b$ and $(v_i, b_{i+1}) = f (i, b_i)$.
+\end{description}
+
+\subsubsection{\tt MLton.Weak}
+\begin{verbatim}
+signature MLTON_WEAK =
+ sig
+ type 'a t
+
+ val get: 'a t -> 'a option
+ val new: 'a -> 'a t
+ end
+\end{verbatim}
+
+A weak pointer is a pointer to an object that is nulled if the
+object becomes unreachable due to garbage collection. The weak
+pointer does not itself cause the object it points to be retained by
+the garbage collector -- only other strong pointers can do that.
+For objects that are not allocated in the heap, like integers, a weak
+pointer will always be nulled. So, if {\tt w: int t} then
+{\tt get w = NONE}.
+
+\begin{description}
+\entry{type 'a t}
+the type of weak pointers to objects of type 'a
+
+\entry{get w}
+returns {\tt NONE} if the object pointed to by {\tt w} no longer
+exist. Otherwise, returns {\tt SOME} of the object pointed to by {\tt
+w}.
+
+\entry{new x}
+returns a weak pointer to {\tt x}.
\end{description}
\subsubsection{\tt MLton.Word, MLton.Word8}
1.11 +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.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- mlton.sig 11 Apr 2003 04:31:10 -0000 1.10
+++ mlton.sig 18 Apr 2003 22:44:55 -0000 1.11
@@ -44,6 +44,7 @@
structure TextIO: MLTON_TEXT_IO
structure Thread: MLTON_THREAD
structure Vector: MLTON_VECTOR
+ structure Weak: MLTON_WEAK
structure Word:
sig
include MLTON_WORD
1.16 +8 -0 mlton/lib/mlton-stubs/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- mlton.sml 11 Apr 2003 04:31:10 -0000 1.15
+++ mlton.sml 18 Apr 2003 22:44:56 -0000 1.16
@@ -398,6 +398,14 @@
end
end
+ structure Weak =
+ struct
+ type 'a t = 'a
+
+ val get = SOME
+ fun new x = x
+ end
+
structure World =
struct
datatype status = Original | Clone
1.8 +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.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- sources.cm 11 Apr 2003 04:31:10 -0000 1.7
+++ sources.cm 18 Apr 2003 22:44:56 -0000 1.8
@@ -90,5 +90,6 @@
thread.sig
thread.sml
vector.sig
+weak.sig
word.sig
world.sig
1.1 mlton/lib/mlton-stubs/weak.sig
Index: weak.sig
===================================================================
signature MLTON_WEAK =
sig
type 'a t
val get: 'a t -> 'a option
val new: 'a -> 'a t
end
1.6 +1 -0 mlton/mllex/mllex-stubs.cm
Index: mllex-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex-stubs.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mllex-stubs.cm 11 Apr 2003 04:31:10 -0000 1.5
+++ mllex-stubs.cm 18 Apr 2003 22:44:56 -0000 1.6
@@ -19,6 +19,7 @@
../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
+../lib/mlton-stubs/weak.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
../lib/mlton-stubs/io.sig
1.10 +1 -0 mlton/mlprof/mlprof-stubs.cm
Index: mlprof-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof-stubs.cm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- mlprof-stubs.cm 11 Apr 2003 04:31:10 -0000 1.9
+++ mlprof-stubs.cm 18 Apr 2003 22:44:56 -0000 1.10
@@ -19,6 +19,7 @@
../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
+../lib/mlton-stubs/weak.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
../lib/mlton-stubs/io.sig
1.13 +1 -2 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.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- mlton-stubs-1997.cm 11 Apr 2003 04:31:10 -0000 1.12
+++ mlton-stubs-1997.cm 18 Apr 2003 22:44:57 -0000 1.13
@@ -11,6 +11,7 @@
../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
+../lib/mlton-stubs/weak.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
../lib/mlton-stubs/io.sig
@@ -227,8 +228,6 @@
atoms/var.fun
atoms/use-name.fun
atoms/tycon.sig
-atoms/unary-tycon.sig
-atoms/unary-tycon.fun
atoms/type-ops.sig
atoms/type.sig
atoms/type-ops.fun
1.18 +1 -2 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mlton-stubs.cm 11 Apr 2003 04:31:10 -0000 1.17
+++ mlton-stubs.cm 18 Apr 2003 22:44:57 -0000 1.18
@@ -10,6 +10,7 @@
../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
+../lib/mlton-stubs/weak.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
../lib/mlton-stubs/io.sig
@@ -226,8 +227,6 @@
atoms/var.fun
atoms/use-name.fun
atoms/tycon.sig
-atoms/unary-tycon.sig
-atoms/unary-tycon.fun
atoms/type-ops.sig
atoms/type.sig
atoms/type-ops.fun
1.65 +0 -2 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- mlton.cm 2 Apr 2003 01:54:51 -0000 1.64
+++ mlton.cm 18 Apr 2003 22:44:57 -0000 1.65
@@ -194,8 +194,6 @@
atoms/var.fun
atoms/use-name.fun
atoms/tycon.sig
-atoms/unary-tycon.sig
-atoms/unary-tycon.fun
atoms/type-ops.sig
atoms/type.sig
atoms/type-ops.fun
1.5 +2 -1 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- prim-tycons.fun 24 Nov 2002 01:19:43 -0000 1.4
+++ prim-tycons.fun 18 Apr 2003 22:44:58 -0000 1.5
@@ -27,12 +27,13 @@
val thread = fromString "thread"
val tuple = fromString "*"
val vector = fromString "vector"
+ val weak = fromString "weak"
val word = fromString "word"
val word8 = fromString "word8"
val prims =
[array, arrow, bool, char, exn, int, intInf, list, pointer,
- preThread, real, reff, thread, tuple, vector, word, word8]
+ preThread, real, reff, thread, tuple, vector, weak, word, word8]
val defaultInt = int
val defaultWord = word
1.5 +1 -0 mlton/mlton/ast/prim-tycons.sig
Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- prim-tycons.sig 24 Nov 2002 01:19:43 -0000 1.4
+++ prim-tycons.sig 18 Apr 2003 22:44:58 -0000 1.5
@@ -31,6 +31,7 @@
val thread: tycon
val tuple: tycon
val vector: tycon
+ val weak: tycon
val word: tycon
val word8: tycon
1.6 +0 -1 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- atoms.fun 20 Jan 2003 20:38:27 -0000 1.5
+++ atoms.fun 18 Apr 2003 22:44:58 -0000 1.6
@@ -16,7 +16,6 @@
structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
structure Var = Var (structure AstId = Ast.Var)
structure Tycon = Tycon (structure AstId = Ast.Tycon)
- structure UnaryTycon = UnaryTycon (structure Tycon = Tycon)
structure Type =
Type (structure Ast = Ast
structure Record = Ast.SortedRecord
1.6 +0 -2 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- atoms.sig 20 Jan 2003 20:38:27 -0000 1.5
+++ atoms.sig 18 Apr 2003 22:44:58 -0000 1.6
@@ -26,7 +26,6 @@
structure Tycon: TYCON
structure Tycons: SET
structure Tyvar: TYVAR
- structure UnaryTycon: UNARY_TYCON
structure Var: VAR
structure Vars: SET
structure TyvarEnv:
@@ -54,7 +53,6 @@
sharing SourceInfo = ProfileExp.SourceInfo
sharing Tycon = Const.Tycon
sharing Tycon = Scheme.Tycon
- sharing Tycon = UnaryTycon.Tycon
sharing Tyvar = Ast.Tyvar
sharing type Con.t = Cons.Element.t
sharing type Tycon.t = Tycons.Element.t
1.46 +12 -1 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- prim.fun 25 Mar 2003 04:31:23 -0000 1.45
+++ prim.fun 18 Apr 2003 22:44:58 -0000 1.46
@@ -157,6 +157,9 @@
| Vector_fromArray
| Vector_length
| Vector_sub
+ | Weak_canGet
+ | Weak_get
+ | Weak_new
| Word32_add
| Word32_addCheck
| Word32_andb
@@ -378,6 +381,9 @@
(Vector_fromArray, DependsOnState, "Vector_fromArray"),
(Vector_length, Functional, "Vector_length"),
(Vector_sub, Functional, "Vector_sub"),
+ (Weak_canGet, DependsOnState, "Weak_canGet"),
+ (Weak_get, DependsOnState, "Weak_get"),
+ (Weak_new, Moveable, "Weak_new"),
(Word32_add, Functional, "Word32_add"),
(Word32_addCheck, SideEffect, "Word32_addCheck"),
(Word32_andb, Functional, "Word32_andb"),
@@ -671,7 +677,9 @@
fun 'a extractTargs {prim, args, result,
dearray,
dearrow: 'a -> 'a * 'a,
- deref, devector} =
+ deref,
+ devector,
+ deweak} =
let
val one = Vector.new1
fun arg i = Vector.sub (args, i)
@@ -698,6 +706,9 @@
| Vector_fromArray => one (dearray (arg 0))
| Vector_length => one (devector (arg 0))
| Vector_sub => one result
+ | Weak_canGet => one (deweak (arg 0))
+ | Weak_get => one result
+ | Weak_new => one (arg 0)
| _ => Vector.new0 ()
end
1.36 +5 -1 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- prim.sig 25 Mar 2003 04:31:23 -0000 1.35
+++ prim.sig 18 Apr 2003 22:44:58 -0000 1.36
@@ -166,6 +166,9 @@
| Vector_fromArray (* implemented in backend *)
| Vector_length
| Vector_sub (* implemented in backend *)
+ | Weak_canGet (* implemented in SsaToRssa *)
+ | Weak_get (* implemented in SsaToRssa *)
+ | Weak_new (* implemented in SsaToRssa *)
| Word32_add
| Word32_addCheck
| Word32_andb
@@ -277,7 +280,8 @@
dearray: 'a -> 'a,
dearrow: 'a -> 'a * 'a,
deref: 'a -> 'a,
- devector: 'a -> 'a} -> 'a vector
+ devector: 'a -> 'a,
+ deweak: 'a -> 'a} -> 'a vector
val ffi: string * Scheme.t -> t
val gcCollect: t
val intInfEqual: t
1.11 +0 -2 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- sources.cm 2 Apr 2003 02:55:55 -0000 1.10
+++ sources.cm 18 Apr 2003 22:44:58 -0000 1.11
@@ -70,8 +70,6 @@
type-ops.sig
type.fun
type.sig
-unary-tycon.fun
-unary-tycon.sig
use-name.fun
var.fun
var.sig
1.5 +5 -2 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- type-ops.fun 24 Nov 2002 01:19:43 -0000 1.4
+++ type-ops.fun 18 Apr 2003 22:44:58 -0000 1.5
@@ -34,9 +34,10 @@
fun unary tycon t = con (tycon, Vector.new1 t)
in
val array = unary Tycon.array
- val vector = unary Tycon.vector
val list = unary Tycon.list
val reff = unary Tycon.reff
+ val vector = unary Tycon.vector
+ val weak = unary Tycon.weak
end
val string = vector char
@@ -58,6 +59,7 @@
val dearrayOpt = deUnaryOpt Tycon.array
val derefOpt = deUnaryOpt Tycon.reff
+val deweakOpt = deUnaryOpt Tycon.weak
fun deUnary tycon t =
case deUnaryOpt tycon t of
@@ -65,8 +67,9 @@
| NONE => Error.bug "deUnary"
val dearray = deUnary Tycon.array
-val devector = deUnary Tycon.vector
val deref = deUnary Tycon.reff
+val devector = deUnary Tycon.vector
+val deweak = deUnary Tycon.weak
fun tuple ts =
if 1 = Vector.length ts
1.5 +3 -0 mlton/mlton/atoms/type-ops.sig
Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- type-ops.sig 24 Nov 2002 01:19:43 -0000 1.4
+++ type-ops.sig 18 Apr 2003 22:44:58 -0000 1.5
@@ -49,6 +49,8 @@
val detupleOpt: t -> t vector option
val detycon: t -> tycon
val devector: t -> t
+ val deweak: t -> t
+ val deweakOpt: t -> t option
val exn: t
val int: t
val intInf: t
@@ -65,6 +67,7 @@
val unit: t
val unitRef: t
val vector: t -> t
+ val weak: t -> t
val word8: t
val word: t
end
1.8 +17 -1 mlton/mlton/backend/machine-atoms.fun
Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- machine-atoms.fun 20 Jan 2003 20:38:28 -0000 1.7
+++ machine-atoms.fun 18 Apr 2003 22:44:59 -0000 1.8
@@ -41,11 +41,12 @@
(* These basic pointer tycons are hardwired into the runtime and are
* prefixed to every user program. See gc.h for the definitions of
- * {STACK,STRING,THREAD,WORD_VECTOR}_TYPE_INDEX.
+ * {STACK,STRING,THREAD,WEAK_GONE,WORD_VECTOR}_TYPE_INDEX.
*)
val stack = new ()
val string = new ()
val thread = new ()
+ val weakGone = new ()
val wordVector = new ()
end
@@ -209,6 +210,7 @@
datatype t = datatype ty
val equals = equalsTy
+ val isOk = isOkTy
val layout = layoutTy
val size = size
end
@@ -340,6 +342,8 @@
Array of MemChunk.t
| Normal of MemChunk.t
| Stack
+ | Weak of Type.t
+ | WeakGone
fun layout (t: t) =
let
@@ -349,16 +353,20 @@
Array mc => seq [str "Array ", MemChunk.layout mc]
| Normal mc => seq [str "Normal ", MemChunk.layout mc]
| Stack => str "Stack"
+ | Weak t => seq [str "Weak ", Type.layout t]
+ | WeakGone => str "WeakGone"
end
val wordSize = Runtime.wordSize
val stack = Stack
+
val string =
Array (MemChunk.T {components = Vector.new1 {mutable = false,
offset = 0,
ty = Type.char},
size = 1})
+
val thread =
let
val components =
@@ -375,6 +383,9 @@
Normal (MemChunk.T {components = components,
size = 3 * wordSize})
end
+
+ val weak = Weak
+
val wordVector =
Array (MemChunk.T {components = Vector.new1 {mutable = false,
offset = 0,
@@ -385,6 +396,8 @@
fn Array mc => MemChunk.isOk mc
| Normal mc => MemChunk.isOk mc
| Stack => true
+ | Weak t => Type.isPointer t andalso Type.isOk t
+ | WeakGone => true
local
structure R = Runtime.ObjectType
@@ -405,6 +418,8 @@
numPointers = p}
end
| Stack => R.Stack
+ | Weak _ => R.Weak
+ | WeakGone => R.WeakGone
end
val basic =
@@ -412,6 +427,7 @@
[(PointerTycon.stack, stack),
(PointerTycon.string, string),
(PointerTycon.thread, thread),
+ (PointerTycon.weakGone, WeakGone),
(PointerTycon.wordVector, wordVector)]
end
1.9 +3 -0 mlton/mlton/backend/machine-atoms.sig
Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- machine-atoms.sig 2 Feb 2003 03:17:08 -0000 1.8
+++ machine-atoms.sig 18 Apr 2003 22:44:59 -0000 1.9
@@ -105,6 +105,8 @@
Array of MemChunk.t
| Normal of MemChunk.t
| Stack
+ | Weak of Type.t (* in Weak t, must have Type.isPointer t *)
+ | WeakGone
val basic: (PointerTycon.t * t) vector
val isOk: t -> bool
@@ -113,6 +115,7 @@
val string: t
val thread: t
val toRuntime: t -> Runtime.ObjectType.t
+ val weak: Type.t -> t
val wordVector: t
end
1.13 +16 -0 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- representation.fun 2 Feb 2003 03:17:08 -0000 1.12
+++ representation.fun 18 Apr 2003 22:44:59 -0000 1.13
@@ -541,6 +541,22 @@
mutable = false,
tys = S.Type.detuple t})
| Vector t => SOME (array {mutable = false, ty = t})
+ | Weak t =>
+ (case toRtype t of
+ NONE => NONE
+ | SOME t =>
+ if R.Type.isPointer t
+ then
+ let
+ val pt = PointerTycon.new ()
+ val _ =
+ List.push
+ (objectTypes,
+ (pt, R.ObjectType.weak t))
+ in
+ SOME (R.Type.pointer pt)
+ end
+ else NONE)
| Word => SOME R.Type.word
| Word8 => SOME R.Type.char
end))
1.12 +4 -0 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- runtime.fun 23 Jan 2003 03:34:36 -0000 1.11
+++ runtime.fun 18 Apr 2003 22:44:59 -0000 1.12
@@ -111,6 +111,8 @@
| Normal of {numPointers: int,
numWordsNonPointers: int}
| Stack
+ | Weak
+ | WeakGone
val equals: t * t -> bool = op =
@@ -128,6 +130,8 @@
record [("numPointers", Int.layout np),
("numWordsNonPointers", Int.layout nwnp)]]
| Stack => str "Stack"
+ | Weak => str "Weak"
+ | WeakGone => str "WeakGone"
end
end
1.21 +2 -0 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- runtime.sig 23 Jan 2003 03:34:36 -0000 1.20
+++ runtime.sig 18 Apr 2003 22:44:59 -0000 1.21
@@ -60,6 +60,8 @@
| Normal of {numPointers: int,
numWordsNonPointers: int}
| Stack
+ | Weak
+ | WeakGone
end
(* All sizes are in bytes, unless they explicitly say "pointers". *)
1.38 +51 -0 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- ssa-to-rssa.fun 25 Mar 2003 04:31:24 -0000 1.37
+++ ssa-to-rssa.fun 18 Apr 2003 22:44:59 -0000 1.38
@@ -140,6 +140,24 @@
name = "Thread_switchTo",
returnTy = NONE}
+ val weakCanGet =
+ vanilla {name = "GC_weakCanGet",
+ returnTy = SOME Type.bool}
+
+ val weakGet =
+ vanilla {name = "GC_weakGet",
+ returnTy = SOME Type.pointer}
+
+ val weakNew =
+ make {bytesNeeded = NONE,
+ ensuresBytesFree = false,
+ mayGC = true,
+ maySwitchThreads = false,
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ name = "GC_weakNew",
+ returnTy = SOME Type.pointer}
+
val worldSave =
make {bytesNeeded = NONE,
ensuresBytesFree = false,
@@ -783,6 +801,13 @@
move (Operand.cast (varOp (a 0),
valOf (toRtype ty)))
fun targ () = toRtype (Vector.sub (targs, 0))
+ fun ifTargIsPointer (yes, no) =
+ case targ () of
+ NONE => no ()
+ | SOME t =>
+ if Type.isPointer t
+ then yes ()
+ else no ()
fun arrayOffset (ty: Type.t): Operand.t =
ArrayOffset {base = varOp (a 0),
index = varOp (a 1),
@@ -1217,6 +1242,32 @@
(case targ () of
NONE => none ()
| SOME t => sub t)
+ | Weak_canGet =>
+ ifTargIsPointer
+ (fn () => simpleCCall CFunction.weakCanGet,
+ fn () => move (Operand.bool false))
+ | Weak_get =>
+ ifTargIsPointer
+ (fn () => simpleCCall CFunction.weakGet,
+ none)
+ | Weak_new =>
+ ifTargIsPointer
+ (fn () =>
+ let
+ val header =
+ Operand.PointerTycon
+ (valOf
+ (Type.dePointer
+ (valOf (toRtype ty))))
+ in
+ ccall {args = (Vector.concat
+ [Vector.new2
+ (Operand.GCState,
+ header),
+ vos args]),
+ func = CFunction.weakNew}
+ end,
+ none)
| Word32_toIntX => cast ()
| Word32_fromInt => cast ()
| World_save =>
1.7 +58 -16 mlton/mlton/closure-convert/abstract-value.fun
Index: abstract-value.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- abstract-value.fun 7 Nov 2002 20:49:38 -0000 1.6
+++ abstract-value.fun 18 Apr 2003 22:44:59 -0000 1.7
@@ -142,11 +142,26 @@
*)
end
+structure UnaryTycon =
+ struct
+ datatype t = Array | Ref | Vector | Weak
+
+ val toString =
+ fn Array => "Array"
+ | Ref => "Ref"
+ | Vector => "Vector"
+ | Weak => "Weak"
+
+ val equals: t * t -> bool = op =
+
+ val layout = Layout.str o toString
+ end
+
datatype tree =
- Type of Type.t
- | Unify of UnaryTycon.t * t
+ Lambdas of LambdaNode.t
| Tuple of t vector
- | Lambdas of LambdaNode.t
+ | Type of Type.t
+ | Unify of UnaryTycon.t * t
withtype t = {tree: tree,
ty: Type.t,
@@ -265,6 +280,12 @@
| Unify (_, v) => v
| _ => Error.bug "Value.deref"
+fun deweak v =
+ case tree v of
+ Type t => fromType (Type.deweak t)
+ | Unify (_, v) => v
+ | _ => Error.bug "Value.deweak"
+
fun dearray v =
case tree v of
Type t => fromType (Type.dearray t)
@@ -323,21 +344,23 @@
structure Dest =
struct
datatype dest =
- Type of Type.t
+ Array of t
+ | Lambdas of Lambdas.t
| Ref of t
- | Array of t
- | Vector of t
| Tuple of t vector
- | Lambdas of Lambdas.t
+ | Type of Type.t
+ | Vector of t
+ | Weak of t
end
fun dest v =
case tree v of
Type t => Dest.Type t
| Unify (mt, v) => (case mt of
- UnaryTycon.Ref => Dest.Ref v
- | UnaryTycon.Array => Dest.Array v
- | UnaryTycon.Vector => Dest.Vector v)
+ UnaryTycon.Array => Dest.Array v
+ | UnaryTycon.Ref => Dest.Ref v
+ | UnaryTycon.Vector => Dest.Vector v
+ | UnaryTycon.Weak => Dest.Weak v)
| Tuple vs => Dest.Tuple vs
| Lambdas l => Dest.Lambdas (LambdaNode.toSet l)
@@ -411,12 +434,15 @@
| Type _ => result ()
| _ => typeError ())
| Ref_ref =>
- let val r = result ()
- in (case dest r of
- Ref x => coerce {from = oneArg (), to = x} (* unify (oneArg (), x) *)
- | Type _ => ()
- | _ => typeError ())
- ; r
+ let
+ val r = result ()
+ val _ =
+ case dest r of
+ Ref x => coerce {from = oneArg (), to = x} (* unify (oneArg (), x) *)
+ | Type _ => ()
+ | _ => typeError ()
+ in
+ r
end
| Vector_fromArray =>
let val r = result ()
@@ -435,6 +461,22 @@
Vector x => x
| Type _ => result ()
| _ => typeError ())
+ | Weak_get =>
+ (case dest (oneArg ()) of
+ Weak v => v
+ | Type _ => result ()
+ | _ => typeError ())
+ | Weak_new =>
+ let
+ val r = result ()
+ val _ =
+ case dest r of
+ Ref x => coerce {from = oneArg (), to = x}
+ | Type _ => ()
+ | _ => typeError ()
+ in
+ r
+ end
| _ => result ()
end
1.4 +2 -0 mlton/mlton/closure-convert/abstract-value.sig
Index: abstract-value.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- abstract-value.sig 10 Apr 2002 07:02:19 -0000 1.3
+++ abstract-value.sig 18 Apr 2003 22:45:00 -0000 1.4
@@ -43,6 +43,7 @@
| Tuple of t vector
| Type of Sxml.Type.t (* type doesn't contain any arrows *)
| Vector of t
+ | Weak of t
val addHandler: t * (Lambda.t -> unit) -> unit
val coerce: {from: t, to: t} -> unit
@@ -52,6 +53,7 @@
val dest: t -> dest
(* Destroy info associated with Sxml.Type used to keep track of arrows. *)
val destroy: unit -> unit
+ val deweak: t -> t
val equals: t * t -> bool
val fromType: Sxml.Type.t -> t
val isEmpty: t -> bool (* no possible values correspond to me *)
1.26 +16 -5 mlton/mlton/closure-convert/closure-convert.fun
Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- closure-convert.fun 13 Jan 2003 07:58:52 -0000 1.25
+++ closure-convert.fun 18 Apr 2003 22:45:00 -0000 1.26
@@ -426,13 +426,14 @@
let
val t =
case Value.dest v of
- Value.Type t => convertType t
+ Value.Array v => Type.array (valueType v)
+ | Value.Lambdas ls => #ty (lambdasInfo ls)
| Value.Ref v => Type.reff (valueType v)
- | Value.Array v => Type.array (valueType v)
- | Value.Vector v => Type.vector (valueType v)
+ | Value.Type t => convertType t
| Value.Tuple vs =>
Type.tuple (Vector.map (vs, valueType))
- | Value.Lambdas ls => #ty (lambdasInfo ls)
+ | Value.Vector v => Type.vector (valueType v)
+ | Value.Weak v => Type.weak (valueType v)
in r := SOME t; t
end
end) arg
@@ -954,6 +955,15 @@
v1 (coerce (convertVarInfo y,
VarInfo.value y, v)))
end
+ | Weak_new =>
+ let
+ val y = varExpInfo (arg 0)
+ val v = Value.deweak v
+ in
+ primApp (v1 (valueType v),
+ v1 (coerce (convertVarInfo y,
+ VarInfo.value y, v)))
+ end
| _ =>
let
val args = Vector.map (args, varExpInfo)
@@ -966,7 +976,8 @@
dearray = Type.dearray,
dearrow = Type.dearrow,
deref = Type.deref,
- devector = Type.devector},
+ devector = Type.devector,
+ deweak = Type.deweak},
Vector.map (args, convertVarInfo))
end)
end
1.51 +4 -0 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- c-codegen.fun 11 Apr 2003 04:31:10 -0000 1.50
+++ c-codegen.fun 18 Apr 2003 22:45:00 -0000 1.51
@@ -226,6 +226,10 @@
(1, numWordsNonPointers, numPointers)
| Stack =>
(2, 0, 0)
+ | Weak =>
+ (3, 1, 1)
+ | WeakGone =>
+ (3, 2, 0)
in
concat ["{ ", Int.toString tag, ", ",
Int.toString nonPointers, ", ",
1.15 +74 -48 mlton/mlton/ssa/constant-propagation.fun
Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- constant-propagation.fun 19 Dec 2002 23:43:35 -0000 1.14
+++ constant-propagation.fun 18 Apr 2003 22:45:00 -0000 1.15
@@ -211,16 +211,17 @@
global: global ref
} Set.t
and value =
- Const of Const.t
- | Datatype of data
- | Vector of {length: t,
- elt: t}
- | Ref of {birth: {init: t} Birth.t,
- arg: t}
- | Array of {birth: unit Birth.t,
- length: t,
- elt: t}
- | Tuple of t vector
+ Array of {birth: unit Birth.t,
+ elt: t,
+ length: t}
+ | Const of Const.t
+ | Datatype of data
+ | Ref of {arg: t,
+ birth: {init: t} Birth.t}
+ | Tuple of t vector
+ | Vector of {elt: t,
+ length: t}
+ | Weak of t
and data =
Data of {
value: dataVal ref,
@@ -252,18 +253,19 @@
in
fun layout v =
case value v of
- Const c => Const.layout c
- | Datatype d => layoutData d
- | Ref {birth, arg, ...} =>
- seq [str "ref", tuple [Birth.layout birth, layout arg]]
- | Array {birth, length, elt, ...} =>
+ Array {birth, elt, length, ...} =>
seq [str "array", tuple [Birth.layout birth,
layout length,
layout elt]]
- | Vector {length, elt, ...} => seq [str "vector",
- tuple [layout length,
- layout elt]]
+ | Const c => Const.layout c
+ | Datatype d => layoutData d
+ | Ref {arg, birth, ...} =>
+ seq [str "ref ", tuple [layout arg, Birth.layout birth]]
| Tuple vs => Vector.layout layout vs
+ | Vector {elt, length, ...} => seq [str "vector ",
+ tuple [layout elt,
+ layout length]]
+ | Weak v => seq [str "weak ", layout v]
and layoutData (Data {value, ...}) =
case !value of
Undefined => str "undefined datatype"
@@ -286,7 +288,8 @@
Trace.traceInfo
(globalsInfo,
(Vector.layout layout) o #1,
- Option.layout (Vector.layout (Layout.tuple2 (Var.layout, Type.layout))),
+ Option.layout (Vector.layout
+ (Layout.tuple2 (Var.layout, Type.layout))),
Trace.assertTrue)
(fn (vs: t vector, newGlobal) =>
DynamicWind.withEscape
@@ -341,7 +344,14 @@
| _ => No
val g =
case value of
- Const (Const.T {const, ...}) =>
+ Array {birth, length, ...} =>
+ unary (birth, fn _ => length,
+ fn {args, targs} =>
+ Exp.PrimApp {args = args,
+ prim = Prim.array,
+ targs = targs},
+ Type.dearray ty)
+ | Const (Const.T {const, ...}) =>
(case !const of
Const.Const c => yes (Exp.Const c)
| _ => No)
@@ -362,20 +372,16 @@
prim = Prim.reff,
targs = targs},
Type.deref ty)
- | Array {birth, length, ...} =>
- unary (birth, fn _ => length,
- fn {args, targs} =>
- Exp.PrimApp {args = args,
- prim = Prim.array,
- targs = targs},
- Type.dearray ty)
- | Vector _ => No
| Tuple vs =>
(case globals (vs, newGlobal) of
NONE => No
| SOME xts =>
yes (Exp.Tuple (Vector.map (xts, #1))))
- in r := g; global (v, newGlobal)
+ | Vector _ => No
+ | Weak _ => No
+ val _ = r := g
+ in
+ global (v, newGlobal)
end
end) arg
@@ -384,7 +390,6 @@
ty = ty,
global = ref NotComputed})
-
fun tuple vs =
new (Tuple vs, Type.tuple (Vector.map (vs, ty)))
@@ -455,10 +460,16 @@
case value v of
Ref fs => sel fs
| _ => Error.bug err
- in val deref = make ("deref", #arg)
+ in
+ val deref = make ("deref", #arg)
val refBirth = make ("refBirth", #birth)
end
+ fun deweak v =
+ case value v of
+ Weak v => v
+ | _ => Error.bug "deweak"
+
structure Data =
struct
datatype t = datatype data
@@ -483,15 +494,16 @@
fun loop (t: Type.t): t =
new
(case Type.dest t of
- Type.Datatype _ => Datatype (data ())
- | Type.Ref t => Ref {birth = refBirth (),
- arg = loop t}
- | Type.Array t => Array {birth = arrayBirth (),
- length = loop Type.int,
- elt = loop t}
- | Type.Vector t => Vector {length = loop Type.int,
- elt = loop t}
+ Type.Array t => Array {birth = arrayBirth (),
+ elt = loop t,
+ length = loop Type.int}
+ | Type.Datatype _ => Datatype (data ())
+ | Type.Ref t => Ref {arg = loop t,
+ birth = refBirth ()}
| Type.Tuple ts => Tuple (Vector.map (ts, loop))
+ | Type.Vector t => Vector {elt = loop t,
+ length = loop Type.int}
+ | Type.Weak t => Weak (loop t)
| _ => Const (const ()),
t)
in loop
@@ -648,6 +660,7 @@
(coerce {from = n, to = n'}
; coerce {from = x, to = x'})
| (Tuple vs, Tuple vs') => coerces {froms = vs, tos = vs'}
+ | (Weak v, Weak v') => unify (v, v')
| (Const (Const.T {const = ref (Const.Const c), coercedTo}),
Vector {length, elt}) =>
let
@@ -698,6 +711,7 @@
(unify (n, n')
; unify (x, x'))
| (Tuple vs, Tuple vs') => Vector.foreach2 (vs, vs', unify)
+ | (Weak v, Weak v') => unify (v, v')
| _ => Error.bug "strange unify"
end
and unifyData (d, d') =
@@ -723,22 +737,24 @@
end
fun makeUnknown (v: t): unit =
case value v of
- Const c => Const.makeUnknown c
+ Array {length, elt, ...} => (makeUnknown length
+ ; makeUnknown elt)
+ | Const c => Const.makeUnknown c
| Datatype d => makeDataUnknown d
| Ref {arg, ...} => makeUnknown arg
- | Array {length, elt, ...} => (makeUnknown length
- ; makeUnknown elt)
+ | Tuple vs => Vector.foreach (vs, makeUnknown)
| Vector {length, elt} => (makeUnknown length
; makeUnknown elt)
- | Tuple vs => Vector.foreach (vs, makeUnknown)
+ | Weak v => makeUnknown v
fun sideEffect (v: t): unit =
case value v of
- Const _ => ()
+ Array {elt, ...} => makeUnknown elt
+ | Const _ => ()
| Datatype _ => ()
| Ref {arg, ...} => makeUnknown arg
- | Array {elt, ...} => makeUnknown elt
| Vector {elt, ...} => makeUnknown elt
| Tuple vs => Vector.foreach (vs, sideEffect)
+ | Weak v => makeUnknown v
fun primApp {prim,
targs,
args: Value.t vector,
@@ -780,13 +796,23 @@
let
val v = arg 0
val r = fromType resultType
- in coerce {from = v, to = deref r}
- ; Birth.coerce {from = bear {init = v}, to = refBirth r}
- ; r
+ val _ = coerce {from = v, to = deref r}
+ val _ = Birth.coerce {from = bear {init = v},
+ to = refBirth r}
+ in
+ r
end
| Vector_fromArray => vectorFromArray (arg 0)
| Vector_length => vectorLength (arg 0)
| Vector_sub => devector (arg 0)
+ | Weak_get => deweak (arg 0)
+ | Weak_new =>
+ let
+ val w = fromType resultType
+ val _ = coerce {from = arg 0, to = deweak w}
+ in
+ w
+ end
| _ => (if Prim.maySideEffect prim
then Vector.foreach (args, sideEffect)
else ()
1.57 +8 -5 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- ssa-tree.fun 12 Feb 2003 05:11:28 -0000 1.56
+++ ssa-tree.fun 18 Apr 2003 22:45:00 -0000 1.57
@@ -34,6 +34,7 @@
| Thread
| Tuple of t vector
| Vector of t
+ | Weak of t
| Word
| Word8
@@ -52,19 +53,20 @@
else Error.bug "bogus application of unary tycon"
val tycons =
- [(Tycon.tuple, Tuple),
+ [(Tycon.array, unary Array),
(Tycon.char, nullary Char),
(Tycon.int, nullary Int),
(Tycon.intInf, nullary IntInf),
(Tycon.pointer, nullary Pointer),
(Tycon.preThread, nullary PreThread),
(Tycon.real, nullary Real),
+ (Tycon.reff, unary Ref),
(Tycon.thread, nullary Thread),
- (Tycon.word8, nullary Word8),
- (Tycon.word, nullary Word),
- (Tycon.array, unary Array),
+ (Tycon.tuple, Tuple),
(Tycon.vector, unary Vector),
- (Tycon.reff, unary Ref)]
+ (Tycon.weak, unary Weak),
+ (Tycon.word, nullary Word),
+ (Tycon.word8, nullary Word8)]
in
val _ = List.foreach (tycons, fn (tycon, f) => set (tycon, SOME f))
@@ -102,6 +104,7 @@
else paren (seq (separate (Vector.toListMap (ts, layout),
" * ")))
| Vector t => seq [layout t, str " vector"]
+ | Weak t => seq [layout t, str " weak"]
| Word => str "word"
| Word8 => str "word8"))
end
1.46 +1 -0 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- ssa-tree.sig 12 Feb 2003 05:11:28 -0000 1.45
+++ ssa-tree.sig 18 Apr 2003 22:45:00 -0000 1.46
@@ -73,6 +73,7 @@
| Thread
| Tuple of t vector
| Vector of t
+ | Weak of t
| Word
| Word8
1.17 +187 -139 mlton/mlton/ssa/useless.fun
Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- useless.fun 11 Jan 2003 00:34:40 -0000 1.16
+++ useless.fun 18 Apr 2003 22:45:00 -0000 1.17
@@ -69,21 +69,21 @@
end
datatype t =
- T of {
+ T of {new: (Type.t * bool) option ref,
ty: Type.t,
- new: (Type.t * bool) option ref,
- value: value
- } Set.t
+ value: value} Set.t
and value =
- Array of {useful: Useful.t,
+ Array of {elt: slot,
length: t,
- elt: slot}
- | Ground of Useful.t
- | Ref of {useful: Useful.t,
- arg: slot}
- | Tuple of slot vector
- | Vector of {length: t,
- elt: slot}
+ useful: Useful.t}
+ | Ground of Useful.t
+ | Ref of {arg: slot,
+ useful: Useful.t}
+ | Tuple of slot vector
+ | Vector of {elt: slot,
+ length: t}
+ | Weak of {arg: slot,
+ useful: Useful.t}
withtype slot = t * Exists.t
local
@@ -97,18 +97,24 @@
open Layout
in
fun layout (T s) =
- let val {value, ...} = Set.value s
- in case value of
- Ground g => seq [str "ground ", Useful.layout g]
- | Tuple vs => Vector.layout layoutSlot vs
- | Ref {arg, useful, ...} =>
- seq [str "ref ",
- record [("useful", Useful.layout useful),
- ("slot", layoutSlot arg)]]
- | Vector {elt, length} =>
- seq [str "vector", tuple [layout length, layoutSlot elt]]
- | Array {elt, length, ...} =>
- seq [str "array", tuple [layout length, layoutSlot elt]]
+ let
+ val {value, ...} = Set.value s
+ in
+ case value of
+ Array {elt, length, ...} =>
+ seq [str "array", tuple [layout length, layoutSlot elt]]
+ | Ground g => seq [str "ground ", Useful.layout g]
+ | Ref {arg, useful, ...} =>
+ seq [str "ref ",
+ record [("useful", Useful.layout useful),
+ ("slot", layoutSlot arg)]]
+ | Tuple vs => Vector.layout layoutSlot vs
+ | Vector {elt, length} =>
+ seq [str "vector", tuple [layout length, layoutSlot elt]]
+ | Weak {arg, useful} =>
+ seq [str "weak ",
+ record [("useful", Useful.layout useful),
+ ("slot", layoutSlot arg)]]
end
and layoutSlot (v, e) =
tuple [Exists.layout e, layout v]
@@ -117,24 +123,29 @@
fun unify (T s, T s') =
if Set.equals (s, s')
then ()
- else let val {value = v, ...} = Set.value s
- val {value = v', ...} = Set.value s'
- in Set.union (s, s')
- ; (case (v, v') of
- (Ground g, Ground g') => Useful.== (g, g')
- | (Tuple vs, Tuple vs') =>
- Vector.foreach2 (vs, vs', unifySlot)
- | (Ref {useful = u, arg = a},
- Ref {useful = u', arg = a'}) =>
- (Useful.== (u, u'); unifySlot (a, a'))
- | (Array {length = n, elt = e, ...},
- Array {length = n', elt = e', ...}) =>
- (unify (n, n'); unifySlot (e, e'))
- | (Vector {length = n, elt = e},
- Vector {length = n', elt = e'}) =>
- (unify (n, n'); unifySlot (e, e'))
- | _ => Error.bug "strange unify")
- end
+ else
+ let
+ val {value = v, ...} = Set.value s
+ val {value = v', ...} = Set.value s'
+ val _ = Set.union (s, s')
+ in
+ case (v, v') of
+ (Array {length = n, elt = e, ...},
+ Array {length = n', elt = e', ...}) =>
+ (unify (n, n'); unifySlot (e, e'))
+ | (Ground g, Ground g') => Useful.== (g, g')
+ | (Ref {useful = u, arg = a},
+ Ref {useful = u', arg = a'}) =>
+ (Useful.== (u, u'); unifySlot (a, a'))
+ | (Tuple vs, Tuple vs') =>
+ Vector.foreach2 (vs, vs', unifySlot)
+ | (Vector {length = n, elt = e},
+ Vector {length = n', elt = e'}) =>
+ (unify (n, n'); unifySlot (e, e'))
+ | (Weak {useful = u, arg = a}, Weak {useful = u', arg = a'}) =>
+ (Useful.== (u, u'); unifySlot (a, a'))
+ | _ => Error.bug "strange unify"
+ end
and unifySlot ((v, e), (v', e')) = (unify (v, v'); Exists.== (e, e'))
fun coerce {from = from as T sfrom, to = to as T sto}: unit =
@@ -145,16 +156,19 @@
fun coerceSlot ((v, e), (v', e')) =
(coerce {from = v, to = v'}
; Exists.== (e, e'))
- in case (value from, value to) of
- (Ground to, Ground from) => Useful.<= (from, to)
- | (Tuple vs, Tuple vs') =>
- Vector.foreach2 (vs, vs', coerceSlot)
- | (Ref _, Ref _) => unify (from, to)
- | (Array _, Array _) => unify (from, to)
- | (Vector {length = n, elt = e}, Vector {length = n', elt = e'}) =>
- (coerce {from = n, to = n'}
- ; coerceSlot (e, e'))
- | _ => Error.bug "strange coerce"
+ in
+ case (value from, value to) of
+ (Array _, Array _) => unify (from, to)
+ | (Ground to, Ground from) => Useful.<= (from, to)
+ | (Ref _, Ref _) => unify (from, to)
+ | (Tuple vs, Tuple vs') =>
+ Vector.foreach2 (vs, vs', coerceSlot)
+ | (Vector {length = n, elt = e},
+ Vector {length = n', elt = e'}) =>
+ (coerce {from = n, to = n'}
+ ; coerceSlot (e, e'))
+ | (Weak _, Weak _) => unify (from, to)
+ | _ => Error.bug "strange coerce"
end
val coerce =
@@ -174,14 +188,16 @@
let
fun loop (v: t): unit =
case value v of
- Ground u => f u
- | Vector {length, elt} => (loop length; slot elt)
- | Array {length, elt, useful} =>
+ Array {length, elt, useful} =>
(f useful; loop length; slot elt)
- | Ref {useful, arg} => (f useful; slot arg)
+ | Ground u => f u
| Tuple vs => Vector.foreach (vs, slot)
+ | Ref {arg, useful} => (f useful; slot arg)
+ | Vector {length, elt} => (loop length; slot elt)
+ | Weak {arg, useful} => (f useful; slot arg)
and slot (v, _) = loop v
- in loop v
+ in
+ loop v
end
(* Coerce every ground value in v to u. *)
@@ -204,11 +220,12 @@
fun someUseful (v: t): Useful.t option =
case value v of
- Ground u => SOME u
- | Array {useful = u, ...} => SOME u
+ Array {useful = u, ...} => SOME u
+ | Ground u => SOME u
| Ref {useful = u, ...} => SOME u
| Tuple slots => Vector.peekMap (slots, someUseful o #1)
| Vector {length, ...} => SOME (deground length)
+ | Weak {useful = u, ...} => SOME u
fun allOrNothing (v: t): Useful.t option =
case someUseful v of
@@ -233,9 +250,7 @@
val loop = fn t => loop (t, es)
val value =
case Type.dest t of
- Type.Ref t => Ref {useful = useful (),
- arg = slot t}
- | Type.Array t =>
+ Type.Array t =>
let val elt as (_, e) = slot t
val length = loop Type.int
in Exists.addHandler
@@ -244,15 +259,21 @@
length = length,
elt = elt}
end
+ | Type.Ref t => Ref {arg = slot t,
+ useful = useful ()}
+ | Type.Tuple ts => Tuple (Vector.map (ts, slot))
| Type.Vector t => Vector {length = loop Type.int,
elt = slot t}
- | Type.Tuple ts => Tuple (Vector.map (ts, slot))
+ | Type.Weak t => Weak {arg = slot t,
+ useful = useful ()}
| _ => Ground (useful ())
- in T (Set.singleton {ty = t,
+ in
+ T (Set.singleton {ty = t,
new = ref NONE,
value = value})
end
- in loop (t, [])
+ in
+ loop (t, [])
end
val const = fromType o Type.ofConst
@@ -264,24 +285,30 @@
| _ => Error.bug "detuple"
fun detuple v = Vector.map (detupleSlots v, #1)
fun tuple (vs: t vector): t =
- let val t = Type.tuple (Vector.map (vs, ty))
- val v = fromType t
- in Vector.foreach2 (vs, detuple v, fn (v, v') =>
- coerce {from = v, to = v'})
- ; v
+ let
+ val t = Type.tuple (Vector.map (vs, ty))
+ val v = fromType t
+ val _ =
+ Vector.foreach2 (vs, detuple v, fn (v, v') =>
+ coerce {from = v, to = v'})
+ in
+ v
end
val unit = tuple (Vector.new0 ())
fun select {tuple, offset, resultType} =
- let val v = fromType resultType
- in coerce {from = Vector.sub (detuple tuple, offset), to = v}
- ; v
+ let
+ val v = fromType resultType
+ val _ = coerce {from = Vector.sub (detuple tuple, offset), to = v}
+ in
+ v
end
local
fun make (err, sel) v =
case value v of
Vector fs => sel fs
| _ => Error.bug err
- in val devector = make ("devector", #1 o #elt)
+ in
+ val devector = make ("devector", #1 o #elt)
val vectorLength = make ("vectorLength", #length)
end
local
@@ -289,7 +316,8 @@
case value v of
Array fs => sel fs
| _ => Error.bug err
- in val dearray: t -> t = make ("dearray", #1 o #elt)
+ in
+ val dearray: t -> t = make ("dearray", #1 o #elt)
val arrayLength = make ("arrayLength", #length)
val arrayUseful = make ("arrayUseful", #useful)
end
@@ -299,49 +327,62 @@
Ref {arg, ...} => #1 arg
| _ => Error.bug "deref"
+ fun deweak (v: t): t =
+ case value v of
+ Weak {arg, ...} => #1 arg
+ | _ => Error.bug "deweak"
+
fun newType (v: t): Type.t = #1 (getNew v)
and isUseful (v: t): bool = #2 (getNew v)
and getNew (T s): Type.t * bool =
- let val {value, ty, new, ...} = Set.value s
- in case !new of
- SOME z => z
- | NONE =>
- let
- fun slot (arg: t, e: Exists.t) =
- let val (t, b) = getNew arg
- in (if Exists.doesExist e then t else Type.unit, b)
- end
- fun wrap ((t, b), f) = (f t, b)
- fun or ((t, b), b') = (t, b orelse b')
- fun maybe (u: Useful.t, s: slot, make: Type.t -> Type.t) =
- wrap (or (slot s, Useful.isUseful u), make)
- val z =
- case value of
- Ground u => (ty, Useful.isUseful u)
- | Ref {useful, arg, ...} => maybe (useful, arg, Type.reff)
- | Array {useful, elt, length, ...} =>
- or (wrap (slot elt, Type.array),
- Useful.isUseful useful orelse isUseful length)
- | Vector {elt, length, ...} =>
- or (wrap (slot elt, Type.vector), isUseful length)
- | Tuple vs =>
- let
- val (v, b) =
- Vector.mapAndFold
- (vs, false, fn ((v, e), useful) =>
- let
- val (t, u) = getNew v
- val t =
- if Exists.doesExist e
- then SOME t
- else NONE
- in (t, u orelse useful)
- end)
- val v = Vector.keepAllMap (v, fn t => t)
- in (Type.tuple v, b)
- end
- in new := SOME z; z
- end
+ let
+ val {value, ty, new, ...} = Set.value s
+ in
+ case !new of
+ SOME z => z
+ | NONE =>
+ let
+ fun slot (arg: t, e: Exists.t) =
+ let val (t, b) = getNew arg
+ in (if Exists.doesExist e then t else Type.unit, b)
+ end
+ fun wrap ((t, b), f) = (f t, b)
+ fun or ((t, b), b') = (t, b orelse b')
+ fun maybe (u: Useful.t, s: slot, make: Type.t -> Type.t) =
+ wrap (or (slot s, Useful.isUseful u), make)
+ val z =
+ case value of
+ Array {useful, elt, length, ...} =>
+ or (wrap (slot elt, Type.array),
+ Useful.isUseful useful orelse isUseful length)
+ | Ground u => (ty, Useful.isUseful u)
+ | Ref {arg, useful, ...} =>
+ maybe (useful, arg, Type.reff)
+ | Tuple vs =>
+ let
+ val (v, b) =
+ Vector.mapAndFold
+ (vs, false, fn ((v, e), useful) =>
+ let
+ val (t, u) = getNew v
+ val t =
+ if Exists.doesExist e
+ then SOME t
+ else NONE
+ in (t, u orelse useful)
+ end)
+ val v = Vector.keepAllMap (v, fn t => t)
+ in
+ (Type.tuple v, b)
+ end
+ | Vector {elt, length, ...} =>
+ or (wrap (slot elt, Type.vector), isUseful length)
+ | Weak {arg, useful} =>
+ maybe (useful, arg, Type.weak)
+ val _ = new := SOME z
+ in
+ z
+ end
end
val getNew =
@@ -420,29 +461,33 @@
* components of its args that a primitive will look at.
*)
fun deepMakeUseful v =
- let val slot = deepMakeUseful o #1
- in case value v of
- Ground u =>
- (Useful.makeUseful u
- (* Make all constructor args of this tycon useful *)
- ; (case Type.dest (ty v) of
- Type.Datatype tycon =>
- let val {useful, cons} = tyconInfo tycon
- in if !useful
- then ()
- else (useful := true
- ; Vector.foreach (cons, fn con =>
- Vector.foreach
- (#args (conInfo con),
- deepMakeUseful)))
- end
- | _ => ()))
- | Tuple vs => Vector.foreach (vs, slot)
- | Ref {useful, arg} => (Useful.makeUseful useful; slot arg)
- | Vector {length, elt} => (deepMakeUseful length; slot elt)
- | Array {useful, length, elt} => (Useful.makeUseful useful
- ; deepMakeUseful length
- ; slot elt)
+ let
+ val slot = deepMakeUseful o #1
+ in
+ case value v of
+ Array {useful, length, elt} =>
+ (Useful.makeUseful useful
+ ; deepMakeUseful length
+ ; slot elt)
+ | Ground u =>
+ (Useful.makeUseful u
+ (* Make all constructor args of this tycon useful *)
+ ; (case Type.dest (ty v) of
+ Type.Datatype tycon =>
+ let val {useful, cons} = tyconInfo tycon
+ in if !useful
+ then ()
+ else (useful := true
+ ; Vector.foreach (cons, fn con =>
+ Vector.foreach
+ (#args (conInfo con),
+ deepMakeUseful)))
+ end
+ | _ => ()))
+ | Ref {arg, useful} => (Useful.makeUseful useful; slot arg)
+ | Tuple vs => Vector.foreach (vs, slot)
+ | Vector {length, elt} => (deepMakeUseful length; slot elt)
+ | Weak {arg, useful} => (Useful.makeUseful useful; slot arg)
end
type value = t
@@ -485,6 +530,8 @@
| Vector_length => return (vectorLength (arg 0))
| Vector_sub => (arg 1 dependsOn result
; return (devector (arg 0)))
+ | Weak_get => return (deweak (arg 0))
+ | Weak_new => coerce {from = arg 0, to = deweak result}
| Word8Array_subWord => sub ()
| Word8Array_updateWord => update ()
| _ =>
@@ -719,7 +766,8 @@
dearray = Type.dearray,
dearrow = Type.dearrow,
deref = Type.deref,
- devector = Type.devector}}
+ devector = Type.devector,
+ deweak = Type.deweak}}
end
| Select {tuple, offset} =>
let
1.6 +1 -0 mlton/mlyacc/mlyacc-stubs.cm
Index: mlyacc-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc-stubs.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mlyacc-stubs.cm 11 Apr 2003 04:31:11 -0000 1.5
+++ mlyacc-stubs.cm 18 Apr 2003 22:45:01 -0000 1.6
@@ -46,6 +46,7 @@
../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
+../lib/mlton-stubs/weak.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
../lib/mlton-stubs/io.sig
1.1 mlton/regression/weak.ok
Index: weak.ok
===================================================================
13
12345678901234567890
1
12345
1.1 mlton/regression/weak.sml
Index: weak.sml
===================================================================
structure Weak = MLton.Weak
val w = Weak.new 13
val _ =
if isSome (Weak.get w)
then raise Fail "bug int"
else ()
fun testIntInf (i: IntInf.int) =
let
val w = Weak.new i
val _ =
case Weak.get w of
NONE => raise Fail "bug IntInf"
| SOME i => print (concat [IntInf.toString i, "\n"])
in
()
end
val _ = testIntInf 13
val _ = testIntInf 12345678901234567890
val r = ref 13
val n = 2
val rs = Array.tabulate (n, ref)
val ws = Array.tabulate (n, fn i => Weak.new (Array.sub (rs, i)))
fun isAlive i = isSome (Weak.get (Array.sub (ws, i)))
val _ = MLton.GC.collect ()
val _ =
if isAlive 0 andalso isAlive 1
then ()
else raise Fail "bug1"
fun clear i = Array.update (rs, i, r)
fun sub i = ! (Array.sub (rs, i))
fun pi x = print (concat [Int.toString x, "\n"])
val _ = pi (sub 0 + sub 1)
val _ = valOf (Weak.get (Array.sub (ws, 0))) := 12345
val _ = clear 1
val _ = MLton.GC.collect ()
val _ =
if isAlive 0 andalso not (isAlive 1)
then ()
else raise Fail "bug2"
val _ = pi (sub 0)
val _ = clear 0
val _ = MLton.GC.collect ()
val _ =
if not (isAlive 0) andalso not (isAlive 1)
then ()
else raise Fail "bug2"
1.128 +197 -29 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.127
retrieving revision 1.128
diff -u -r1.127 -r1.128
--- gc.c 10 Apr 2003 02:03:10 -0000 1.127
+++ gc.c 18 Apr 2003 22:45:02 -0000 1.128
@@ -78,6 +78,7 @@
DEBUG_SIGNALS = FALSE,
DEBUG_STACKS = FALSE,
DEBUG_THREADS = FALSE,
+ DEBUG_WEAK = FALSE,
FORWARDED = 0xFFFFFFFF,
HEADER_SIZE = WORD_SIZE,
PROFILE_ALLOC_MISC = 0,
@@ -92,6 +93,7 @@
#define STACK_HEADER GC_objectHeader (STACK_TYPE_INDEX)
#define STRING_HEADER GC_objectHeader (STRING_TYPE_INDEX)
#define THREAD_HEADER GC_objectHeader (THREAD_TYPE_INDEX)
+#define WEAK_GONE_HEADER GC_objectHeader (WEAK_GONE_TYPE_INDEX)
#define WORD8_VECTOR_HEADER GC_objectHeader (WORD8_TYPE_INDEX)
#define SPLIT_HEADER() \
@@ -120,6 +122,8 @@
return "NORMAL";
case STACK_TAG:
return "STACK";
+ case WEAK_TAG:
+ return "WEAK";
default:
die ("bad tag %u", t);
}
@@ -698,6 +702,7 @@
s->frontier = p;
}
+/* bytesRequested includes the header. */
static pointer object (GC_state s, uint header, W32 bytesRequested,
bool allocInOldGen) {
pointer frontier;
@@ -819,13 +824,16 @@
/* ---------------------------------------------------------------- */
/* foreachPointerInObject */
/* ---------------------------------------------------------------- */
-/* foreachPointerInObject (s, f, p) applies f to each pointer in the object
+/* foreachPointerInObject (s, p,f, ws) applies f to each pointer in the object
* pointer to by p.
* Returns pointer to the end of object, i.e. just past object.
+ *
+ * If ws, then the object pointer in weak objects is skipped.
*/
-static inline pointer foreachPointerInObject (GC_state s, GC_pointerFun f,
- pointer p) {
+static inline pointer foreachPointerInObject (GC_state s, pointer p,
+ Bool skipWeaks,
+ GC_pointerFun f) {
word header;
uint numPointers;
uint numNonPointers;
@@ -849,6 +857,10 @@
(uint)p, *(uint*)p);
maybeCall (f, s, (pointer*)p);
}
+ } else if (WEAK_TAG == tag) {
+ if (not skipWeaks and 1 == numPointers)
+ maybeCall (f, s, (pointer*)&(((GC_weak)p)->object));
+ p += 2 * WORD_SIZE;
} else if (ARRAY_TAG == tag) {
uint numBytes;
pointer max;
@@ -881,8 +893,8 @@
maybeCall(f, s, (pointer*)p);
}
}
- assert(p == max);
- } else {
+ assert (p == max);
+ } else { /* stack */
GC_stack stack;
pointer top, bottom;
int i;
@@ -950,18 +962,21 @@
/* foreachPointerInRange */
/* ---------------------------------------------------------------- */
-/* foreachPointerInRange (s, front, back, f)
+/* foreachPointerInRange (s, front, back, ws, f)
* Apply f to each pointer between front and *back, which should be a
* contiguous sequence of objects, where front points at the beginning of
* the first object and *back points just past the end of the last object.
* f may increase *back (for example, this is done by forward).
- * foreachPointerInRange returns apointer to the end of the last object it
+ * foreachPointerInRange returns a pointer to the end of the last object it
* visits.
+ *
+ * If ws, then the object pointer in weak objects is skipped.
*/
static inline pointer foreachPointerInRange (GC_state s,
pointer front,
pointer *back,
+ Bool skipWeaks,
GC_pointerFun f) {
pointer b;
@@ -976,7 +991,8 @@
if (DEBUG_DETAILED)
fprintf (stderr, "front = 0x%08x *back = 0x%08x\n",
(uint)front, *(uint*)back);
- front = foreachPointerInObject (s, f, toData (front));
+ front = foreachPointerInObject
+ (s, toData (front), skipWeaks, f);
}
b = *back;
}
@@ -995,16 +1011,16 @@
and s->copyRatio <= s->liveRatio;
}
+static inline bool isInNursery (GC_state s, pointer p) {
+ return s->nursery <= p and p < s->frontier;
+}
+
#if ASSERT
static inline bool isInOldGen (GC_state s, pointer p) {
return s->heap.start <= p and p < s->heap.start + s->oldGenSize;
}
-static inline bool isInNursery (GC_state s, pointer p) {
- return s->nursery <= p and p < s->frontier;
-}
-
static inline bool isInFromSpace (GC_state s, pointer p) {
return (isInOldGen (s, p) or isInNursery (s, p));
}
@@ -1087,10 +1103,12 @@
back = s->heap.start + s->oldGenSize;
if (DEBUG_DETAILED)
fprintf (stderr, "Checking old generation.\n");
- foreachPointerInRange (s, s->heap.start, &back, assertIsInFromSpace);
+ foreachPointerInRange (s, s->heap.start, &back, FALSE,
+ assertIsInFromSpace);
if (DEBUG_DETAILED)
fprintf (stderr, "Checking nursery.\n");
- foreachPointerInRange (s, s->nursery, &s->frontier, assertIsInFromSpace);
+ foreachPointerInRange (s, s->nursery, &s->frontier, FALSE,
+ assertIsInFromSpace);
/* Current thread. */
stack = s->currentThread->stack;
assert (isAligned (stack->reserved, WORD_SIZE));
@@ -1453,8 +1471,7 @@
}
}
-static inline uint objectSize (GC_state s, pointer p)
-{
+static inline uint objectSize (GC_state s, pointer p) {
uint headerBytes, objectBytes;
word header;
uint tag, numPointers, numNonPointers;
@@ -1464,13 +1481,16 @@
if (NORMAL_TAG == tag) { /* Fixed size object. */
headerBytes = GC_NORMAL_HEADER_SIZE;
objectBytes = toBytes (numPointers + numNonPointers);
- } else if (STACK_TAG == tag) { /* Stack. */
- headerBytes = STACK_HEADER_SIZE;
- objectBytes = sizeof(struct GC_stack) + ((GC_stack)p)->reserved;
- } else { /* Array. */
- assert(ARRAY_TAG == tag);
+ } else if (ARRAY_TAG == tag) {
headerBytes = GC_ARRAY_HEADER_SIZE;
objectBytes = arrayNumBytes (p, numPointers, numNonPointers);
+ } else if (WEAK_TAG == tag) {
+ headerBytes = GC_NORMAL_HEADER_SIZE;
+ objectBytes = 2 * WORD_SIZE;
+ } else { /* Stack. */
+ assert (STACK_TAG == tag);
+ headerBytes = STACK_HEADER_SIZE;
+ objectBytes = sizeof(struct GC_stack) + ((GC_stack)p)->reserved;
}
return headerBytes + objectBytes;
}
@@ -1493,10 +1513,10 @@
word tag;
if (DEBUG_DETAILED)
- fprintf(stderr, "forward pp = 0x%x *pp = 0x%x\n", (uint)pp, *(uint*)pp);
+ fprintf (stderr, "forward pp = 0x%x *pp = 0x%x\n", (uint)pp, *(uint*)pp);
assert (isInFromSpace (s, *pp));
p = *pp;
- header = GC_getHeader(p);
+ header = GC_getHeader (p);
if (header != FORWARDED) { /* forward the object */
uint headerBytes, objectBytes, size, skip;
uint numPointers, numNonPointers;
@@ -1512,6 +1532,10 @@
objectBytes = arrayNumBytes (p, numPointers,
numNonPointers);
skip = 0;
+ } else if (WEAK_TAG == tag) {
+ headerBytes = GC_NORMAL_HEADER_SIZE;
+ objectBytes = 2 * WORD_SIZE;
+ skip = 0;
} else { /* Stack. */
GC_stack stack;
@@ -1547,6 +1571,25 @@
fprintf (stderr, "copying from 0x%08x to 0x%08x of size %u\n",
(uint)p, (uint)s->back, size);
copy (p - headerBytes, s->back, size);
+ if (WEAK_TAG == tag and 1 == numPointers) {
+ GC_weak w;
+
+ w = (GC_weak)(s->back + GC_NORMAL_HEADER_SIZE);
+ if (DEBUG_WEAK)
+ fprintf (stderr, "forwarding weak 0x%08x ",
+ (uint)w);
+ if (GC_isPointer (w->object)
+ and (not s->amInMinorGC
+ or isInNursery (s, w->object))) {
+ if (DEBUG_WEAK)
+ fprintf (stderr, "linking\n");
+ w->link = s->weaks;
+ s->weaks = w;
+ } else {
+ if (DEBUG_WEAK)
+ fprintf (stderr, "not linking\n");
+ }
+ }
#if METER
if (size < sizeof(sizes)/sizeof(sizes[0])) sizes[size]++;
#endif
@@ -1562,6 +1605,28 @@
assert (isInToSpace (s, *pp));
}
+static void updateWeaks (GC_state s) {
+ GC_weak w;
+
+ for (w = s->weaks; w != NULL; w = w->link) {
+ assert ((pointer)BOGUS_POINTER != w->object);
+
+ if (DEBUG_WEAK)
+ fprintf (stderr, "updateWeaks w = 0x%08x ", (uint)w);
+ if (FORWARDED == GC_getHeader ((pointer)w->object)) {
+ if (DEBUG_WEAK)
+ fprintf (stderr, "forwarded\n");
+ w->object = *(pointer*)w->object;
+ } else {
+ if (DEBUG_WEAK)
+ fprintf (stderr, "cleared\n");
+ *(GC_getHeaderp((pointer)w)) = WEAK_GONE_HEADER;
+ w->object = (pointer)BOGUS_POINTER;
+ }
+ }
+ s->weaks = NULL;
+}
+
static void swapSemis (GC_state s) {
struct GC_heap h;
@@ -1599,7 +1664,8 @@
clearCrossMap (s);
s->back = s->heap2.start;
foreachGlobal (s, forward);
- foreachPointerInRange (s, s->heap2.start, &s->back, forward);
+ foreachPointerInRange (s, s->heap2.start, &s->back, TRUE, forward);
+ updateWeaks (s);
s->oldGenSize = s->back - s->heap2.start;
s->bytesCopied += s->oldGenSize;
if (DEBUG)
@@ -1686,8 +1752,15 @@
cardEnd = oldGenEnd;
assert (objectStart < cardEnd);
orig = objectStart;
+ /* If we ever add Weak.set, then there could be intergenerational
+ * weak pointers, in which case we would need to link the weak
+ * objects into s->weaks. But for now, since there is no
+ * Weak.set, the foreachPointerInRange will do the right thing
+ * on weaks, since the weak pointer will never be into the
+ * nursery.
+ */
objectStart =
- foreachPointerInRange (s, objectStart, &cardEnd,
+ foreachPointerInRange (s, objectStart, &cardEnd, FALSE,
forwardIfInNursery);
s->minorBytesScanned += objectStart - orig;
if (objectStart == oldGenEnd)
@@ -1730,6 +1803,7 @@
if (DEBUG_GENERATIONAL or s->messages)
fprintf (stderr, "Minor GC.\n");
startTiming (&ru_start);
+ s->amInMinorGC = TRUE;
s->toSpace = s->heap.start + s->oldGenSize;
s->toLimit = s->toSpace + s->nurserySize;
assert (invariant (s));
@@ -1742,11 +1816,13 @@
*/
foreachGlobal (s, forwardIfInNursery);
forwardInterGenerationalPointers (s);
- foreachPointerInRange (s, s->toSpace, &s->back,
+ foreachPointerInRange (s, s->toSpace, &s->back, TRUE,
forwardIfInNursery);
+ updateWeaks (s);
bytesCopied = s->back - s->toSpace;
s->bytesCopiedMinor += bytesCopied;
s->oldGenSize += bytesCopied;
+ s->amInMinorGC = FALSE;
stopTiming (&ru_start, &s->ru_gcMinor);
if (DEBUG_GENERATIONAL or s->messages)
fprintf (stderr, "Minor GC done. %s bytes copied.\n",
@@ -1874,6 +1950,10 @@
headerp = nextHeaderp;
header = nextHeader;
goto markNext;
+ } else if (WEAK_TAG == tag) {
+ /* Store the marked header and don't follow any pointers. */
+ *headerp = header;
+ goto ret;
} else if (ARRAY_TAG == tag) {
numBytes = arrayNumBytes (cur, numPointers, numNonPointers);
size += GC_ARRAY_HEADER_SIZE + numBytes;
@@ -1971,6 +2051,10 @@
headerp = GC_getHeaderp (prev);
header = *headerp;
SPLIT_HEADER();
+ /* It's impossible to get a WEAK_TAG here, since we would never follow
+ * the weak object pointer.
+ */
+ assert (WEAK_TAG != tag);
if (NORMAL_TAG == tag) {
todo = prev + toBytes (numNonPointers);
max = todo + toBytes (numPointers);
@@ -2034,6 +2118,38 @@
*headerp = (Header)pp;
}
+/* If p is weak, the object pointer was valid, and points to an unmarked object,
+ * then clear the object pointer.
+ */
+static inline void maybeClearWeak (GC_state s, pointer p) {
+ Header header;
+ Header *headerp;
+ uint numPointers;
+ uint numNonPointers;
+ uint tag;
+
+ headerp = GC_getHeaderp (p);
+ header = *headerp;
+ SPLIT_HEADER();
+ if (WEAK_TAG == tag and 1 == numPointers) {
+ Header h2;
+
+ if (DEBUG_WEAK)
+ fprintf (stderr, "maybeClearWeak (0x%08x) header = 0x%08x\n",
+ (uint)p, (uint)header);
+ h2 = GC_getHeader (((GC_weak)p)->object);
+ /* If it's unmarked not threaded, clear the weak pointer. */
+ if (1 == ((MARK_MASK | 1) & h2)) {
+ ((GC_weak)p)->object = (pointer)BOGUS_POINTER;
+ header = WEAK_GONE_HEADER | MARK_MASK;
+ if (DEBUG_WEAK)
+ fprintf (stderr, "cleared. new header = 0x%08x\n",
+ (uint)header);
+ *headerp = header;
+ }
+ }
+}
+
static void updateForwardPointers (GC_state s) {
pointer back;
pointer front;
@@ -2072,6 +2188,7 @@
* Thread internal pointers.
*/
thread:
+ maybeClearWeak (s, p);
size = objectSize (s, p);
if (DEBUG_MARK_COMPACT)
fprintf (stderr, "threading 0x%08x of size %u\n",
@@ -2100,7 +2217,7 @@
}
front += size;
endOfLastMarked = front;
- foreachPointerInObject (s, threadInternal, p);
+ foreachPointerInObject (s, p, FALSE, threadInternal);
goto updateObject;
} else {
/* It's not marked. */
@@ -2193,7 +2310,7 @@
pointer new;
/* It's a pointer. This object must be live. Fix all the
- * forward pointers to it. Then unmark it.
+ * backward pointers to it. Then unmark it.
*/
new = p - gap;
do {
@@ -2267,7 +2384,7 @@
/* Translate globals and heap. */
foreachGlobal (s, translatePointer);
limit = to + size;
- foreachPointerInRange (s, to, &limit, translatePointer);
+ foreachPointerInRange (s, to, &limit, FALSE, translatePointer);
}
/* ---------------------------------------------------------------- */
@@ -3699,6 +3816,7 @@
int i;
s->amInGC = TRUE;
+ s->amInMinorGC = FALSE;
s->bytesAllocated = 0;
s->bytesCopied = 0;
s->bytesCopiedMinor = 0;
@@ -3739,6 +3857,7 @@
s->startTime = currentTime ();
s->summary = FALSE;
s->useFixedHeap = FALSE;
+ s->weaks = NULL;
heapInit (&s->heap);
heapInit (&s->heap2);
sigemptyset (&s->signalsHandled);
@@ -4084,4 +4203,53 @@
fprintf (stderr, "Unpacked heap to size %s.\n",
uintToCommaString (s->heap.size));
leave (s);
+}
+
+/* ------------------------------------------------- */
+/* GC_weak* */
+/* ------------------------------------------------- */
+
+/* A weak object is a header followed by two words.
+ *
+ * The object type indexed by the header determines whether the weak is valid
+ * or not. If the type has numPointers == 1, then the weak pointer is valid.
+ * Otherwise, the type has numPointers == 0 and the weak pointer is not valid.
+ *
+ * The first word is used to chain the live weaks together during a copying gc
+ * and is otherwise unused.
+ *
+ * The second word is the weak pointer.
+ */
+
+Bool GC_weakCanGet (pointer p) {
+ Bool res;
+
+ res = WEAK_GONE_HEADER != GC_getHeader (p);
+ if (DEBUG_WEAK)
+ fprintf (stderr, "%s = GC_weakCanGet (0x%08x)\n",
+ boolToString (res), (uint)p);
+ return res;
+}
+
+pointer GC_weakGet (pointer p) {
+ pointer res;
+
+ res = ((GC_weak)p)->object;
+ if (DEBUG_WEAK)
+ fprintf (stderr, "0x%08x = GC_weakGet (0x%08x)\n",
+ (uint)res, (uint)p);
+ return res;
+}
+
+pointer GC_weakNew (GC_state s, W32 header, pointer p) {
+ pointer res;
+
+ res = object (s, header,
+ HEADER_SIZE + WORD_SIZE + WORD_SIZE,
+ FALSE);
+ ((GC_weak)res)->object = p;
+ if (DEBUG_WEAK)
+ fprintf (stderr, "0x%08x = GC_weakNew (0x%08x, 0x%08x)\n",
+ (uint)res, (uint)header, (uint)p);
+ return res;
}
1.58 +21 -1 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- gc.h 25 Mar 2003 04:31:25 -0000 1.57
+++ gc.h 18 Apr 2003 22:45:04 -0000 1.58
@@ -78,11 +78,15 @@
SOURCES_INDEX_GC = 1,
SOURCE_SEQ_GC = 1,
SOURCE_SEQ_UNKNOWN = 0,
+ /* The type indices here must agree with those in
+ * backend/machine-atoms.fun.
+ */
STACK_TYPE_INDEX = 0,
STRING_TYPE_INDEX = 1,
THREAD_TYPE_INDEX = 2,
+ WEAK_GONE_TYPE_INDEX = 3,
WORD8_VECTOR_TYPE_INDEX = STRING_TYPE_INDEX,
- WORD_VECTOR_TYPE_INDEX = 3,
+ WORD_VECTOR_TYPE_INDEX = 4,
};
#define BOGUS_THREAD (GC_thread)BOGUS_POINTER
@@ -97,6 +101,7 @@
ARRAY_TAG,
NORMAL_TAG,
STACK_TAG,
+ WEAK_TAG,
} GC_ObjectTypeTag;
typedef struct {
@@ -199,6 +204,15 @@
} *GC_thread;
/* ------------------------------------------------- */
+/* GC_weak */
+/* ------------------------------------------------- */
+
+typedef struct GC_weak {
+ struct GC_weak *link;
+ pointer object;
+} *GC_weak;
+
+/* ------------------------------------------------- */
/* Profiling */
/* ------------------------------------------------- */
@@ -296,6 +310,7 @@
pointer stackLimit; /* stackBottom + stackSize - maxFrameSize */
bool amInGC;
+ bool amInMinorGC;
pointer back; /* Points at next available word in toSpace. */
ullong bytesAllocated;
ullong bytesCopied;
@@ -455,6 +470,7 @@
uint translateDiff; /* used by translateHeap */
bool translateUp; /* used by translateHeap */
bool useFixedHeap; /* if true, then don't resize the heap */
+ GC_weak weaks;
} *GC_state;
static inline uint wordAlign(uint p) {
@@ -634,5 +650,9 @@
void GC_startHandler (GC_state s);
void GC_switchToThread (GC_state s, GC_thread t);
+
+bool GC_weakCanGet (pointer p);
+pointer GC_weakGet (pointer p);
+pointer GC_weakNew (GC_state s, W32 header, pointer p);
#endif /* #ifndef _MLTON_GC_H */
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel