diff: type_name for higher order types.

Tyson Richard DOWD trd at cs.mu.oz.au
Wed Jul 16 00:17:35 AEST 1997


Hi,

Could someone review this change? 

(I gave up on implementing this by generating closure type_infos at
compile time - it was difficult to bootstrap, required too many changes, 
and was too time consuming).

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

Estimated hours taken: 3

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:
	Create base_type_info for func/0.

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

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

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/15 06:29:48
@@ -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 are 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/15 12:35:35
@@ -719,19 +719,25 @@
 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,
+		(
+			PredOrFunc = predicate,
+			TypeId = unqualified("pred") - 0
+		;
+			PredOrFunc = function,
+			TypeId = unqualified("func") - 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/15 12:35:35
@@ -314,7 +314,7 @@
 builtin_unify_pred(_Pred1, _Pred2) :-
 	% suppress determinism warning
 	( semidet_succeed ->
-		error("attempted unification of higher-order predicate terms")
+		error("attempted unification of higher-order terms")
 	;
 		semidet_fail
 	).
@@ -582,8 +582,47 @@
 #endif
 };
 
-	/* base_type_info for `pred' */
-	/* (this is used for all higher-order types) */
+	/* 
+	** 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);
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/15 12:35:35
@@ -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,37 @@
 {
 	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 = 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 +1427,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 +1730,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 +1743,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);
 		}
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/15 12:35:35
@@ -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)				\
+	((String) (Word) ( ( ((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: tests/hard_coded/higher_order_type_manip.exp
===================================================================
func(type_info) = string
pred(type_info, c_pointer, list(type_info))
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.

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"),
	{ 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").


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