[m-dev.] Re: ML_expand: attempt to use UNUSED tag!

Fergus Henderson fjh at cs.mu.oz.au
Tue Dec 30 17:41:20 AEDT 1997


On 30-Dec-1997, Tyson Dowd <trd at cs.mu.oz.au> wrote:
> 
> I'm wondering if it's possible to not allocate new type_infos
> in general, and just keep around the actual parameters.

You can do something that is somewhat like this; it is usually called a
"structure-sharing" implementation.  The alternative, which we're
currently using, is a "structure-copying" implementation.

Mark Jones's paper about the implementation of Gofer says
that Gofer uses a structure-sharing implementation,
with hand-coded memory management, and that this is very
important for making the type checker efficient.

A structure-sharing implementation would still need to do memory
allocation, though; the advantage is just that it only needs to
allocate fixed-size units.

Anyway, for the moment I have stuck with using structure-copying
to implement substitution of type variables in make_type_info();
to solve the memory leak, I keep track of the allocated memory
in a linked list.  See the diff below.

--------------------

library/std_util.m:
	Fix a bug in ML_create_type_info():
	when searching for type parameters to substituting with their
	corresponding values, they were only looking at the top level
	of the type.  To get correct results, it is necessary to
	traverse recursively through all levels of the type.

runtime/mercury_deep_copy.c:
	Fix a bug similar to the one above in make_type_info().
	The fix is a bit more complicated, due to memory management
	issues --- we need to keep a linked list of all the memory
	cells we allocate so that we can free them when we're done.

	Also avoid some duplicated code in mercury_deep_copy.c
	by introducing a new function deep_copy_arg().

	And fix a bug in deep_copy_type_info(): it should be
	allocating memory using incr_saved_hp(), not using
	make(). make() calls newmem(), which in non-conservative GC
	grades calls malloc(), which results in a memory leak;
	whereas incr_saved_hp() allocates on the Mercury heap,
	which is (in accurate gc grades) subject to garbage collection.

tests/hard_coded/Mmakefile:
tests/hard_coded/eqv_type_bug.m:
tests/hard_coded/eqv_type_bug.exp:
	Regression test for the above-mentioned bug in ML_create_type_info().


cvs diff  library/std_util.m runtime/mercury_deep_copy.c tests/hard_coded/Mmakefile tests/hard_coded/eqv_type_bug.exp tests/hard_coded/eqv_type_bug.m
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.111
diff -u -r1.111 std_util.m
--- std_util.m	1997/12/03 07:05:11	1.111
+++ std_util.m	1997/12/30 06:05:50
@@ -2655,25 +2655,28 @@
 {
 	int i, arity, extra_args;
 	Word *base_type_info;
+	Word *arg_type_info;
 	Word *type_info;
 
-		/* 
-		** The arg_pseudo_type_info might be a polymorphic variable,
-		** if so - substitute.
-		*/
-
+	/* 
+	** The arg_pseudo_type_info might be a polymorphic variable.
+	** If so, then substitute it's value, and then we're done.
+	*/
 	if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
-		arg_pseudo_type_info = (Word *) 
+		arg_type_info = (Word *) 
 			term_type_info[(Word) arg_pseudo_type_info];
-	}
 
-	if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
-		fatal_error(""ML_create_type_info: unbound type variable"");
+		if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
+			fatal_error(""ML_create_type_info: ""
+					""unbound type variable"");
+		}
+
+		return arg_type_info;
 	}
 
 	base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(arg_pseudo_type_info);
 
-		/* no arguments - optimise common case */
+	/* no arguments - optimise common case */
 	if (base_type_info == arg_pseudo_type_info) {
 		return arg_pseudo_type_info;
 	}
@@ -2686,52 +2689,39 @@
 		extra_args = 1;
 	}
 
-
-		/* 
-		** Check for type variables -- if there are none,
-		** we don't need to create a new type_info.
-		*/
-	for (i = arity + extra_args - 1; i >= extra_args; i--) {
-		if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info[i])) {
-			break;
-		}
-	}
-
-		/*
-		** Do we need to create a new type_info?
-		*/
-	if (i >= extra_args) {
-		incr_saved_hp(LVALUE_CAST(Word, type_info), arity + extra_args);
-
-			/* 
-			** Copy any preliminary arguments to the type_info 
-			** (this means the base_type_info and possibly
-			** arity for higher order terms).
-			*/ 
-		for (i = 0; i < extra_args; i++) {
-			type_info[i] = arg_pseudo_type_info[i];
+	/*
+	** Iterate over the arguments, figuring out whether we
+	** need to make any substitutions.
+	** If so, copy the resulting argument type-infos into
+	** a new type_info.
+	*/
+	type_info = NULL;
+	for (i = extra_args; i < arity + extra_args; i++) {
+		arg_type_info = ML_create_type_info(term_type_info,
+				(Word *) arg_pseudo_type_info[i]);
+		if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
+			fatal_error(""ML_create_type_info: ""
+				""unbound type variable"");
 		}
-
+		if (arg_type_info != (Word *) arg_pseudo_type_info[i]) {
 			/*
-			** Copy type arguments, substituting for any 
-			** type variables.
+			** We made a substitution.
+			** We need to allocate a new type_info,
+			** if we haven't done so already.
 			*/
-		for (i = extra_args; i < arity + extra_args; i++) {
-			if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info[i])) {
-				type_info[i] = term_type_info[
-					arg_pseudo_type_info[i]];
-				if (TYPEINFO_IS_VARIABLE(type_info[i])) {
-					fatal_error(""ML_create_type_info: ""
-						""unbound type variable"");
-				}
-
-			} else {
-				type_info[i] = arg_pseudo_type_info[i];
+			if (type_info == NULL) {
+				incr_saved_hp(LVALUE_CAST(Word, type_info),
+					arity + extra_args);
+				memcpy(type_info, arg_pseudo_type_info,
+					(arity + extra_args) * sizeof(Word));
 			}
+			type_info[i] = (Word) arg_type_info;
 		}
-		return type_info;
-	} else {
+	}
+	if (type_info == NULL) {
 		return arg_pseudo_type_info;
+	} else {
+		return type_info;
 	}
 }
 
Index: runtime/mercury_deep_copy.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_copy.c,v
retrieving revision 1.2
diff -u -r1.2 mercury_deep_copy.c
--- mercury_deep_copy.c	1997/11/23 07:21:17	1.2
+++ mercury_deep_copy.c	1997/12/30 06:15:43
@@ -14,12 +14,22 @@
 
 #define in_range(X)	((X) >= lower_limit && (X) <= upper_limit)
 
+/* for make_type_info(), we keep a list of allocated memory cells */
+struct MemoryCellNode {
+	void *data;
+	struct MemoryCellNode *next;
+};
+typedef struct MemoryCellNode *MemoryList;
+
 /*
 ** Prototypes.
 */
 static Word get_base_type_layout_entry(Word data, Word *type_info);
+static Word deep_copy_arg(Word data, Word *type_info, Word *arg_type_info,
+	Word *lower_limit, Word *upper_limit);
 static Word * make_type_info(Word *term_type_info, Word *arg_pseudo_type_info,
-	bool *allocated);
+	MemoryList *allocated);
+static void deallocate(MemoryList allocated_memory_cells);
 static Word * deep_copy_type_info(Word *type_info,
 	Word *lower_limit, Word *upper_limit);
 
@@ -36,10 +46,10 @@
     int data_tag, entry_tag; 
 
     int arity, i;
-    bool allocated;
-    Word *argument_vector, *type_info_vector, *new_type_info;
+    Word *argument_vector, *type_info_vector;
 
     Word new_data;
+
 	
     data_tag = tag(data);
     data_value = (Word *) body(data, data_tag);
@@ -51,7 +61,7 @@
 
     switch(entry_tag) {
 
-        case TYPELAYOUT_CONST_TAG:      /* and COMP_CONST_TAG */
+        case TYPELAYOUT_CONST_TAG: /* and TYPELAYOUT_COMP_CONST_TAG */
 
             /* Some builtins need special treatment */
             if ((Word) entry_value <= TYPELAYOUT_MAX_VARINT) {
@@ -238,14 +248,10 @@
 
                     /* copy arguments */
                 for (i = 0; i < arity; i++) {
-                    new_type_info = make_type_info(type_info,
-                        (Word *) type_info_vector[i], &allocated);
-                    field(0, new_data, i) = 
-                        deep_copy(argument_vector[i],
-                            new_type_info, lower_limit, upper_limit); 
-                    if (allocated) { 
-                        free(new_type_info);
-                    }
+		    field(0, new_data, i) =
+			deep_copy_arg(argument_vector[i],
+				type_info, (Word *) type_info_vector[i],
+				lower_limit, upper_limit);
                 }
                     /* tag this pointer */
                 new_data = (Word) mkword(data_tag, new_data);
@@ -283,15 +289,10 @@
 
                     /* copy arguments */
                 for (i = 0; i < arity; i++) {
-                    new_type_info = make_type_info(type_info,
-                        (Word *) type_info_vector[i], &allocated);
                     field(0, new_data, i + 1) = 
-                        deep_copy(argument_vector[i], 
-                            new_type_info, lower_limit, 
-                            upper_limit);
-                    if (allocated) {
-                        free(new_type_info);
-                    }
+			deep_copy_arg(argument_vector[i],
+				type_info, (Word *) type_info_vector[i],
+				lower_limit, upper_limit);
                 }
 
                 /* tag this pointer */
@@ -302,7 +303,7 @@
             break;
         }
 
-        case TYPELAYOUT_EQUIV_TAG:
+        case TYPELAYOUT_EQUIV_TAG: /* and TYPELAYOUT_NO_TAG */
             /* note: we treat no_tag types just like equivalences */
 
             if ((Word) entry_value < TYPELAYOUT_MAX_VARINT) {
@@ -316,13 +317,9 @@
 		** (as per comments in base_type_layout.m)
 		** XXX should avoid use of hard-coded offset `1' here
 		*/
-                new_type_info = make_type_info(type_info, 
-                    (Word *) entry_value[1], &allocated);
-                new_data = deep_copy(data, new_type_info, 
-                    lower_limit, upper_limit);
-                if (allocated) {
-                    free(new_type_info);
-                }
+		new_data = deep_copy_arg(data,
+				type_info, (Word *) entry_value[1],
+				lower_limit, upper_limit);
             }
             break;
 
@@ -334,22 +331,52 @@
     return new_data;
 } /* end deep_copy() */
 
+
 Word 
 get_base_type_layout_entry(Word data_tag, Word *type_info)
 {
 	Word *base_type_info, *base_type_layout;
+	base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
+	base_type_layout = MR_BASE_TYPEINFO_GET_TYPELAYOUT(base_type_info);
+	return base_type_layout[data_tag];
+}
 
-	base_type_info = (Word *) type_info[0];
-
-	if (base_type_info == 0) {
-		base_type_info = type_info;
-	}
-
-	base_type_layout = (Word *) base_type_info[OFFSET_FOR_BASE_TYPE_LAYOUT];
+/*
+** deep_copy_arg is like deep_copy() except that it takes a
+** pseudo_type_info (namely arg_pseudo_type_info) rather than
+** a type_info.  The pseudo_type_info may contain type variables,
+** which refer to arguments of the term_type_info.
+*/
+static Word
+deep_copy_arg(Word data, Word *term_type_info, Word *arg_pseudo_type_info,
+		Word *lower_limit, Word *upper_limit)
+{
+	MemoryList allocated_memory_cells;
+	Word *new_type_info;
+	Word new_data;
+
+	allocated_memory_cells = NULL;
+	new_type_info = make_type_info(term_type_info, arg_pseudo_type_info,
+					&allocated_memory_cells);
+	new_data = deep_copy(data, new_type_info, lower_limit, upper_limit);
+	deallocate(allocated_memory_cells);
 
-	return base_type_layout[data_tag];
+	return new_data;
 }
 
+/*
+** deallocate() frees up a list of memory cells
+*/
+static void
+deallocate(MemoryList allocated)
+{
+	while (allocated != NULL) {
+	    MemoryList next = allocated->next;
+	    free(allocated->data);
+	    free(allocated);
+	    allocated = next;
+	}
+}
 
 	/* 
 	** Given a type_info (term_type_info) which contains a
@@ -366,15 +393,14 @@
 	** arg_pseudo_type_info with all the type variables filled in.
 	** If there are no type variables to fill in, we return the
 	** arg_pseudo_type_info, unchanged. Otherwise, we allocate
-	** memory using malloc().  If memory is allocated, the boolean
-	** argument (passed by reference) is set to TRUE, otherwise it is
-	** set to FALSE.  It is the caller's responsibility to check whether 
-	** the call to make_type_info allocated memory, and if so, free
-	** it.
+	** memory using malloc().  Any such memory allocated will be
+	** inserted into the list of allocated memory cells.
+	** It is the caller's responsibility to free these cells
+	** by calling deallocate() on the list when they are no longer
+	** needed.
 	**
 	** This code could be tighter. In general, we want to
 	** handle our own allocations rather than using malloc().
-	** Also, we might be able to do only one traversal.
 	**
 	** NOTE: If you are changing this code, you might also need
 	** to change the code in create_type_info in library/std_util.m,
@@ -384,26 +410,30 @@
 
 Word *
 make_type_info(Word *term_type_info, Word *arg_pseudo_type_info,
-	bool *allocated) 
+	MemoryList *allocated) 
 {
-	int arity, i, extra_args;
+	int i, arity, extra_args;
 	Word *base_type_info;
+	Word *arg_type_info;
 	Word *type_info;
 
-	*allocated = FALSE;
-
-		/* 
-		** The arg_pseudo_type_info might be a polymorphic variable,
-		** is so - substitute.
-		*/
-
+	/* 
+	** The arg_pseudo_type_info might be a polymorphic variable.
+	** If so, then substitute its value, and then we're done.
+	*/
 	if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
-		return (Word *) term_type_info[(Word) arg_pseudo_type_info];
+		arg_type_info = (Word *) 
+			term_type_info[(Word) arg_pseudo_type_info];
+		if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
+			fatal_error("make_type_info: "
+				"unbound type variable");
+		}
+		return arg_type_info;
 	}
 
 	base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(arg_pseudo_type_info);
 
-		/* no arguments - optimise common case */
+	/* no arguments - optimise common case */
 	if (base_type_info == arg_pseudo_type_info) {
 		return arg_pseudo_type_info;
 	} 
@@ -416,52 +446,55 @@
                 extra_args = 1;
         }
 
-		/*
-                ** Check for type variables -- if there are none,
-                ** we don't need to create a new type_info.
-                */
-	for (i = arity + extra_args - 1; i >= extra_args; i--) {
-		if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info[i])) {
-			break;
+	/*
+	** Iterate over the arguments, figuring out whether we
+	** need to make any substitutions.
+	** If so, copy the resulting argument type-infos into
+	** a new type_info.
+	*/
+	type_info = NULL;
+	for (i = extra_args; i < arity + extra_args; i++) {
+		arg_type_info = make_type_info(term_type_info,
+			(Word *) arg_pseudo_type_info[i], allocated);
+		if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
+			fatal_error("make_type_info: "
+				"unbound type variable");
 		}
-	}
-
-		/*
-		** Do we need to create a new type_info?
-		*/ 
-	if (i >= extra_args) {
-		type_info = checked_malloc((arity + extra_args) * sizeof(Word));
-		*allocated = TRUE;
-
+		if (arg_type_info != (Word *) arg_pseudo_type_info[i]) {
 			/*
-			** Copy any preliminary arguments to the type_info 
-			** (this means the base_type_info and possibly 
-			** arity for higher order terms).
-			*/ 
-                for (i = 0; i < extra_args; i++) {
-                        type_info[i] = arg_pseudo_type_info[i];
-                }
-
-			/*
-			**  Copy type arguments, substituting for any
-			**  type variables.
-			*/ 
-		for (i = extra_args; i < arity + extra_args; i++) {
-			if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info[i])) {
-				type_info[i] = term_type_info[
-					arg_pseudo_type_info[i]];
-				if (type_info[i] < TYPELAYOUT_MAX_VARINT) {
-					fatal_error("make_type_info: "
-						"unbound type variable.");
-				}
-			} else {
-				type_info[i] = arg_pseudo_type_info[i];
+			** We made a substitution.
+			** We need to allocate a new type_info,
+			** if we haven't done so already.
+			*/
+			if (type_info == NULL) {
+				MemoryList node;
+				/*
+				** allocate a new type_info and copy the
+				** data across from arg_pseduo_type_info
+				*/
+				type_info = checked_malloc(
+					(arity + extra_args) * sizeof(Word));
+				memcpy(type_info, arg_pseudo_type_info,
+					(arity + extra_args) * sizeof(Word));
+				/*
+				** insert this type_info cell into the linked
+				** list of allocated memory cells, so we can
+				** free it later on
+				*/
+				node = checked_malloc(sizeof(*node));
+				node->data = type_info;
+				node->next = *allocated;
+				*allocated = node;
 			}
+			type_info[i] = (Word) arg_type_info;
 		}
-		return type_info;
-	} else {
+	}
+	if (type_info == NULL) {
 		return arg_pseudo_type_info;
+	} else {
+		return type_info;
 	}
+
 } /* end make_type_info() */
 
 Word *
@@ -476,7 +509,7 @@
 
 		base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
 		arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
-		new_type_info = make_many(Word, arity + 1);
+		incr_saved_hp(LVALUE_CAST(Word, new_type_info), arity + 1);
 		new_type_info[0] = type_info[0];
 		for (i = 1; i < arity + 1; i++) {
 			new_type_info[i] = (Word) deep_copy_type_info(
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.3
diff -u -r1.3 Mmakefile
--- Mmakefile	1997/12/09 04:02:34	1.3
+++ Mmakefile	1997/12/30 03:10:59
@@ -21,6 +21,7 @@
 	det_in_semidet_cntxt \
 	division_test \
 	elim_special_pred \
+	eqv_type_bug \
 	error_func \
 	erroneous_liveness \
 	expand \
Index: tests/hard_coded/eqv_type_bug.exp
===================================================================
RCS file: eqv_type_bug.exp
diff -N eqv_type_bug.exp
--- /dev/null	Tue Dec 30 17:23:01 1997
+++ eqv_type_bug.exp	Tue Dec 30 14:13:03 1997
@@ -0,0 +1,2 @@
+[] - [5, 4, 3, 2, 1]
+[5] - [4, 3, 2, 1]
Index: tests/hard_coded/eqv_type_bug.m
===================================================================
RCS file: eqv_type_bug.m
diff -N eqv_type_bug.m
--- /dev/null	Tue Dec 30 17:23:01 1997
+++ eqv_type_bug.m	Tue Dec 30 14:28:56 1997
@@ -0,0 +1,26 @@
+:- module try.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module cqueue.
+
+:- import_module int, list, string.
+
+main -->
+	{ cqueue__cqueue(CQ0) },
+	{ copy(CQ0, CQ0c) },
+	{ list__foldl((pred(I::in, Q0::in, Q::out) is det :-
+		cqueue__append(Q0, I, Q)), [1,2,3,4,5], CQ0c, CQ1) },
+	{ copy(CQ1, CQ1c) },
+	write(CQ1c), nl,
+	{ cqueue__next(CQ1c, CQ2) },
+	{ copy(CQ2, CQ2c) },
+	write(CQ2c), nl.
+
+
-- 
Fergus Henderson <fjh at cs.mu.oz.au>   |  "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh>   |  of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3         |     -- the last words of T. S. Garp.



More information about the developers mailing list