[m-dev.] Re: construct__get_functor bug

Peter Ross pro at missioncriticalit.com
Fri Dec 20 03:36:04 AEDT 2002


Hi,

This is not a diff I plan to check in.  It represents my first attempt
to fix problems with get_construct that I identified in an earlier
mail.

I would like comments on approach, better way to code it, functions in
the RTTI that I have missed and anything else you can think off.  This
is more a learning experience for me about the RTTI then a bug fix!

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


library/construct.m:
	Add a new version of get_functor which takes a term of the
	type we are trying to get the functor for.  This allows one to
	handle functors with existentially quantified arguments.

runtime/mercury_construct.c:
	Add missing MR_TYPECTOR_REP_UNIV cases to the switch.

runtime/mercury_type_info.c:
	Add a version of MR_pseudo_type_info_vector_to_type_info_list
	which handles existentially quantified types.
	Add the function MR_may_contain_existq_type_infos which
	returns true iff a type may contain existentially quantified
	types, in other words it is a DU type.  If it may contain an
	existentially quantified type then we return the arg_vector
	and functor_desc which are used to create a type_info of that
	type.

Index: library/construct.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/construct.m,v
retrieving revision 1.8
diff -u -r1.8 construct.m
--- library/construct.m	21 Nov 2002 15:14:43 -0000	1.8
+++ library/construct.m	19 Dec 2002 16:27:21 -0000
@@ -55,6 +55,11 @@
 		list(type_desc__type_desc)::out, list(maybe(string))::out)
 		is semidet.
 
+:- pred get_functor(T::in,
+		type_desc__type_desc::in, int::in, string::out, int::out,
+		list(type_desc__type_desc)::out, list(maybe(string))::out)
+		is semidet.
+
 	% get_functor_ordinal(Type, I, Ordinal)
 	%
 	% Returns Ordinal, where Ordinal is the position in declaration order
@@ -169,6 +174,11 @@
     get_functor_2(TypeDesc, I, Functor, Arity, TypeInfoList, ArgNameList0),
     ArgNameList = map(null_to_no, ArgNameList0).
 
+get_functor(T, TypeDesc, I, Functor, Arity, TypeInfoList, ArgNameList) :-
+    get_functor_2(T, TypeDesc, I, Functor, Arity, TypeInfoList, ArgNameList0),
+    ArgNameList = map(null_to_no, ArgNameList0).
+
+
 :- func null_to_no(string) = maybe(string).
 
 null_to_no(S) = ( if null(S) then no else yes(S) ).
@@ -194,6 +204,97 @@
 	% This version is only used for back-ends for which there is no
 	% matching foreign_proc version.
 	private_builtin__sorry("construct__null").
+
+:- pred get_functor_2(T::in,
+	type_desc__type_desc::in, int::in, string::out, int::out,
+	list(type_desc__type_desc)::out, list(string)::out) is semidet.
+
+:- pragma foreign_proc("C",
+	get_functor_2(Term::in, TypeDesc::in, FunctorNumber::in,
+		FunctorName::out, Arity::out,
+		TypeInfoList::out, ArgNameList::out),
+	[will_not_call_mercury, thread_safe, promise_pure],
+"{
+    MR_TypeInfo         type_info;
+    MR_TypeCtorInfo	type_ctor_info;
+    MR_Construct_Info   construct_info;
+    int                 arity;
+    MR_bool             success;
+    MR_Word		*arg_vector;
+    MR_DuFunctorDesc	*functor_desc;
+
+    type_info = (MR_TypeInfo) TypeDesc;
+
+        /*
+        ** Get information for this functor number and
+        ** store in construct_info. If this is a discriminated union
+        ** type and if the functor number is in range, we
+        ** succeed.
+        */
+    MR_save_transient_registers();
+    success = MR_get_functors_check_range(FunctorNumber,
+                type_info, &construct_info);
+    MR_restore_transient_registers();
+
+        /*
+        ** Get the functor name and arity, construct the list
+        ** of type_infos for arguments.
+        */
+
+    if (success) {
+        MR_make_aligned_string(FunctorName, (MR_String) (MR_Word)
+                construct_info.functor_name);
+        arity = construct_info.arity;
+        Arity = arity;
+
+        if (MR_TYPE_CTOR_INFO_IS_TUPLE(
+                        MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info)))
+        {
+	    int i;
+            MR_save_transient_registers();
+            TypeInfoList = MR_type_params_vector_to_list(Arity,
+                    MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info));
+            ArgNameList = MR_list_empty();
+            for (i = 0; i < Arity; i++) {
+                ArgNameList = MR_list_cons_msg((MR_Word) NULL,
+                                ArgNameList, MR_PROC_LABEL);
+            }
+            MR_restore_transient_registers();
+        } else {
+	    type_ctor_info = MR_TYPEINFO_GET_TYPE_CTOR_INFO(type_info);
+	    if (MR_may_contain_existq_type_infos(Term, type_ctor_info,
+	    		&functor_desc, &arg_vector)) {
+		MR_save_transient_registers();
+		TypeInfoList =
+		     MR_pseudo_type_info_vector_to_type_info_list_maybe_existq(
+			    arity,
+			    MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
+			    arg_vector, functor_desc,
+			    construct_info.arg_pseudo_type_infos);
+            	MR_restore_transient_registers();
+	    } else {
+		MR_save_transient_registers();
+		TypeInfoList =
+		     MR_pseudo_type_info_vector_to_type_info_list(
+			    arity,
+			    MR_TYPEINFO_GET_FIXED_ARITY_ARG_VECTOR(type_info),
+			    construct_info.arg_pseudo_type_infos);
+            	MR_restore_transient_registers();
+	    }
+
+	    MR_save_transient_registers();
+            ArgNameList = MR_arg_name_vector_to_list(
+                arity, construct_info.arg_names);
+            MR_restore_transient_registers();
+        }
+    }
+    SUCCESS_INDICATOR = success;
+}").
+
+get_functor_2(_, _, _, _, _, _, _) :-
+	% This version is only used for back-ends for which there is no
+	% matching foreign_proc version.
+	private_builtin__sorry("construct__get_functor_2").
 
 :- pred get_functor_2(type_desc__type_desc::in, int::in, string::out, int::out,
 	list(type_desc__type_desc)::out, list(string)::out) is semidet.
Index: runtime/mercury_construct.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_construct.c,v
retrieving revision 1.6
diff -u -r1.6 mercury_construct.c
--- runtime/mercury_construct.c	2 Sep 2002 05:48:02 -0000	1.6
+++ runtime/mercury_construct.c	19 Dec 2002 16:27:21 -0000
@@ -51,6 +51,7 @@
     case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
     case MR_TYPECTOR_REP_DU:
     case MR_TYPECTOR_REP_DU_USEREQ:
+    case MR_TYPECTOR_REP_UNIV:
         {
             const MR_DuFunctorDesc    *functor_desc;
 
@@ -275,6 +276,7 @@
         case MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ:
         case MR_TYPECTOR_REP_ENUM:
         case MR_TYPECTOR_REP_ENUM_USEREQ:
+        case MR_TYPECTOR_REP_UNIV:
             functors = MR_type_ctor_num_functors(type_ctor_info);
             break;
 
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.54
diff -u -r1.54 mercury_type_info.c
--- runtime/mercury_type_info.c	21 Nov 2002 15:14:39 -0000	1.54
+++ runtime/mercury_type_info.c	19 Dec 2002 16:27:21 -0000
@@ -482,3 +482,88 @@
 	MR_save_transient_registers();
 	return type_info_list;
 }
+
+MR_Word
+MR_pseudo_type_info_vector_to_type_info_list_maybe_existq(int arity,
+	MR_TypeInfoParams type_params,
+	const MR_Word *data_value, const MR_DuFunctorDesc *functor_desc,
+	const MR_PseudoTypeInfo *arg_pseudo_type_infos)
+{
+	MR_TypeInfo arg_type_info;
+	MR_Word     type_info_list;
+
+	MR_restore_transient_registers();
+	type_info_list = MR_list_empty();
+
+	while (--arity >= 0) {
+			/* Get the argument type_info */
+
+		MR_save_transient_registers();
+		arg_type_info = MR_create_type_info_maybe_existq(type_params,
+			arg_pseudo_type_infos[arity], data_value, functor_desc);
+		MR_restore_transient_registers();
+
+		MR_save_transient_registers();
+		arg_type_info = MR_collapse_equivalences(arg_type_info);
+		MR_restore_transient_registers();
+
+		type_info_list = MR_list_cons((MR_Word) arg_type_info,
+			type_info_list);
+	}
+
+	MR_save_transient_registers();
+	return type_info_list;
+}
+
+MR_bool
+MR_may_contain_existq_type_infos(const MR_Word data,
+		const MR_TypeCtorInfo tci, MR_DuFunctorDesc **functor_desc,
+		MR_Word **arg_vector)
+{
+    MR_DuTypeLayout du_type_layout;
+    switch(MR_type_ctor_rep(tci)) {
+	case MR_TYPECTOR_REP_DU:
+	case MR_TYPECTOR_REP_DU_USEREQ:
+	case MR_TYPECTOR_REP_UNIV:
+	{
+	    const MR_DuPtagLayout   *ptag_layout;
+	    const MR_DuExistInfo    *exist_info;
+	    int                     ptag;
+	    MR_Word                 sectag;
+
+	    ptag = MR_tag(data);
+	    du_type_layout = MR_type_ctor_layout(tci).MR_layout_du;
+	    ptag_layout = &du_type_layout[ptag];
+
+	    switch (ptag_layout->MR_sectag_locn) {
+		case MR_SECTAG_NONE:
+		    *functor_desc = ptag_layout->MR_sectag_alternatives[0];
+		    *arg_vector = (MR_Word *) MR_body(data, ptag);
+		    break;
+		case MR_SECTAG_LOCAL:
+		    sectag = MR_unmkbody(data);
+		    *functor_desc =
+			ptag_layout->MR_sectag_alternatives[sectag];
+		    *arg_vector = NULL;
+		    break;
+		case MR_SECTAG_REMOTE:
+		    sectag = MR_field(ptag, data, 0);
+		    *functor_desc =
+			ptag_layout->MR_sectag_alternatives[sectag];
+		    *arg_vector = (MR_Word *) MR_body(data, ptag) + 1;
+		    break;
+		case MR_SECTAG_VARIABLE:
+		    /* XXX how do I handle this case */
+		default:
+		    MR_fatal_error("MR_may_contain_existq_type_infos"
+			 ": invalid sectag_locn");
+		}
+
+	    	return MR_TRUE;
+	    }
+	    default:
+		return MR_FALSE;
+    }
+}
+		
+
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.97
diff -u -r1.97 mercury_type_info.h
--- runtime/mercury_type_info.h	21 Nov 2002 15:14:40 -0000	1.97
+++ runtime/mercury_type_info.h	19 Dec 2002 16:27:22 -0000
@@ -1578,6 +1578,18 @@
                         MR_TypeInfoParams type_params,
                         const MR_PseudoTypeInfo *arg_pseudo_type_infos);
 
+extern  MR_Word     MR_pseudo_type_info_vector_to_type_info_list_maybe_existq(
+                        int arity,
+                        MR_TypeInfoParams type_params,
+                        const MR_Word *data_value,
+                        const MR_DuFunctorDesc *functor_desc,
+                        const MR_PseudoTypeInfo *arg_pseudo_type_infos);
+
+extern  MR_bool
+MR_may_contain_existq_type_infos(const MR_Word data_word_ptr,
+		const MR_TypeCtorInfo tci, MR_DuFunctorDesc **functor_desc,
+		MR_Word **arg_vector);
+
 /*---------------------------------------------------------------------------*/
 
 #endif /* not MERCURY_TYPE_INFO_H */

--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------



More information about the developers mailing list