[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