diff: type_name for higher order, round 2

Tyson Richard DOWD trd at cs.mu.oz.au
Wed Jul 16 18:07:38 AEST 1997


Hi,

Here's an improved diff - further testing revealed a bug in
ML_create_type_info, and fixing that meant updating code in deep_copy as
well (two functions that need to be kept in sync). This in turn meant
that code should be moved to the runtime library. Hence the following
changes...

===================================================================

Estimated hours taken: 5

Allow the names of higher order types to be generated.

LIMITATIONS:
	Document limitations introduced by this change.

compiler/polymorphism.m:
	Map higher order predicates to pred/0 and functions to func/0.

library/mercury_builtin.m:
	Move base_type_* for pred/0 out of library (into runtime).

library/std_util.m:
	Check for pred/0 and func/0 when comparing type infos.
	Create different ctor_infos for higher order preds, decode them
	correctly for args and functors when needed.
	Print functions nicely (eg func(foo) = bar).
	Fix ML_create_type_info so it works correctly with higher order
	types.

runtime/type_info.h:
	Define macros to deal with new representation of higher order
	ctor_infos.

runtime/deep_copy.c:
	Fix make_type_info so it works correctly with higher order
	types.

runtime/Mmakefile:
runtime/type_info.mod:
	Add definitions for pred/0 and func/0 in runtime, they are
	needed by deep copy.

tests/hard_coded/Mmake:
tests/hard_coded/higher_order_type_manip.exp:
tests/hard_coded/higher_order_type_manip.m:
	Test case for this change.


Index: LIMITATIONS
===================================================================
RCS file: /home/staff/zs/imp/mercury/LIMITATIONS,v
retrieving revision 1.8
diff -u -r1.8 LIMITATIONS
--- LIMITATIONS	1996/12/20 17:36:52	1.8
+++ LIMITATIONS	1997/07/16 02:45:52
@@ -19,12 +19,16 @@
 * The order of mode declarations is significant:
   unique mode declarations must precede non-unique mode declarations.
 
+We are working on eliminating all of these problems. 
+
+In addition, design decisions in this implementation have imposed the
+following fixed limits:
+
 * Predicates can have at most about 1000 arguments.
 
-We are working on eliminating all of these problems. 
+* Higher order terms are limited to arity of about 500.
 
-Of course, those are not the only things we're working on.  Among other
-things, we'd like to provide better support for debugging, and a better
-garbage collector.  We're also working on a parallel/multithreaded
-version of Mercury, and on adding support for constraint solving.
+These limits can be lifted (with some effort), but would possibly incur
+performance penalties. Contact the Mercury team (mercury at cs.mu.oz.au) if
+you find these limits are affecting your application.
 
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.106
diff -u -r1.106 polymorphism.m
--- polymorphism.m	1997/06/02 06:36:09	1.106
+++ polymorphism.m	1997/07/16 02:47:09
@@ -719,19 +719,20 @@
 polymorphism__make_var(Type, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0, 
 		Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes) :-
 	(
-		type_is_higher_order(Type, _PredOrFunc, TypeArgs)
+		type_is_higher_order(Type, PredOrFunc, TypeArgs)
 	->
 		% This occurs for code where a predicate calls a polymorphic
 		% predicate with a known higher-order value of the type
 		% variable.
-		% The transformation we perform is basically the same
-		% as in the first-order case below, except that
-		% we ignore the PredOrFunc and map all pred/func types to 
-		% builtin pred/0 for the purposes of creating type_infos.
+		% The transformation we perform is basically the same as
+		% in the first-order case below, except that we map
+		% pred/func types to builtin pred/0 or func/0 for the
+		% purposes of creating type_infos.  
 		% To allow univ_to_type to check the type_infos
-		% correctly, the actual arity of the pred is added to 
+		% correctly, the actual arity of the pred is added to
 		% the type_info of higher-order types.
-		TypeId = unqualified("pred") - 0,
+		hlds_out__pred_or_func_to_string(PredOrFunc, PredOrFuncStr),
+		TypeId = unqualified(PredOrFuncStr) - 0,
 		polymorphism__construct_type_info(Type, TypeId, TypeArgs,
 			yes, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
 			Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes)
Index: library/mercury_builtin.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/mercury_builtin.m,v
retrieving revision 1.75
diff -u -r1.75 mercury_builtin.m
--- mercury_builtin.m	1997/06/04 09:59:33	1.75
+++ mercury_builtin.m	1997/07/16 06:36:00
@@ -311,24 +311,9 @@
 :- pragma(c_code, builtin_strcmp(Res::out, S1::in, S2::in),
 	"Res = strcmp(S1, S2);").
 
-builtin_unify_pred(_Pred1, _Pred2) :-
-	% suppress determinism warning
-	( semidet_succeed ->
-		error("attempted unification of higher-order predicate terms")
-	;
-		semidet_fail
-	).
-
-builtin_index_pred(_, -1).
-
-builtin_compare_pred(Res, _Pred1, _Pred2) :-
-	% suppress determinism warning
-	( semidet_succeed ->
-		error("attempted comparison of higher-order predicate terms")
-	;
-		% the following is never executed
-		Res = (<)
-	).
+:- external(builtin_unify_pred/2).
+:- external(builtin_index_pred/2).
+:- external(builtin_compare_pred/3).
 
 unused :-
 	( semidet_succeed ->
@@ -383,16 +368,6 @@
 		mkbody(TYPELAYOUT_FLOAT_VALUE))
 };
 
-	/* base_type_layout for `pred' */
-	/* (this is used for all higher-order types) */
-
-const struct mercury_data___base_type_layout_pred_0_struct {
-	TYPE_LAYOUT_FIELDS
-} mercury_data___base_type_layout_pred_0 = {
-	make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG, 
-		mkbody(TYPELAYOUT_PREDICATE_VALUE))
-};
-
 	/* base_type_layout for `void' */
 
 const struct mercury_data___base_type_layout_void_0_struct {
@@ -436,15 +411,6 @@
 	MR_TYPEFUNCTORS_SPECIAL
 };
 
-	/* base_type_functors for `pred' */
-	/* (this is used for all higher-order types) */
-
-const struct mercury_data___base_type_functors_pred_0_struct {
-	Integer f1;
-} mercury_data___base_type_functors_pred_0 = {
-	MR_TYPEFUNCTORS_SPECIAL
-};
-
 	/* base_type_functors for `void' */
 
 const struct mercury_data___base_type_functors_void_0_struct {
@@ -579,38 +545,6 @@
 	(const Word *) & mercury_data___base_type_layout_float_0,
 	(const Word *) & mercury_data___base_type_functors_float_0,
 	(const Word *) string_const(""float"", 5)
-#endif
-};
-
-	/* base_type_info for `pred' */
-	/* (this is used for all higher-order types) */
-
-Declare_entry(mercury__builtin_unify_pred_2_0);
-Declare_entry(mercury__builtin_index_pred_2_0);
-Declare_entry(mercury__builtin_compare_pred_3_0);
-MR_STATIC_CODE_CONST struct mercury_data___base_type_info_pred_0_struct {
-	Integer f1;
-	Code *f2;
-	Code *f3;
-	Code *f4;
-#ifdef USE_TYPE_TO_TERM
-	Code *f5;
-	Code *f6;
-#endif
-#ifdef USE_TYPE_LAYOUT
-	const Word *f7;
-	const Word *f8;
-	const Word *f9;
-#endif
-} mercury_data___base_type_info_pred_0 = {
-	((Integer) 0),
-	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_unify_pred_2_0)),
-	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_index_pred_2_0)),
-	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_compare_pred_3_0)),
-#ifdef  USE_TYPE_LAYOUT
-	(const Word *) & mercury_data___base_type_layout_pred_0,
-	(const Word *) & mercury_data___base_type_functors_pred_0,
-	(const Word *) string_const(""pred"", 4)
 #endif
 };
 
Index: library/std_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/std_util.m,v
retrieving revision 1.93
diff -u -r1.93 std_util.m
--- std_util.m	1997/06/04 09:59:37	1.93
+++ std_util.m	1997/07/16 05:55:13
@@ -397,7 +397,7 @@
 
 :- implementation.
 
-:- import_module require, set, int, string.
+:- import_module require, set, int, string, bool.
 
 %-----------------------------------------------------------------------------%
 
@@ -757,8 +757,6 @@
 ** calls to this function.
 */
 
-MR_DECLARE_STRUCT(mercury_data___base_type_info_pred_0);
-
 int
 ML_compare_type_info(Word t1, Word t2)
 {
@@ -818,8 +816,8 @@
 	** But we need to recursively compare the argument types, if any.
 	*/
 		/* Check for higher order */
-	if (base_type_info_1 ==
-		(const Word *) &mercury_data___base_type_info_pred_0)
+	if (MR_BASE_TYPEINFO_IS_HO_PRED(base_type_info_1) ||
+	    MR_BASE_TYPEINFO_IS_HO_FUNC(base_type_info_1))
 	{
 		int num_arg_types_2;
 
@@ -1204,20 +1202,25 @@
 	( Arity = 0 ->
 		TypeName = Name
 	;
-		type_arg_names(ArgTypes, ArgTypeNames),
-		string__append_list([Name, "(" | ArgTypeNames], TypeName)
+		( Name = "func" -> IsFunc = yes ; IsFunc = no ),
+		type_arg_names(ArgTypes, IsFunc, ArgTypeNames),
+		string__append_list([Name, "(" | ArgTypeNames], 
+			TypeName)
 	).
 
-:- pred type_arg_names(list(type_info), list(string)).
-:- mode type_arg_names(in, out) is det.
+:- pred type_arg_names(list(type_info), bool, list(string)).
+:- mode type_arg_names(in, in, out) is det.
 
-type_arg_names([], []).
-type_arg_names([Type|Types], ArgNames) :-
+type_arg_names([], _, []).
+type_arg_names([Type|Types], IsFunc, ArgNames) :-
 	Name = type_name(Type),
 	( Types = [] ->
 		ArgNames = [Name, ")"]
+	; IsFunc = yes, Types = [FuncReturnType] ->
+		FuncReturnName = type_name(FuncReturnType),
+		ArgNames = [Name, ") = ", FuncReturnName]
 	;
-		type_arg_names(Types, Names),
+		type_arg_names(Types, IsFunc, Names),
 		ArgNames = [Name, ", " | Names]
 	).
 
@@ -1240,31 +1243,82 @@
 :- pragma c_code(type_ctor(TypeInfo::in) = (TypeCtor::out), 
 	will_not_call_mercury, "
 {
-	Word *type_info;
+	Word *type_info, *base_type_info;
 
 	save_transient_registers();
 	type_info = (Word *) ML_collapse_equivalences(TypeInfo);
 	restore_transient_registers();
 
-	TypeCtor = (Word) MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
+	base_type_info = (Word *) MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
+
+	TypeCtor = ML_make_ctor_info(type_info, base_type_info);
 }
 ").
 
+:- pragma c_header_code("
+
+Word ML_make_ctor_info(Word *type_info, Word *base_type_info);
+
+	/*
+	** Several predicates use these (the MR_BASE_TYPEINFO_IS_HO_*
+	** macros need access to these addresses).
+	*/
+MR_DECLARE_STRUCT(mercury_data___base_type_info_pred_0);
+MR_DECLARE_STRUCT(mercury_data___base_type_info_func_0);
+
+
+").
+
+:- pragma c_code("
+
+
+Word ML_make_ctor_info(Word *type_info, Word *base_type_info)
+{
+	Word ctor_info = (Word) base_type_info;
+
+	if (MR_BASE_TYPEINFO_IS_HO_PRED(base_type_info)) {
+		ctor_info = MR_TYPECTOR_MAKE_PRED(
+			MR_TYPEINFO_GET_HIGHER_ARITY(type_info));
+		if (!MR_TYPECTOR_IS_HIGHER_ORDER(ctor_info)) {
+			fatal_error(""std_util:ML_make_ctor_info""
+				""- arity out of range."");
+		}
+	} else if (MR_BASE_TYPEINFO_IS_HO_FUNC(base_type_info)) {
+		ctor_info = MR_TYPECTOR_MAKE_FUNC(
+			MR_TYPEINFO_GET_HIGHER_ARITY(type_info));
+		if (!MR_TYPECTOR_IS_HIGHER_ORDER(ctor_info)) {
+			fatal_error(""std_util:ML_make_ctor_info""
+				""- arity out of range."");
+		}
+	}
+	return ctor_info;
+}
+
+").
+
+
 :- pragma c_code(type_ctor_and_args(TypeInfo::in,
 		TypeCtor::out, TypeArgs::out), will_not_call_mercury, "
 {
-	Word *type_info;
-	Word *base_type_info;
+	Word *type_info, *base_type_info;
 	Integer arity;
 
 	save_transient_registers();
 	type_info = (Word *) ML_collapse_equivalences(TypeInfo);
 	base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
-	TypeCtor = (Word) base_type_info;
-	arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
-	TypeArgs = ML_copy_argument_typeinfos(arity, 0,
+	TypeCtor = ML_make_ctor_info(type_info, base_type_info);
+
+	if (MR_TYPECTOR_IS_HIGHER_ORDER(TypeCtor)) {
+		arity = MR_TYPECTOR_GET_HOT_ARITY(TypeCtor);
+		TypeArgs = ML_copy_argument_typeinfos(arity, 0,
+			type_info + TYPEINFO_OFFSET_FOR_PRED_ARGS);
+	} else {
+		arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+		TypeArgs = ML_copy_argument_typeinfos(arity, 0,
 			type_info + OFFSET_FOR_ARG_TYPE_INFOS);
+	}
 	restore_transient_registers();
+
 }
 ").
 
@@ -1286,7 +1340,11 @@
 	
 	base_type_info = (Word *) TypeCtor;
 
-	arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+	if (MR_TYPECTOR_IS_HIGHER_ORDER(base_type_info)) {
+		arity = MR_TYPECTOR_GET_HOT_ARITY(base_type_info);
+	} else {
+		arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+	}
 
 	arg_type = ArgTypes; 
 	for (list_length = 0; !list_is_empty(arg_type); list_length++) {
@@ -1315,21 +1373,38 @@
 {
 	Word *type_info = (Word *) TypeInfo;
 	Word *base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(type_info);
-	Integer arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
-	TypeCtor = (Word) base_type_info;
-	save_transient_registers();
-	ArgTypes = ML_copy_argument_typeinfos(arity, 0,
+	Integer arity;
+
+	TypeCtor = ML_make_ctor_info(type_info, base_type_info);
+	if (MR_TYPECTOR_IS_HIGHER_ORDER(TypeCtor)) {
+		arity = MR_TYPECTOR_GET_HOT_ARITY(base_type_info);
+		save_transient_registers();
+		ArgTypes = ML_copy_argument_typeinfos(arity, 0,
+			type_info + TYPEINFO_OFFSET_FOR_PRED_ARGS);
+		restore_transient_registers();
+	} else {
+		arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+		save_transient_registers();
+		ArgTypes = ML_copy_argument_typeinfos(arity, 0,
 			type_info + OFFSET_FOR_ARG_TYPE_INFOS);
-	restore_transient_registers();
+		restore_transient_registers();
+	}
 }
 ").
 
 :- pragma c_code(type_ctor_name_and_arity(TypeCtor::in,
 	TypeCtorName::out, TypeCtorArity::out), will_not_call_mercury, "
 {
-	Word *base_type_info = (Word *) TypeCtor;
-	TypeCtorName = MR_BASE_TYPEINFO_GET_TYPE_NAME(base_type_info);
-	TypeCtorArity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+	Word *type_ctor = (Word *) TypeCtor;
+
+	if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) {
+		TypeCtorName = (String) (Word) 
+			MR_TYPECTOR_GET_HOT_NAME(type_ctor);
+		TypeCtorArity = MR_TYPECTOR_GET_HOT_ARITY(type_ctor);
+	} else {
+		TypeCtorName = MR_BASE_TYPEINFO_GET_TYPE_NAME(type_ctor);
+		TypeCtorArity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(type_ctor);
+	}
 }
 ").
 
@@ -1353,7 +1428,7 @@
 		** Get information for this functor number and
 		** store in info. If this is a discriminated union
 		** type and if the functor number is in range, we
-	 	** succeed.
+		** succeed.
 		*/
 	save_transient_registers();
 	success = ML_get_functors_check_range(FunctorNumber,
@@ -1656,7 +1731,7 @@
 	** ML_make_type(arity, base_type_info, arg_types_list):
 	**
 	** Construct and return a type_info for a type using the
-	** specified base_type_info for the type constructor,
+	** specified type_ctor for the type constructor,
 	** and using the arguments specified in arg_types_list
 	** for the type arguments (if any).
 	**
@@ -1669,28 +1744,39 @@
 	*/
 
 Word
-ML_make_type(int arity, Word *base_type_info, Word arg_types_list) 
+ML_make_type(int arity, Word *type_ctor, Word arg_types_list) 
 {
-	int i;
+	int i, extra_args;
+	Word base_type_info;
 
 	/*
 	** XXX: do we need to treat higher-order predicates as
 	**      a special case here?
 	*/
 
+	if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) {
+		base_type_info = MR_TYPECTOR_GET_HOT_BASE_TYPE_INFO(type_ctor);
+		extra_args = 2;
+	} else {
+		base_type_info = (Word) type_ctor;
+		extra_args = 1;
+	}
 
 	if (arity == 0) {
-		return (Word) base_type_info;
+		return base_type_info;
 	} else {
 		Word *type_info;
 
 		restore_transient_registers();
-		incr_hp(LVALUE_CAST(Word, type_info), arity + 1);
+		incr_hp(LVALUE_CAST(Word, type_info), arity + extra_args);
 		save_transient_registers();
 		
-		field(mktag(0), type_info, 0) = (Word) base_type_info;
+		field(mktag(0), type_info, 0) = base_type_info;
+		if (MR_TYPECTOR_IS_HIGHER_ORDER(type_ctor)) {
+			field(mktag(0), type_info, 1) = (Word) arity;
+		}
 		for (i = 0; i < arity; i++) {
-			field(mktag(0), type_info, i + 1) = 
+			field(mktag(0), type_info, i + extra_args) = 
 				list_head(arg_types_list);
 			arg_types_list = list_tail(arg_types_list);
 		}
@@ -2311,7 +2397,7 @@
 	** type_info.
 	**
 	** NOTE: If you are changing this code, you might also need
-	** to change the code in ML_create_type_info in runtime/deep_copy.c,
+	** to change the code in make_type_info in runtime/deep_copy.c,
 	** which does much the same thing, only allocating using malloc
 	** instead of on the heap.
 	*/
@@ -2319,8 +2405,8 @@
 Word * 
 ML_create_type_info(Word *term_type_info, Word *arg_pseudo_type_info)
 {
-	int i, arity;
-	Word base_type_info;
+	int i, arity, extra_args;
+	Word *base_type_info;
 	Word *type_info;
 
 		/* 
@@ -2337,30 +2423,69 @@
 		fatal_error(""ML_create_type_info: unbound type variable"");
 	}
 
-	base_type_info = arg_pseudo_type_info[0];
+	base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(arg_pseudo_type_info);
 
 		/* no arguments - optimise common case */
-	if (base_type_info == 0) {
+	if (base_type_info == arg_pseudo_type_info) {
 		return arg_pseudo_type_info;
 	}
 
-	arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+	if (MR_BASE_TYPEINFO_IS_HO_PRED(base_type_info) ||
+			MR_BASE_TYPEINFO_IS_HO_FUNC(base_type_info)) {
+		arity = MR_TYPEINFO_GET_HIGHER_ARITY(arg_pseudo_type_info);
+		extra_args = 2;
+	} else {
+		arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+		extra_args = 1;
+	}
 
-	incr_saved_hp(LVALUE_CAST(Word, type_info), arity + 1);
 
-	for (i = 0; i <= arity; i++) {
+		/* 
+		** 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])) {
-			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"");
-			}
+			break;
+		}
+	}
 
-		} else {
+		/*
+		** 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];
 		}
+
+			/*
+			** 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 (TYPEINFO_IS_VARIABLE(type_info[i])) {
+					fatal_error(""ML_create_type_info: ""
+						""unbound type variable"");
+				}
+
+			} else {
+				type_info[i] = arg_pseudo_type_info[i];
+			}
+		}
+		return type_info;
+	} else {
+		return arg_pseudo_type_info;
 	}
-	return type_info;
 }
 
 ").
Index: runtime/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/Mmakefile,v
retrieving revision 1.6
diff -u -r1.6 Mmakefile
--- Mmakefile	1997/06/16 13:35:29	1.6
+++ Mmakefile	1997/07/16 06:20:35
@@ -35,8 +35,8 @@
 		  machdeps/mips_regs.h machdeps/sparc_regs.h \
 		  machdeps/alpha_regs.h machdeps/pa_regs.h \
 		  machdeps/rs6000_regs.h
-MODS		= engine.mod wrapper.mod call.mod context.mod
-MOD_CS		= engine.c wrapper.c call.c context.c
+MODS		= engine.mod wrapper.mod call.mod context.mod type_info.mod
+MOD_CS		= engine.c wrapper.c call.c context.c type_info.c
 MOD_OS		= $(MOD_CS:.c=.o)
 ORIG_CS		= deep_copy.c dlist.c dummy.c label.c \
 		  memory.c misc.c regs.c table.c timing.c prof.c prof_mem.c \
Index: runtime/deep_copy.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/deep_copy.c,v
retrieving revision 1.11
diff -u -r1.11 deep_copy.c
--- deep_copy.c	1997/04/28 12:11:15	1.11
+++ deep_copy.c	1997/07/16 06:24:44
@@ -23,6 +23,9 @@
 static Word * deep_copy_type_info(Word *type_info,
 	Word *lower_limit, Word *upper_limit);
 
+MR_DECLARE_STRUCT(mercury_data___base_type_info_pred_0);
+MR_DECLARE_STRUCT(mercury_data___base_type_info_func_0);
+
 /*
 ** Due to the depth of the control here, we'll use 4 space indentation.
 */
@@ -383,46 +386,74 @@
 make_type_info(Word *term_type_info, Word *arg_pseudo_type_info,
 	bool *allocated) 
 {
-	int arity, i;
-	Word base_type_info;
+	int arity, i, extra_args;
+	Word *base_type_info;
 	Word *type_info;
 
 	*allocated = FALSE;
 
-		/* The arg_pseudo_type_info might be a polymorphic variable */
+		/* 
+		** The arg_pseudo_type_info might be a polymorphic variable,
+		** is so - substitute.
+		*/
 
-	if ((Word) arg_pseudo_type_info < TYPELAYOUT_MAX_VARINT) {
+	if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
 		return (Word *) term_type_info[(Word) arg_pseudo_type_info];
 	}
 
-
-	base_type_info = arg_pseudo_type_info[0];
+	base_type_info = MR_TYPEINFO_GET_BASE_TYPEINFO(arg_pseudo_type_info);
 
 		/* no arguments - optimise common case */
-	if (base_type_info == 0) {
+	if (base_type_info == arg_pseudo_type_info) {
 		return arg_pseudo_type_info;
-	} else {
-		arity = ((Word *) base_type_info)[0];
-	}
+	} 
+
+        if (MR_BASE_TYPEINFO_IS_HO_PRED(base_type_info) ||
+                        MR_BASE_TYPEINFO_IS_HO_FUNC(base_type_info)) {
+                arity = MR_TYPEINFO_GET_HIGHER_ARITY(arg_pseudo_type_info);
+                extra_args = 2;
+        } else {
+                arity = MR_BASE_TYPEINFO_GET_TYPE_ARITY(base_type_info);
+                extra_args = 1;
+        }
 
-	for (i = arity; i > 0; i--) {
-		if (arg_pseudo_type_info[i] < TYPELAYOUT_MAX_VARINT) {
+		/*
+                ** 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;
 		}
 	}
 
-		/* 
-		** See if any of the arguments were polymorphic.
-		** If so, substitute.
-		*/
-	if (i > 0) {
-		type_info = checked_malloc(arity * sizeof(Word));
+		/*
+		** Do we need to create a new type_info?
+		*/ 
+	if (i >= extra_args) {
+		type_info = checked_malloc((arity + extra_args) * sizeof(Word));
 		*allocated = TRUE;
-		for (i = 0; i <= arity; i++) {
-			if (arg_pseudo_type_info[i] < TYPELAYOUT_MAX_VARINT) {
-				type_info[i] = term_type_info[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("Error! Can't instantiate type variable.");
+					fatal_error("make_type_info: "
+						"unbound type variable.");
 				}
 			} else {
 				type_info[i] = arg_pseudo_type_info[i];
Index: runtime/type_info.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/type_info.h,v
retrieving revision 1.26
diff -u -r1.26 type_info.h
--- type_info.h	1997/05/20 02:05:11	1.26
+++ type_info.h	1997/07/16 02:49:06
@@ -268,6 +268,38 @@
 #define TYPEINFO_IS_VARIABLE(T)		( (Word) T <= TYPELAYOUT_MAX_VARINT )
 
 /*
+** This constant is also used for other information - for
+** ctor infos a small integer is used for higher order types.
+** Even integers represent preds, odd represent functions.
+** The arity of the pred or function can be found by dividing by
+** two (integer division).
+*/
+
+#define MR_BASE_TYPEINFO_HO_PRED				\
+	((const Word *) &mercury_data___base_type_info_pred_0)
+#define MR_BASE_TYPEINFO_HO_FUNC				\
+	((const Word *) &mercury_data___base_type_info_func_0)
+#define MR_BASE_TYPEINFO_IS_HO_PRED(T)				\
+	(T == MR_BASE_TYPEINFO_HO_PRED)
+#define MR_BASE_TYPEINFO_IS_HO_FUNC(T)				\
+	(T == MR_BASE_TYPEINFO_HO_FUNC)
+
+#define MR_TYPECTOR_IS_HIGHER_ORDER(T)				\
+	( (Word) T <= TYPELAYOUT_MAX_VARINT )
+#define MR_TYPECTOR_MAKE_PRED(Arity)				\
+	( (Word) ((Integer) (Arity) * 2) )
+#define MR_TYPECTOR_MAKE_FUNC(Arity)				\
+	( (Word) ((Integer) (Arity) * 2 + 1) )
+#define MR_TYPECTOR_GET_HOT_ARITY(T)				\
+	((Integer) (T) / 2 )
+#define MR_TYPECTOR_GET_HOT_NAME(T)				\
+	((ConstString) ( ( ((Integer) (T)) % 2 ) ? "func" : "pred" ))
+#define MR_TYPECTOR_GET_HOT_BASE_TYPE_INFO(T)			\
+	((Word) ( ( ((Integer) (T)) % 2 ) ?		\
+		(const Word *) &mercury_data___base_type_info_func_0 :	\
+		(const Word *) &mercury_data___base_type_info_pred_0 ))
+
+/*
 ** Offsets into the type_layout structure for functors and arities.
 **
 ** Constant and enumeration values start at 0, so the functor
@@ -654,6 +686,9 @@
 
 #define MR_TYPEINFO_GET_BASE_TYPEINFO(TypeInfo)				\
 		((*TypeInfo) ? ((Word *) *TypeInfo) : TypeInfo)
+
+#define MR_TYPEINFO_GET_HIGHER_ARITY(TypeInfo)				\
+		((Integer) (Word *) (TypeInfo)[TYPEINFO_OFFSET_FOR_PRED_ARITY]) 
 
 #define MR_BASE_TYPEINFO_GET_TYPEFUNCTORS(BaseTypeInfo)			\
 		((Word *) (BaseTypeInfo)[OFFSET_FOR_BASE_TYPE_FUNCTORS])
Index: tests/hard_coded/Mmake
===================================================================
RCS file: /home/staff/zs/imp/tests/hard_coded/Mmake,v
retrieving revision 1.50
diff -u -r1.50 Mmake
--- Mmake	1997/07/09 08:21:08	1.50
+++ Mmake	1997/07/15 06:29:48
@@ -31,6 +31,7 @@
 	getopt_test \
 	higher_order_func_test \
 	higher_order_syntax \
+	higher_order_type_manip \
 	ho_func_reg \
 	ho_solns \
 	ho_univ_to_type \

New File: runtime/type_info.mod
===================================================================
/*
** Copyright (C) 1995-1997 University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/

/*
** type_info.c -
**	Definitions for type_infos, type_layouts, and
**	type_functors tables needed by the Mercury runtime system..
*/

#include "imp.h"
#include "type_info.h"

/*---------------------------------------------------------------------------*/

	/* base_type_layout for `pred' */
	/* (this is used for all higher-order types) */

const struct mercury_data___base_type_layout_pred_0_struct {
	TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_pred_0 = {
	make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG, 
		mkbody(TYPELAYOUT_PREDICATE_VALUE))
};

	/* base_type_functors for `pred' */
	/* (this is used for all higher-order types) */

const struct mercury_data___base_type_functors_pred_0_struct {
	Integer f1;
} mercury_data___base_type_functors_pred_0 = {
	MR_TYPEFUNCTORS_SPECIAL
};


	/* 
	** base_type_info for `func' 
	** (this is used for all higher-order func types) 
	**
	** Note: we use the special predicates, functors and layout for
	** `pred'.
	*/

Declare_entry(mercury__builtin_unify_pred_2_0);
Declare_entry(mercury__builtin_index_pred_2_0);
Declare_entry(mercury__builtin_compare_pred_3_0);
MR_STATIC_CODE_CONST struct mercury_data___base_type_info_func_0_struct {
	Integer f1;
	Code *f2;
	Code *f3;
	Code *f4;
#ifdef USE_TYPE_TO_TERM
	Code *f5;
	Code *f6;
#endif
#ifdef USE_TYPE_LAYOUT
	const Word *f7;
	const Word *f8;
	const Word *f9;
#endif
} mercury_data___base_type_info_func_0 = {
	((Integer) 0),
	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_unify_pred_2_0)),
	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_index_pred_2_0)),
	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_compare_pred_3_0)),
#ifdef  USE_TYPE_LAYOUT
	(const Word *) & mercury_data___base_type_layout_pred_0,
	(const Word *) & mercury_data___base_type_functors_pred_0,
	(const Word *) string_const("func", 4)
#endif
};

	/*
	** base_type_info for `pred' 
	** (this is used for all higher-order pred types) 
	*/

Declare_entry(mercury__builtin_unify_pred_2_0);
Declare_entry(mercury__builtin_index_pred_2_0);
Declare_entry(mercury__builtin_compare_pred_3_0);
MR_STATIC_CODE_CONST struct mercury_data___base_type_info_pred_0_struct {
	Integer f1;
	Code *f2;
	Code *f3;
	Code *f4;
#ifdef USE_TYPE_TO_TERM
	Code *f5;
	Code *f6;
#endif
#ifdef USE_TYPE_LAYOUT
	const Word *f7;
	const Word *f8;
	const Word *f9;
#endif
} mercury_data___base_type_info_pred_0 = {
	((Integer) 0),
	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_unify_pred_2_0)),
	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_index_pred_2_0)),
	MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_compare_pred_3_0)),
#ifdef  USE_TYPE_LAYOUT
	(const Word *) & mercury_data___base_type_layout_pred_0,
	(const Word *) & mercury_data___base_type_functors_pred_0,
	(const Word *) string_const("pred", 4)
#endif
};

Define_extern_entry(mercury__builtin_unify_pred_2_0);
Define_extern_entry(mercury__builtin_index_pred_2_0);
Define_extern_entry(mercury__builtin_compare_pred_3_0);
Declare_label(mercury__builtin_compare_pred_3_0_i4);

BEGIN_MODULE(mercury__builtin_unify_pred_module)

BEGIN_CODE

/* code for predicate 'builtin_unify_pred'/2 in mode 0 */
mercury__builtin_unify_pred_2_0:
        incr_sp_push_msg(2, "mercury_builtin:builtin_unify_pred");
	fatal_error("attempted unification of higher-order terms");
END_MODULE


BEGIN_MODULE(mercury__builtin_index_pred_module)

BEGIN_CODE

/* code for predicate 'builtin_index_pred'/2 in mode 0 */
mercury__builtin_index_pred_2_0:
        r1 = (Integer) -1;
        proceed();
END_MODULE

BEGIN_MODULE(mercury__builtin_compare_pred_module)

BEGIN_CODE

/* code for predicate 'builtin_compare_pred'/3 in mode 0 */
mercury__builtin_compare_pred_3_0:
        incr_sp_push_msg(2, "mercury_builtin:builtin_compare_pred");
	fatal_error("attempted comparison of higher-order terms");
END_MODULE

/*---------------------------------------------------------------------------*/

New File: tests/hard_coded/higher_order_type_manip.exp
===================================================================
func(type_info) = string
pred(type_info, c_pointer, list(type_info))
int
container(list(int))
container(pred(state, state))
func(int) = int

New File: tests/hard_coded/higher_order_type_manip.m
===================================================================
%
% File: ho_type_manip.m
%
% Test case for higher order type manipulation.
% 
% Author: trd

:- module higher_order_type_manip.
:- interface.
:- import_module io.

:- pred main(io__state::di, io__state::uo) is det.

:- implementation.

:- import_module std_util, list.

:- func tryme = int.

:- type container(T) --->		container(T).

main -->
	io__write_string(type_name(type_of(type_name))),
	io__write_string("\n"),
	io__write_string(type_name(type_of(type_ctor_and_args))),
	io__write_string("\n"),
	io__write_string(type_name(type_of(tryme))),
	io__write_string("\n"),
	io__write_string(type_name(type_of(container([1,2,3])))),
	io__write_string("\n"),
	io__write_string(type_name(type_of(container(main)))),
	io__write_string("\n"),
	{ Ctor = type_ctor(type_of(type_name)) },
	{ IntType = type_of(8) },
	{ NewType = det_make_type(Ctor, [IntType, IntType]) },
	io__write_string(type_name(NewType)),
	io__write_string("\n").

tryme = 4.

-- 
       Tyson Dowd           # 4.4: People keep saying the behavior is undefined,
                            # but I just tried it on an ANSI-conforming compiler
     trd at cs.mu.oz.au        # and got the results I expected.
http://www.cs.mu.oz.au/~trd # A: They were wrong. Flame them mercilessly. C-IAQ



More information about the developers mailing list