[m-dev.] for review: RTTI for existential types (revised)
David Glen JEFFERY
dgj at cs.mu.OZ.AU
Tue Dec 7 17:04:03 AEDT 1999
Hi Fergus,
Here is a diff which addresses your previous comments, including implementing
deep copying for existentially typed functors.
==========================================================================
Estimated hours taken: 160
Implement RTTI for functors with existentially typed arguments. This allows
these functors to be deconstructed (and therefore io__write works for them)
and deep_copied.
compiler/base_type_layout.m:
Generate extra information in the stack layout: the RTTI needs to
include the number of extra arguments added for type infos and
typeclass infos for each functor, as well as the locations of the
type infos for each type.
compiler/stack_layout.m:
Pass some extra arguments indicating that the pseudo type infos being
handled are not existentially quantified.
compiler/std_util.m:
Change ML_expand so that it includes information about existentially
quantified arguments in the expand info.
compiler/base_typeclass_info.m:
Extend the typeclass info structure to include enough information to
copy it at runtime.
runtime/mercury_type_info.c:
Use the new information in the RTTI to look up the type info packed
inside a constructor if the pseudo type-info in question is
existentially quantified. This may involve looking inside a typeclass
info or just taking the type info directly.
runtime/mercury_deep_copy_body.h:
Use the new RTTI to lookup up type so existentially quantified
variables when doing a deep copy.
Implement a function to deep copy typeclass infos.
runtime/mercury_deep_copy.c:
#define the appropriate things to make copy_typeclass_info work for
the different ways of allocating memory.
runtime/mercury_type_info.h:
Change some prototypes and add macros to access the new information in
the functor descriptor.
Change the macros which access typeclass infos to reflect the new
structure.
==========================================================================
cvs diff: Diffing .
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing bytecode/test
cvs diff: Diffing compiler
Index: compiler/base_type_layout.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/base_type_layout.m,v
retrieving revision 1.46
diff -u -t -r1.46 base_type_layout.m
--- base_type_layout.m 1999/07/13 08:52:40 1.46
+++ base_type_layout.m 1999/12/01 07:20:58
@@ -227,15 +227,27 @@
list(comp_gen_c_data)).
:- mode base_type_layout__generate_llds(in, out, out) is det.
- % Given a Mercury type, this predicate returns an rval giving the
- % pseudo type info for that type, plus the llds_type of that rval.
- % The int arguments are label numbers for generating `create' rvals
- % with.
+ % base_type_layout__construct_typed_pseudo_type_info(Type,
+ % NumUnivQTvars, ExistQVars, Rval, LldsType, LabelNum0, LabelNum)
+ %
+ % Given a Mercury type (`Type'), this predicate returns an rval (`Rval')
+ % giving the pseudo type info for that type, plus the llds_type
+ % (`LldsType') of that rval. NumUnivQTvars is the number of universally
+ % quantified type variables of the enclosing type and ExistQVars is the
+ % list of existentially quantified type variables of the constructor in
+ % question.
+ % The int arguments (`LabelNum0' and `LabelNum') are label numbers for
+ % generating `create' rvals with.
:- pred base_type_layout__construct_typed_pseudo_type_info(type,
+ int, existq_tvars,
rval, llds_type, int, int).
:- mode base_type_layout__construct_typed_pseudo_type_info(in,
+ in, in,
out, out, in, out) is det.
+ % Maximum value of an integer representation of a variable.
+:- pred base_type_layout__max_varint(int::out) is det.
+
:- implementation.
:- import_module hlds_data, hlds_pred, hlds_out, builtin_ops, type_util.
@@ -247,6 +259,7 @@
layout_info(
module_name, % module name
cons_table, % ctor table
+ class_table, % class table
int, % number of tags available
int, % next available label
type_id, % type_id of type being currently examined
@@ -325,12 +338,13 @@
int__pow(2, NumTagBits, MaxTags),
module_info_name(ModuleInfo0, ModuleName),
module_info_ctors(ModuleInfo0, ConsTable),
+ module_info_classes(ModuleInfo0, ClassTable),
module_info_get_cell_count(ModuleInfo0, CellCount),
- LayoutInfo0 = layout_info(ModuleName, ConsTable, MaxTags, CellCount,
- unqualified("") - 0, []),
+ LayoutInfo0 = layout_info(ModuleName, ConsTable, ClassTable,
+ MaxTags, CellCount, unqualified("") - 0, []),
base_type_layout__construct_base_type_data(BaseGenInfos, Globals,
LayoutInfo0, LayoutInfo),
- LayoutInfo = layout_info(_, _, _, FinalCellCount, _, CModules),
+ LayoutInfo = layout_info(_, _, _, _, FinalCellCount, _, CModules),
module_info_set_cell_count(ModuleInfo0, FinalCellCount, ModuleInfo).
%---------------------------------------------------------------------------%
@@ -484,9 +498,6 @@
base_type_layout__enum_indicator(no, 0).
base_type_layout__enum_indicator(yes, 1).
- % Maximum value of a integer representation of a variable.
-
-:- pred base_type_layout__max_varint(int::out) is det.
base_type_layout__max_varint(1024).
% Tag values
@@ -717,9 +728,15 @@
base_type_layout__no_tag_indicator(yes, NoTagIndicator),
Rval0 = yes(const(int_const(NoTagIndicator))),
+ base_type_layout__get_type_id(LayoutInfo0, _-NumUnivQTvars),
+
+ % This is a no-tag type so there can't be any existentially
+ % quantified args.
+ ExistQVars0 = [],
+
% generate pseudo_type_info
- base_type_layout__generate_pseudo_type_info(Type, Rval1, LayoutInfo0,
- LayoutInfo1),
+ base_type_layout__generate_pseudo_type_info(Type, NumUnivQTvars,
+ ExistQVars0, Rval1, LayoutInfo0, LayoutInfo1),
% functor name
unqualify_name(SymName, Name),
@@ -739,14 +756,19 @@
% Tag is 3, rest of word is pointer to pseudo_type_info or
% variable number
-:- pred base_type_layout__layout_eqv(type, layout_info,
- layout_info, list(maybe(rval))).
+:- pred base_type_layout__layout_eqv(type, layout_info, layout_info,
+ list(maybe(rval))).
:- mode base_type_layout__layout_eqv(in, in, out, out) is det.
base_type_layout__layout_eqv(Type, LayoutInfo0, LayoutInfo, Rvals) :-
+ base_type_layout__get_type_id(LayoutInfo0, _-NumUnivQTvars),
+
+ % There are no existentially typed args to an equivalence.
+ ExistQVars = [],
+
% generate rest of word, remove a level of creates
- base_type_layout__generate_pseudo_type_info(Type, Rval0, LayoutInfo0,
- LayoutInfo1),
+ base_type_layout__generate_pseudo_type_info(Type, NumUnivQTvars,
+ ExistQVars, Rval0, LayoutInfo0, LayoutInfo1),
base_type_layout__tag_value_equiv(Tag),
(
% If it was a constant (a type variable), then tag it
@@ -905,6 +927,16 @@
% N pseudo-typeinfos (of the arguments)
% - a string constant (the name of the functor)
% - tag information
+ % M - the number of extra arguments for type-infos and
+ % typeclass-infos of existentially quantified arguments
+ % The location of each such type-info. (This is a tagged word
+ % indicating whether the type-info exists as an argument of
+ % the functor in its own right or whether it is nested inside
+ % a typeclass-info. If it is the former, the rest of the word
+ % just contains the argument number. If the latter, the rest
+ % of the word contains two numbers: the argument number of
+ % the typeclass-info and the index of the type-info inside
+ % it).
:- pred base_type_layout__functor_descriptor(list(pair(cons_id, cons_tag)),
layout_info, layout_info, list(maybe(rval))).
@@ -923,15 +955,145 @@
),
base_type_layout__get_cons_args(LayoutInfo0, ConsId, ConsArgs),
list__length(ConsArgs, NumArgs),
- list__map_foldl(base_type_layout__generate_pseudo_type_info,
+
+ base_type_layout__get_type_id(LayoutInfo0, TypeId),
+
+ % XXX we are re-doing work from base_type_layout__get_cons_args
+ base_type_layout__get_cons_table(LayoutInfo0, ConsTable),
+ map__lookup(ConsTable, ConsId, MatchingCons),
+ list__filter(
+ (pred(hlds_cons_defn(_, _, _, TheTypeId, _)::in) is semidet :-
+ TheTypeId = TypeId
+ ), MatchingCons, MatchingConsCorrectType),
+
+ (
+ MatchingConsCorrectType =
+ [hlds_cons_defn(ExistQVars0, Constraints0, _, _, _)]
+ ->
+ ExistQVars = ExistQVars0,
+ Constraints = Constraints0
+ ;
+ error("base_type_layout__functor_descriptor: no constructor of the correct type!")
+ ),
+
+ TypeId = _ - NumUnivQTvars,
+
+ list__map_foldl((pred(C::in, P::out, L0::in, L::out) is det :-
+ base_type_layout__generate_pseudo_type_info(C,
+ NumUnivQTvars, ExistQVars, P, L0, L)
+ ),
ConsArgs, PseudoTypeInfos, LayoutInfo0, LayoutInfo1),
base_type_layout__encode_cons_tag(ConsTag, ConsTagRvals, LayoutInfo1,
LayoutInfo),
+
+ base_type_layout__generate_type_info_locns(ExistQVars, Constraints,
+ Locns, NumExtraTypeInfos, NumExtraTypeClassInfos, LayoutInfo),
+ list__map((pred(Tvar::in, yes(Locn)::out) is det :-
+ map__lookup(Locns, Tvar, Locn)
+ ), ExistQVars, ExistQVarLocns),
+
list__append([yes(const(int_const(NumArgs))) | PseudoTypeInfos],
[yes(const(string_const(ConsString))) | ConsTagRvals],
+ EndRvals0),
+ NTypeInfos = yes(const(int_const(NumExtraTypeInfos))),
+ NTypeClassInfos = yes(const(int_const(NumExtraTypeClassInfos))),
+ list__append(EndRvals0, [NTypeInfos, NTypeClassInfos |ExistQVarLocns],
EndRvals).
+:- pred base_type_layout__generate_type_info_locns(list(tvar),
+ list(class_constraint), map(tvar, rval), int, int, layout_info).
+:- mode base_type_layout__generate_type_info_locns(in, in, out, out, out, in)
+ is det.
+
+base_type_layout__generate_type_info_locns(Tvars, Constraints, Locns,
+ NUnconstrained, NumConstraints, Info) :-
+ base_type_layout__get_class_table(Info, ClassTable),
+ list__map((pred(C::in, Ts::out) is det :- C = constraint(_, Ts)),
+ Constraints, ConstrainedTvars0),
+ list__condense(ConstrainedTvars0, ConstrainedTvars1),
+ term__vars_list(ConstrainedTvars1, ConstrainedTvars2),
+ list__delete_elems(Tvars, ConstrainedTvars2, UnconstrainedTvars),
+ % We do this to maintain the ordering of the type variables.
+ list__delete_elems(Tvars, UnconstrainedTvars, ConstrainedTvars),
+ map__init(Locns0),
+ list__foldl((pred(T::in, N0-Ls0::in, N-Ls::out) is det :-
+ make_direct_typeinfo_index(N0, Locn),
+ map__det_insert(Ls0, T, Locn, Ls),
+ N = N0 + 1
+ ), UnconstrainedTvars, 0-Locns0, NUnconstrained-Locns1),
+ list__foldl(
+ find_type_info_index(Constraints, ClassTable, NUnconstrained),
+ ConstrainedTvars, Locns1, Locns),
+ list__length(Constraints, NumConstraints).
+
+:- pred find_type_info_index(list(class_constraint)::in, class_table::in,
+ int::in, tvar::in, map(tvar, rval)::in, map(tvar, rval)::out) is det.
+find_type_info_index(Constraints, ClassTable, NUn, Tvar, Locns0, Locns) :-
+ first_matching_type_class_info(Constraints, Tvar,
+ FirstConstraint, NUn, ThisN, TypeInfoIndex),
+ FirstConstraint = constraint(ClassName, Args),
+ list__length(Args, ClassArity),
+ map__lookup(ClassTable, class_id(ClassName, ClassArity), ClassDefn),
+ ClassDefn = hlds_class_defn(SuperClasses, _, _, _, _),
+ list__length(SuperClasses, NumSuperClasses),
+ RealTypeInfoIndex = TypeInfoIndex + NumSuperClasses,
+ make_indirect_typeinfo_index(ThisN, RealTypeInfoIndex, Rval),
+ map__det_insert(Locns0, Tvar, Rval, Locns).
+
+:- pred first_matching_type_class_info(list(class_constraint)::in, tvar::in,
+ class_constraint::out, int::in, int::out, int::out) is det.
+first_matching_type_class_info([], _, _, _, _, _) :-
+ error("base_type_layout: constrained type info not found").
+first_matching_type_class_info([C|Cs], Tvar, MatchingConstraint, N0, N,
+ TypeInfoIndex) :-
+ C = constraint(_, Ts),
+ term__vars_list(Ts, TVs),
+ (
+ list__nth_member_search(TVs, Tvar, Index)
+ ->
+ N = N0,
+ MatchingConstraint = C,
+ TypeInfoIndex = Index
+ ;
+ first_matching_type_class_info(Cs, Tvar, MatchingConstraint,
+ N0+1, N, TypeInfoIndex)
+ ).
+%--------------------------------------------------------------------------%
+% Note: Any changes to this code will need to be reflected in
+% runtime/mercury_type_info.c
+
+:- pred make_direct_typeinfo_index(int::in, rval::out) is det.
+make_direct_typeinfo_index(N, Rval) :-
+ TaggedValue is (N << base_type_layout__indirect_tag_bits)
+ + base_type_layout__direct_tag,
+ Rval = const(int_const(TaggedValue)).
+
+:- pred make_indirect_typeinfo_index(int::in, int::in, rval::out) is det.
+make_indirect_typeinfo_index(ArgNumber, TypeInfoNumber, Rval) :-
+ require((1 << base_type_layout__indirect_offset_bits) > ArgNumber,
+ "base_type_layout: arg number too large to be represented"),
+ TaggedValue0 is
+ (TypeInfoNumber << base_type_layout__indirect_offset_bits)
+ + ArgNumber,
+ TaggedValue is (TaggedValue0 << base_type_layout__indirect_tag_bits)
+ + base_type_layout__indirect_tag,
+ Rval = const(int_const(TaggedValue)).
+
+:- func base_type_layout__direct_tag = int.
+base_type_layout__direct_tag = 0.
+
+:- func base_type_layout__indirect_tag = int.
+base_type_layout__indirect_tag = 1.
+
+:- func base_type_layout__indirect_tag_bits = int.
+base_type_layout__indirect_tag_bits = 1.
+
+:- func base_type_layout__indirect_offset_bits = int.
+base_type_layout__indirect_offset_bits = 6.
+
+%--------------------------------------------------------------------------%
+
% For shared remote tags:
%
% Tag 2, with a pointer to an array containing:
@@ -987,9 +1149,12 @@
base_type_layout__functors_eqv(Type, LayoutInfo0, LayoutInfo, Rvals) :-
+ ExistQTvars = [],
+ base_type_layout__get_type_id(LayoutInfo0, _-NumUnivQTvars),
+
% Construct pseudo
- base_type_layout__generate_pseudo_type_info(Type, Rvals0, LayoutInfo0,
- LayoutInfo),
+ base_type_layout__generate_pseudo_type_info(Type, NumUnivQTvars,
+ ExistQTvars, Rvals0, LayoutInfo0, LayoutInfo),
base_type_layout__functors_value(equiv, EqvIndicator),
EqvRval = yes(const(int_const(EqvIndicator))),
Rvals = [EqvRval, Rvals0].
@@ -1089,25 +1254,30 @@
%---------------------------------------------------------------------------%
-:- pred base_type_layout__generate_pseudo_type_info(type, maybe(rval),
- layout_info, layout_info).
-:- mode base_type_layout__generate_pseudo_type_info(in, out, in, out) is det.
+:- pred base_type_layout__generate_pseudo_type_info(type, int, existq_tvars,
+ maybe(rval), layout_info, layout_info).
+:- mode base_type_layout__generate_pseudo_type_info(in, in, in, out,
+ in, out) is det.
-base_type_layout__generate_pseudo_type_info(Type, yes(Rval), LayoutInfo0,
- LayoutInfo) :-
+base_type_layout__generate_pseudo_type_info(Type, NumUnivQTvars, ExistQTvars,
+ yes(Rval), LayoutInfo0, LayoutInfo) :-
base_type_layout__get_cell_number(LayoutInfo0, CellNumber0),
- base_type_layout__construct_pseudo_type_info(Type, Rval,
- CellNumber0, CellNumber),
+ base_type_layout__construct_pseudo_type_info(Type, NumUnivQTvars,
+ ExistQTvars, Rval, CellNumber0, CellNumber),
base_type_layout__set_cell_number(CellNumber, LayoutInfo0, LayoutInfo).
-
-:- pred base_type_layout__construct_pseudo_type_info(type, rval, int, int).
-:- mode base_type_layout__construct_pseudo_type_info(in, out, in, out) is det.
-base_type_layout__construct_pseudo_type_info(Type, Pseudo, CNum0, CNum) :-
- base_type_layout__construct_typed_pseudo_type_info(Type, Pseudo, _,
- CNum0, CNum).
+:- pred base_type_layout__construct_pseudo_type_info(type, int, existq_tvars,
+ rval, int, int).
+:- mode base_type_layout__construct_pseudo_type_info(in, in, in, out,
+ in, out) is det.
+
+base_type_layout__construct_pseudo_type_info(Type, NumUnivQTvars, ExistQTvars,
+ Pseudo, CNum0, CNum) :-
+ base_type_layout__construct_typed_pseudo_type_info(Type, NumUnivQTvars,
+ ExistQTvars, Pseudo, _, CNum0, CNum).
-base_type_layout__construct_typed_pseudo_type_info(Type, Pseudo, LldsType,
+base_type_layout__construct_typed_pseudo_type_info(Type, NumUnivQTvars,
+ ExistQTvars, Pseudo, LldsType,
CNum0, CNum) :-
(
type_to_type_id(Type, TypeId, TypeArgs0)
@@ -1154,7 +1324,10 @@
CNum1 = CNum0 + 1,
% generate args, but remove one level of create()s.
- list__map_foldl(base_type_layout__construct_pseudo_type_info,
+ list__map_foldl((pred(T::in, P::out, C0::in, C::out) is det :-
+ base_type_layout__construct_pseudo_type_info(
+ T, NumUnivQTvars, ExistQTvars, P, C0, C)
+ ),
TypeArgs, PseudoArgs0, CNum1, CNum),
list__map(base_type_layout__remove_create, PseudoArgs0,
PseudoArgs1),
@@ -1166,7 +1339,33 @@
;
type_util__var(Type, Var)
->
- term__var_to_int(Var, VarInt),
+ % In the case of a type variable, we need to assign a
+ % variable number *for this constructor* ie. taking
+ % only the existentially quantified variables of
+ % this constructor (and not those of other functors in
+ % the same type) into account.
+
+ % XXX term__var_to_int doesn't gaurantee anything about
+ % the the ints returned (other than that they be
+ % distinct for different variables), but we are relying
+ % on more here.
+ term__var_to_int(Var, VarInt0),
+ (
+ VarInt0 =< NumUnivQTvars
+ ->
+ % This is a universally quantified variable.
+ VarInt = VarInt0
+ ;
+ % It is existentially quantified.
+ (
+ list__nth_member_search(ExistQTvars,
+ Var, ExistNum0)
+ ->
+ VarInt = ExistNum0 + NumUnivQTvars
+ ;
+ error("base_type_layout: var not in list")
+ )
+ ),
base_type_layout__max_varint(MaxVarInt),
require(VarInt < MaxVarInt,
"type_ctor_layout: type variable representation exceeds limit"),
@@ -1285,57 +1484,62 @@
:- pred base_type_layout__get_module_name(layout_info, module_name).
:- mode base_type_layout__get_module_name(in, out) is det.
base_type_layout__get_module_name(LayoutInfo, ModuleName) :-
- LayoutInfo = layout_info(ModuleName, _, _, _, _, _).
+ LayoutInfo = layout_info(ModuleName, _, _, _, _, _, _).
:- pred base_type_layout__get_cons_table(layout_info, cons_table).
:- mode base_type_layout__get_cons_table(in, out) is det.
base_type_layout__get_cons_table(LayoutInfo, ConsTable) :-
- LayoutInfo = layout_info(_, ConsTable, _, _, _, _).
+ LayoutInfo = layout_info(_, ConsTable, _, _, _, _, _).
:- pred base_type_layout__get_max_tags(layout_info, int).
:- mode base_type_layout__get_max_tags(in, out) is det.
base_type_layout__get_max_tags(LayoutInfo, MaxTags) :-
- LayoutInfo = layout_info(_, _, MaxTags, _, _, _).
+ LayoutInfo = layout_info(_, _, _, MaxTags, _, _, _).
:- pred base_type_layout__get_cell_number(layout_info, int).
:- mode base_type_layout__get_cell_number(in, out) is det.
base_type_layout__get_cell_number(LayoutInfo, NextCNum) :-
- LayoutInfo = layout_info(_, _, _, NextCNum, _, _).
+ LayoutInfo = layout_info(_, _, _, _, NextCNum, _, _).
:- pred base_type_layout__get_type_id(layout_info, type_id).
:- mode base_type_layout__get_type_id(in, out) is det.
base_type_layout__get_type_id(LayoutInfo, TypeId) :-
- LayoutInfo = layout_info(_, _, _, _, TypeId, _).
+ LayoutInfo = layout_info(_, _, _, _, _, TypeId, _).
:- pred base_type_layout__get_c_data(layout_info, list(comp_gen_c_data)).
:- mode base_type_layout__get_c_data(in, out) is det.
base_type_layout__get_c_data(LayoutInfo, CModules) :-
- LayoutInfo = layout_info(_, _, _, _, _, CModules).
+ LayoutInfo = layout_info(_, _, _, _, _, _, CModules).
+
+:- pred base_type_layout__get_class_table(layout_info, class_table).
+:- mode base_type_layout__get_class_table(in, out) is det.
+base_type_layout__get_class_table(LayoutInfo, Table) :-
+ LayoutInfo = layout_info(_, _, Table, _, _, _, _).
:- pred base_type_layout__add_c_data(layout_info, comp_gen_c_data,
layout_info).
:- mode base_type_layout__add_c_data(in, in, out) is det.
base_type_layout__add_c_data(LayoutInfo0, CModule, LayoutInfo) :-
- LayoutInfo0 = layout_info(A, B, C, D, E, CModules0),
+ LayoutInfo0 = layout_info(A, B, C, D, E, F, CModules0),
CModules = [CModule | CModules0],
- LayoutInfo = layout_info(A, B, C, D, E, CModules).
+ LayoutInfo = layout_info(A, B, C, D, E, F, CModules).
:- pred base_type_layout__get_next_cell_number(int, layout_info, layout_info).
:- mode base_type_layout__get_next_cell_number(out, in, out) is det.
base_type_layout__get_next_cell_number(CNum0, LayoutInfo0, LayoutInfo) :-
- LayoutInfo0 = layout_info(A, B, C, CNum0, E, F),
+ LayoutInfo0 = layout_info(A, B, C, D, CNum0, F, G),
CNum = CNum0 + 1,
- LayoutInfo = layout_info(A, B, C, CNum, E, F).
+ LayoutInfo = layout_info(A, B, C, D, CNum, F, G).
:- pred base_type_layout__set_cell_number(int, layout_info, layout_info).
:- mode base_type_layout__set_cell_number(in, in, out) is det.
base_type_layout__set_cell_number(NextLabel, LayoutInfo0, LayoutInfo) :-
- LayoutInfo0 = layout_info(A, B, C, _, E, F),
- LayoutInfo = layout_info(A, B, C, NextLabel, E, F).
+ LayoutInfo0 = layout_info(A, B, C, D, _, F, G),
+ LayoutInfo = layout_info(A, B, C, D, NextLabel, F, G).
:- pred base_type_layout__set_type_id(layout_info, type_id, layout_info).
:- mode base_type_layout__set_type_id(in, in, out) is det.
base_type_layout__set_type_id(LayoutInfo0, TypeId, LayoutInfo) :-
- LayoutInfo0 = layout_info(A, B, C, D, _, F),
- LayoutInfo = layout_info(A, B, C, D, TypeId, F).
+ LayoutInfo0 = layout_info(A, B, C, D, E, _, G),
+ LayoutInfo = layout_info(A, B, C, D, E, TypeId, G).
Index: compiler/base_typeclass_info.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/base_typeclass_info.m,v
retrieving revision 1.12
diff -u -t -r1.12 base_typeclass_info.m
--- base_typeclass_info.m 1999/04/30 06:19:09 1.12
+++ base_typeclass_info.m 1999/12/01 07:07:15
@@ -90,16 +90,9 @@
DataName = base_typeclass_info(ClassId, InstanceString),
base_typeclass_info__gen_rvals_and_procs(PredProcIds,
- InstanceConstraints, ModuleInfo, Rvals0, Procs),
-
- /*
- base_typeclass_info__gen_superclass_rvals(ClassId, ModuleInfo,
- InstanceTypes, SuperClassRvals),
-
- list__append(Rvals0, SuperClassRvals, Rvals),
- */
- Rvals = Rvals0,
-
+ InstanceConstraints, ModuleInfo, ClassId,
+ Rvals, Procs),
+
% XXX Need we always export it from the module?
% (Note that linkage/2 in llds_out.m assumes
% that we do.)
@@ -117,14 +110,15 @@
%----------------------------------------------------------------------------%
:- pred base_typeclass_info__gen_rvals_and_procs(maybe(list(hlds_class_proc)),
- list(class_constraint), module_info, list(maybe(rval)),
+ list(class_constraint), module_info, class_id, list(maybe(rval)),
list(pred_proc_id)).
-:- mode base_typeclass_info__gen_rvals_and_procs(in, in, in, out, out) is det.
+:- mode base_typeclass_info__gen_rvals_and_procs(in, in, in, in,
+ out, out) is det.
-base_typeclass_info__gen_rvals_and_procs(no, _, _, [], []) :-
+base_typeclass_info__gen_rvals_and_procs(no, _, _, _, [], []) :-
error("pred_proc_ids should have been filled in by check_typeclass.m").
base_typeclass_info__gen_rvals_and_procs(yes(PredProcIds0), Constraints,
- ModuleInfo, Rvals, PredProcIds) :-
+ ModuleInfo, ClassId, Rvals, PredProcIds) :-
list__length(Constraints, InstanceArity),
ArityArg = yes(const(int_const(InstanceArity))),
ExtractPredProcId = lambda([HldsPredProc::in, PredProc::out] is det,
@@ -135,7 +129,9 @@
list__map(ExtractPredProcId, PredProcIds0, PredProcIds),
base_typeclass_info__construct_pred_addrs(PredProcIds, ModuleInfo,
PredAddrArgs),
- Rvals = [ArityArg|PredAddrArgs].
+ base_typeclass_info__gen_superclass_count(ClassId, ModuleInfo,
+ SuperClassCount, ClassArity),
+ Rvals = [ ArityArg, SuperClassCount, ClassArity | PredAddrArgs ].
:- pred base_typeclass_info__construct_pred_addrs(list(pred_proc_id),
module_info, list(maybe(rval))).
@@ -148,6 +144,22 @@
PredAddrArg = yes(const(code_addr_const(PredAddr))),
base_typeclass_info__construct_pred_addrs(Procs, ModuleInfo,
PredAddrArgs).
+
+%----------------------------------------------------------------------------%
+
+:- pred base_typeclass_info__gen_superclass_count(class_id, module_info,
+ maybe(rval), maybe(rval)).
+:- mode base_typeclass_info__gen_superclass_count(in, in, out, out) is det.
+
+base_typeclass_info__gen_superclass_count(ClassId, ModuleInfo,
+ SuperArg, ArityArg) :-
+ module_info_classes(ModuleInfo, ClassTable),
+ map__lookup(ClassTable, ClassId, ClassDefn),
+ ClassDefn = hlds_class_defn(SuperClassConstraints, ClassVars, _, _, _),
+ list__length(SuperClassConstraints, NumSuper),
+ list__length(ClassVars, NumVars),
+ SuperArg = yes(const(int_const(NumSuper))),
+ ArityArg = yes(const(int_const(NumVars))).
%----------------------------------------------------------------------------%
Index: compiler/stack_layout.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/stack_layout.m,v
retrieving revision 1.39
diff -u -t -r1.39 stack_layout.m
--- stack_layout.m 1999/11/25 09:09:32 1.39
+++ stack_layout.m 1999/11/30 05:31:32
@@ -1240,9 +1240,19 @@
stack_layout__construct_closure_arg_rval(ClosureArg,
yes(ArgRval) - ArgRvalType, CNum0, CNum) :-
ClosureArg = closure_arg_info(Type, _Inst),
- base_type_layout__construct_typed_pseudo_type_info(Type, ArgRval,
- ArgRvalType, CNum0, CNum).
+ % For a stack layout, we can treat all type variables as
+ % universally quantified. This is not the argument of a
+ % constructor, so we do not need to distinguish between type
+ % variables that are and aren't in scope; we can take the
+ % variable number directly from the procedure's tvar set.
+ ExistQTvars = [],
+ base_type_layout__max_varint(Max),
+ NumUnivQTvars = Max - 1,
+
+ base_type_layout__construct_typed_pseudo_type_info(Type,
+ NumUnivQTvars, ExistQTvars, ArgRval, ArgRvalType, CNum0, CNum).
+
%---------------------------------------------------------------------------%
% Construct a representation of the type of a value.
@@ -1298,7 +1308,17 @@
stack_layout__represent_live_value_type(var(_, _, Type, _), Rval, LldsType)
-->
stack_layout__get_cell_number(CNum0),
+
+ % For a stack layout, we can treat all type variables as
+ % universally quantified. This is not the argument of a
+ % constructor, so we do not need to distinguish between type
+ % variables that are and aren't in scope; we can take the
+ % variable number directly from the procedure's tvar set.
+ { ExistQTvars = [] },
+ { base_type_layout__max_varint(Max) },
+ { NumUnivQTvars = Max - 1 },
{ base_type_layout__construct_typed_pseudo_type_info(Type,
+ NumUnivQTvars, ExistQTvars,
Rval, LldsType, CNum0, CNum) },
stack_layout__set_cell_number(CNum).
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing detail
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/exceptions
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lazy_evaluation/examples
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/opium_m
cvs diff: Diffing extras/opium_m/non-regression-tests
cvs diff: Diffing extras/opium_m/scripts
cvs diff: Diffing extras/opium_m/source
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing library
Index: library/std_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/std_util.m,v
retrieving revision 1.174
diff -u -t -r1.174 std_util.m
--- std_util.m 1999/11/25 09:09:40 1.174
+++ std_util.m 1999/12/02 08:27:36
@@ -274,7 +274,7 @@
%
% Warning: support for existential types is still experimental.
%
-:- some([T], pred has_type(T::unused, type_info::in) is det).
+:- some [T] pred has_type(T::unused, type_info::in) is det.
% type_name(Type) returns the name of the specified type
% (e.g. type_name(type_of([2,3])) = "list:list(int)").
@@ -1797,7 +1797,7 @@
/*
** ML_typecheck_arguments:
**
- ** Given a list of univs (`arg_list'), and an vector of
+ ** Given a list of univs (`arg_list'), and a vector of
** type_infos (`arg_vector'), checks that they are all of the
** same type; if so, returns TRUE, otherwise returns FALSE;
** `arg_vector' may contain type variables, these
@@ -1825,7 +1825,6 @@
list_arg_type_info = MR_field(MR_mktag(0),
MR_list_head(arg_list), UNIV_OFFSET_FOR_TYPEINFO);
- /* XXX need to handle existential types */
arg_type_info = (Word) MR_create_type_info(
(Word *) type_info, (Word *) arg_vector[i]);
@@ -2090,6 +2089,7 @@
typedef struct ML_Expand_Info_Struct {
ConstString functor;
int arity;
+ int num_extra_args;
Word *argument_vector;
Word *type_info_vector;
bool non_canonical_type;
@@ -2184,6 +2184,7 @@
info->functor = MR_TYPE_CTOR_LAYOUT_ENUM_VECTOR_FUNCTOR_NAME(
layout_vector_for_tag, data_word);
info->arity = 0;
+ info->num_extra_args = 0;
info->argument_vector = NULL;
info->type_info_vector = NULL;
break;
@@ -2197,6 +2198,7 @@
info->functor = MR_TYPE_CTOR_LAYOUT_ENUM_VECTOR_FUNCTOR_NAME(
layout_vector_for_tag, data_value);
info->arity = 0;
+ info->num_extra_args = 0;
info->argument_vector = NULL;
info->type_info_vector = NULL;
break;
@@ -2225,6 +2227,9 @@
info->arity =
MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(functor_descriptor);
+
+ info->num_extra_args =
+ MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_VARCOUNT(functor_descriptor);
if (info->need_functor) {
MR_make_aligned_string(info->functor,
@@ -2243,9 +2248,12 @@
arg_pseudo_type_info = (Word *)
MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARGS(
- functor_descriptor)[i];
- info->type_info_vector[i] = (Word) MR_create_type_info(
- type_info, arg_pseudo_type_info);
+ functor_descriptor)[i];
+ info->type_info_vector[i] =
+ (Word) MR_create_type_info_maybe_existq(
+ type_info, arg_pseudo_type_info,
+ (Word *)data_value,
+ functor_descriptor);
}
}
break;
@@ -2263,6 +2271,7 @@
info->arity = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(
functor_descriptor);
+ info->num_extra_args = 0;
if (info->need_functor) {
MR_make_aligned_string(info->functor,
@@ -2287,8 +2296,11 @@
arg_pseudo_type_info = (Word *)
MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARGS(
functor_descriptor)[i];
- info->type_info_vector[i] = (Word) MR_create_type_info(
- type_info, arg_pseudo_type_info);
+ info->type_info_vector[i] =
+ (Word) MR_create_type_info_maybe_existq(
+ type_info, arg_pseudo_type_info,
+ (Word *)data_value,
+ functor_descriptor);
}
}
break;
@@ -2296,7 +2308,8 @@
case MR_TYPECTOR_REP_EQUIV: {
Word *equiv_type_info;
- equiv_type_info = MR_create_type_info(type_info,
+ equiv_type_info = MR_create_type_info(
+ type_info,
(Word *) MR_TYPE_CTOR_LAYOUT_EQUIV_TYPE(
layout_vector_for_tag));
ML_expand(equiv_type_info, data_word_ptr, info);
@@ -2305,7 +2318,8 @@
case MR_TYPECTOR_REP_EQUIV_VAR: {
Word *equiv_type_info;
- equiv_type_info = MR_create_type_info(type_info,
+ equiv_type_info = MR_create_type_info(
+ type_info,
(Word *) layout_vector_for_tag);
ML_expand(equiv_type_info, data_word_ptr, info);
break;
@@ -2325,6 +2339,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_CHAR:
@@ -2340,6 +2355,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_FLOAT:
@@ -2358,6 +2374,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_STRING:
@@ -2374,6 +2391,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_PRED:
@@ -2383,6 +2401,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_UNIV:
@@ -2409,6 +2428,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_TYPEINFO:
@@ -2419,6 +2439,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_TYPECLASSINFO:
@@ -2429,6 +2450,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_ARRAY:
@@ -2439,6 +2461,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_SUCCIP:
@@ -2448,6 +2471,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_HP:
@@ -2457,6 +2481,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_CURFR:
@@ -2466,6 +2491,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_MAXFR:
@@ -2475,6 +2501,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_REDOFR:
@@ -2484,6 +2511,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_REDOIP:
@@ -2493,6 +2521,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_TRAIL_PTR:
@@ -2502,6 +2531,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_TICKET:
@@ -2511,6 +2541,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_UNKNOWN: /* fallthru */
@@ -2768,7 +2799,7 @@
}
/* Fill in the data */
MR_field(MR_mktag(0), Argument, UNIV_OFFSET_FOR_DATA) =
- info.argument_vector[i];
+ info.argument_vector[i + info.num_extra_args];
}
/* Free the allocated type_info_vector, since we just copied
cvs diff: Diffing lp_solve
cvs diff: Diffing lp_solve/lp_examples
cvs diff: Diffing profiler
cvs diff: Diffing readline
cvs diff: Diffing readline/doc
cvs diff: Diffing readline/examples
cvs diff: Diffing readline/shlib
cvs diff: Diffing readline/support
cvs diff: Diffing runtime
Index: runtime/mercury_deep_copy.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_deep_copy.c,v
retrieving revision 1.15
diff -u -t -r1.15 mercury_deep_copy.c
--- mercury_deep_copy.c 1999/10/19 04:11:39 1.15
+++ mercury_deep_copy.c 1999/12/02 03:51:11
@@ -42,6 +42,9 @@
#undef copy_type_info
#define copy_type_info deep_copy_type_info
+#undef copy_typeclass_info
+#define copy_typeclass_info deep_copy_typeclass_info
+
#undef leave_forwarding_pointer
#define leave_forwarding_pointer(DataPtr, NewData)
@@ -69,6 +72,9 @@
#undef copy_type_info
#define copy_type_info agc_deep_copy_type_info
+
+#undef copy_typeclass_info
+#define copy_typeclass_info agc_deep_copy_typeclass_info
#ifdef MR_DEBUG_AGC_FORWARDING
#define FORWARD_DEBUG_MSG(Msg, Data) \
Index: runtime/mercury_deep_copy_body.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_deep_copy_body.h,v
retrieving revision 1.14
diff -u -t -r1.14 mercury_deep_copy_body.h
--- mercury_deep_copy_body.h 1999/10/28 06:22:56 1.14
+++ mercury_deep_copy_body.h 1999/12/06 06:57:35
@@ -15,11 +15,15 @@
/*
** Prototypes.
*/
-static Word copy_arg(maybeconst Word *data_ptr, const Word *type_info,
+static Word copy_arg(maybeconst Word *data_ptr,
+ maybeconst Word *parent_data_ptr,
+ const Word *functor_descriptor, const Word *type_info,
const Word *arg_type_info, const Word *lower_limit,
const Word *upper_limit);
static Word *copy_type_info(maybeconst Word *type_info,
const Word *lower_limit, const Word *upper_limit);
+static Word copy_typeclass_info(maybeconst Word *typeclass_info_ptr,
+ const Word *lower_limit, const Word *upper_limit);
Word
copy(maybeconst Word *data_ptr, const Word *type_info,
@@ -61,9 +65,11 @@
case MR_DISCUNIONTAG_SHARED_REMOTE: {
Word secondary_tag;
- Word *new_entry;
+ Word *functor_descriptor;
Word *argument_vector, *type_info_vector;
int arity, i;
+ int num_extra_args, num_extra_typeinfos,
+ num_extra_typeclassinfos;
/*
** if the vector containing the secondary tags and the
@@ -73,24 +79,47 @@
secondary_tag = *data_value;
argument_vector = data_value + 1;
- new_entry = MR_TYPE_CTOR_LAYOUT_SHARED_REMOTE_VECTOR_GET_FUNCTOR_DESCRIPTOR(
+ functor_descriptor = MR_TYPE_CTOR_LAYOUT_SHARED_REMOTE_VECTOR_GET_FUNCTOR_DESCRIPTOR(
entry_value, secondary_tag);
- arity = new_entry[TYPE_CTOR_LAYOUT_UNSHARED_ARITY_OFFSET];
- type_info_vector = new_entry +
+ arity = functor_descriptor[TYPE_CTOR_LAYOUT_UNSHARED_ARITY_OFFSET];
+ type_info_vector = functor_descriptor +
TYPE_CTOR_LAYOUT_UNSHARED_ARGS_OFFSET;
+ num_extra_typeinfos = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_TYPEINFO_VARCOUNT(functor_descriptor);
+
+ num_extra_typeclassinfos = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_TYPECLASSINFO_VARCOUNT(functor_descriptor);
+
+ num_extra_args = num_extra_typeinfos +
+ num_extra_typeclassinfos;
+
/* allocate space for new args, and secondary tag */
- incr_saved_hp(new_data, arity + 1);
+ incr_saved_hp(new_data, arity + num_extra_args + 1);
/* copy secondary tag */
MR_field(0, new_data, 0) = secondary_tag;
+ /* copy typeinfo arguments */
+ for (i = 0; i < num_extra_typeinfos; i++) {
+ MR_field(0, new_data, i + 1) = (Word)copy_type_info(
+ &argument_vector[i],
+ lower_limit, upper_limit);
+ }
+
+ /* copy typeclassinfo arguments */
+ for (i = num_extra_typeinfos;
+ i < num_extra_args; i++) {
+ MR_field(0, new_data, i + 1) = copy_typeclass_info(
+ &argument_vector[i], lower_limit, upper_limit);
+ }
+
/* copy arguments */
for (i = 0; i < arity; i++) {
- MR_field(0, new_data, i + 1) = copy_arg(
- &argument_vector[i], type_info,
- (Word *) type_info_vector[i], lower_limit,
- upper_limit);
+ MR_field(0, new_data, i + num_extra_args+ 1)
+ = copy_arg(data_value,
+ &argument_vector[i + num_extra_args],
+ functor_descriptor, type_info,
+ (Word *) type_info_vector[i], lower_limit,
+ upper_limit);
}
/* tag this pointer */
@@ -105,24 +134,53 @@
case MR_DISCUNIONTAG_UNSHARED: {
int arity, i;
+ int num_extra_args, num_extra_typeinfos,
+ num_extra_typeclassinfos;
Word *argument_vector, *type_info_vector;
+ Word *functor_descriptor;
argument_vector = data_value;
/* If the argument vector is in range, copy the arguments */
if (in_range(argument_vector)) {
+
+ functor_descriptor = entry_value;
+
arity = entry_value[TYPE_CTOR_LAYOUT_UNSHARED_ARITY_OFFSET];
+
type_info_vector = entry_value +
TYPE_CTOR_LAYOUT_UNSHARED_ARGS_OFFSET;
+ num_extra_typeinfos = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_TYPEINFO_VARCOUNT(functor_descriptor);
+
+ num_extra_typeclassinfos = MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_TYPECLASSINFO_VARCOUNT(functor_descriptor);
+ num_extra_args = num_extra_typeinfos +
+ num_extra_typeclassinfos;
+
/* allocate space for new args. */
- incr_saved_hp(new_data, arity);
+ incr_saved_hp(new_data, arity + num_extra_args);
+
+ /* copy typeinfo arguments */
+ for (i = 0; i < num_extra_typeinfos; i++) {
+ MR_field(0, new_data, i) = (Word)copy_type_info(
+ &argument_vector[i],
+ lower_limit, upper_limit);
+ }
+
+ /* copy typeclassinfo arguments */
+ for (i = num_extra_typeinfos;
+ i < num_extra_args; i++) {
+ MR_field(0, new_data, i) = copy_typeclass_info(
+ &argument_vector[i], lower_limit, upper_limit);
+ }
/* copy arguments */
for (i = 0; i < arity; i++) {
- MR_field(0, new_data, i) = copy_arg(
- &argument_vector[i],
- type_info, (Word *) type_info_vector[i],
- lower_limit, upper_limit);
+ MR_field(0, new_data, i + num_extra_args)
+ = copy_arg(data_value,
+ &argument_vector[i + num_extra_args],
+ entry_value,
+ type_info, (Word *) type_info_vector[i],
+ lower_limit, upper_limit);
}
/* tag this pointer */
new_data = (Word) MR_mkword(data_tag, new_data);
@@ -137,19 +195,20 @@
break;
case MR_TYPECTOR_REP_NOTAG:
case MR_TYPECTOR_REP_NOTAG_USEREQ:
- new_data = copy_arg(data_ptr, type_info,
+ new_data = copy_arg(NULL, data_ptr, NULL, type_info,
(Word *) *MR_TYPE_CTOR_LAYOUT_NO_TAG_VECTOR_ARGS(
entry_value), lower_limit, upper_limit);
break;
case MR_TYPECTOR_REP_EQUIV:
- new_data = copy_arg(data_ptr, type_info,
+ new_data = copy_arg(NULL, data_ptr, type_info, NULL,
(const Word *) MR_TYPE_CTOR_LAYOUT_EQUIV_TYPE((Word *)
entry_value), lower_limit, upper_limit);
break;
case MR_TYPECTOR_REP_EQUIV_VAR:
- new_data = copy(data_ptr, (Word *) type_info[(Word) entry_value],
+ new_data = copy(data_ptr,
+ (Word *) type_info[(Word) entry_value],
lower_limit, upper_limit);
break;
@@ -218,8 +277,9 @@
Word *arg_pseudo_type_info =
(Word *) closure_layout->arg_pseudo_type_info[i];
new_closure->MR_closure_hidden_args_0[i] =
- copy_arg(
+ copy_arg(NULL,
&old_closure->MR_closure_hidden_args_0[i],
+ NULL,
type_info + TYPEINFO_OFFSET_FOR_PRED_ARGS - 1,
arg_pseudo_type_info,
lower_limit, upper_limit
@@ -281,8 +341,8 @@
new_array = MR_make_array(array_size);
new_array->size = array_size;
for (i = 0; i < array_size; i++) {
- new_array->elements[i] = copy_arg(
- &old_array->elements[i], type_info,
+ new_array->elements[i] = copy_arg(NULL,
+ &old_array->elements[i], NULL, type_info,
(const Word *) 1, lower_limit, upper_limit);
}
new_data = (Word) new_array;
@@ -352,9 +412,15 @@
** 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.
+**
+** It also takes a pointer to the data of the parent of this piece of data
+** and a functor descriptor for the parent in case the data being copied is
+** existentially quantified.
*/
static Word
-copy_arg(maybeconst Word *data_ptr, const Word *term_type_info,
+copy_arg(maybeconst Word *parent_data_ptr, maybeconst Word *data_ptr,
+ const Word *functor_descriptor,
+ const Word *term_type_info,
const Word *arg_pseudo_type_info, const Word *lower_limit,
const Word *upper_limit)
{
@@ -363,8 +429,10 @@
Word new_data;
allocated_memory_cells = NULL;
- new_type_info = MR_make_type_info(term_type_info, arg_pseudo_type_info,
- &allocated_memory_cells);
+ new_type_info = MR_make_type_info_maybe_existq(term_type_info,
+ arg_pseudo_type_info, parent_data_ptr,
+ functor_descriptor, &allocated_memory_cells);
+
new_data = copy(data_ptr, new_type_info, lower_limit, upper_limit);
MR_deallocate(allocated_memory_cells);
@@ -422,3 +490,51 @@
return type_info;
}
}
+
+static Word
+copy_typeclass_info(maybeconst Word *typeclass_info_ptr,
+ const Word *lower_limit, const Word *upper_limit)
+{
+ Word *typeclass_info = (Word *) *typeclass_info_ptr;
+
+ if (in_range(typeclass_info)) {
+ Word *base_typeclass_info;
+ Word *new_typeclass_info;
+ Integer arity, num_super, num_arg_typeinfos, offset, i;
+
+ /*
+ ** Note that we assume base_typeclass_infos will always be
+ ** allocated statically, so we never copy them.
+ */
+
+ base_typeclass_info = (Word *)*typeclass_info;
+
+ arity = MR_typeclass_info_instance_arity(typeclass_info);
+ num_super = MR_typeclass_info_num_superclasses(typeclass_info);
+ num_arg_typeinfos = MR_typeclass_info_num_type_infos(typeclass_info);
+ incr_saved_hp(LVALUE_CAST(Word, new_typeclass_info),
+ arity + num_super + num_arg_typeinfos + 1);
+
+ new_typeclass_info[0] = (Word) base_typeclass_info;
+
+ /* First, copy all the typeclass infos */
+ for (i = 1; i < arity + num_super + 1; i++) {
+ new_typeclass_info[i] = (Word) copy_typeclass_info(&typeclass_info[i],
+ lower_limit, upper_limit);
+ }
+ /* Then, copy all the type infos */
+ for (i = arity + num_super + 1;
+ i < arity + num_super + num_arg_typeinfos + 1;
+ i++) {
+ new_typeclass_info[i] = (Word) copy_type_info(&typeclass_info[i],
+ lower_limit, upper_limit);
+ }
+ leave_forwarding_pointer(typeclass_info_ptr,
+ (Word) new_typeclass_info);
+ return (Word)new_typeclass_info;
+ } else {
+ found_forwarding_pointer(typeclass_info);
+ return (Word)typeclass_info;
+ }
+}
+
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.25
diff -u -t -r1.25 mercury_type_info.c
--- mercury_type_info.c 1999/10/28 06:23:00 1.25
+++ mercury_type_info.c 1999/12/07 02:56:34
@@ -154,10 +154,27 @@
** which does much the same thing, only allocating using MR_GC_malloc()
** instead of on the Mercury heap.
*/
-
Word *
MR_create_type_info(Word *term_type_info, Word *arg_pseudo_type_info)
{
+ return MR_create_type_info_maybe_existq(term_type_info,
+ arg_pseudo_type_info, NULL, NULL);
+}
+
+ /*
+ ** MR_create_type_info_maybe_existq():
+ **
+ ** The same as MR_create_type_info except that the type-info being
+ ** created may be for an existentially typed argument of a constructor.
+ ** In order to handle this, it also takes the data value from which
+ ** the values whose pseudo type-info we are looking at was taken, as
+ ** well as the functor descriptor for that functor.
+ */
+Word *
+MR_create_type_info_maybe_existq(Word *term_type_info,
+ Word *arg_pseudo_type_info, Word *data_value,
+ Word *functor_descriptor)
+{
int i, arity, extra_args;
MR_TypeCtorInfo type_ctor_info;
Word *arg_type_info;
@@ -168,9 +185,10 @@
** If so, then substitute it's value, and then we're done.
*/
if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
- arg_type_info = (Word *)
- term_type_info[(Word) arg_pseudo_type_info];
+ arg_type_info = MR_get_arg_type_info(term_type_info,
+ arg_pseudo_type_info, data_value, functor_descriptor);
+
if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
fatal_error("MR_create_type_info: "
"unbound type variable");
@@ -202,10 +220,11 @@
*/
type_info = NULL;
for (i = extra_args; i < arity + extra_args; i++) {
- arg_type_info = MR_create_type_info(term_type_info,
- (Word *) arg_pseudo_type_info[i]);
+ arg_type_info = MR_create_type_info_maybe_existq(term_type_info,
+ (Word *) arg_pseudo_type_info[i],
+ data_value, functor_descriptor);
if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
- fatal_error("MR_create_type_info: "
+ fatal_error("MR_create_type_info_maybe_existq: "
"unbound type variable");
}
if (arg_type_info != (Word *) arg_pseudo_type_info[i]) {
@@ -230,6 +249,63 @@
}
}
+Word *
+MR_get_arg_type_info(Word *term_type_info,
+ Word *arg_pseudo_type_info, Word *data_value,
+ Word *functor_descriptor)
+{
+ Word *arg_type_info;
+
+ int num_univ_type_infos;
+
+ num_univ_type_infos =
+ MR_TYPEINFO_GET_TYPE_CTOR_INFO(term_type_info)->arity;
+
+ if ((Word)arg_pseudo_type_info <= num_univ_type_infos) {
+
+ /* This is a universally quantified type variable */
+
+ arg_type_info = (Word *)
+ term_type_info[(Word) arg_pseudo_type_info];
+ }
+ else {
+
+ /* This is an existentially quantified type variable */
+
+ Word type_info_locn;
+
+ type_info_locn =
+ ((Word *)MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_TYPE_INFO_LOCNS(functor_descriptor))[(Integer)arg_pseudo_type_info - num_univ_type_infos - 1];
+
+ if (MR_TYPE_INFO_LOCN_IS_INDIRECT(type_info_locn)) {
+
+ /* This is indirect; the type-info
+ ** is inside a typeclass-info
+ */
+
+ int typeinfo_number;
+ int arg_number;
+
+ typeinfo_number = MR_TYPE_INFO_LOCN_INDIRECT_GET_TYPEINFO_NUMBER(type_info_locn);
+
+ arg_number = MR_TYPE_INFO_LOCN_INDIRECT_GET_ARG_NUMBER(type_info_locn);
+
+ arg_type_info =
+ MR_typeclass_info_type_info(
+ data_value[arg_number],
+ typeinfo_number);
+ }
+ else {
+ /* This is direct */
+
+ arg_type_info =
+ (Word *)data_value[MR_TYPE_INFO_LOCN_DIRECT_GET_TYPEINFO_NUMBER(type_info_locn)];
+ }
+ }
+
+ return arg_type_info;
+}
+
/*
** MR_compare_type_info(type_info_1, type_info_2):
**
@@ -370,6 +446,8 @@
/* Look past equivalences */
while (MR_TYPE_CTOR_FUNCTORS_INDICATOR(functors) == MR_TYPE_CTOR_FUNCTORS_EQUIV) {
equiv_type_info = (Word) MR_TYPE_CTOR_FUNCTORS_EQUIV_TYPE(functors);
+ /* Maybe we need to thread the value */
+ /* down as well... */
equiv_type_info = (Word) MR_create_type_info(
(Word *) maybe_equiv_type_info,
(Word *) equiv_type_info);
@@ -434,6 +512,22 @@
MR_make_type_info(const Word *term_type_info, const Word *arg_pseudo_type_info,
MR_MemoryList *allocated)
{
+ return MR_make_type_info_maybe_existq(term_type_info,
+ arg_pseudo_type_info, NULL, NULL, allocated);
+}
+
+ /*
+ ** The same as MR_make_type_info except that the type-info being
+ ** created may be for an existentially typed argument of a constructor.
+ ** In order to handle this, it also takes the data value from which
+ ** the values whose pseudo type-info we are looking at was taken, as
+ ** well as the functor descriptor for that functor.
+ */
+Word *
+MR_make_type_info_maybe_existq(const Word *term_type_info,
+ const Word *arg_pseudo_type_info, Word *data_value,
+ Word *functor_descriptor, MR_MemoryList *allocated)
+{
int i, arity, extra_args;
MR_TypeCtorInfo type_ctor_info;
Word *arg_type_info;
@@ -444,8 +538,10 @@
** If so, then substitute its value, and then we're done.
*/
if (TYPEINFO_IS_VARIABLE(arg_pseudo_type_info)) {
- arg_type_info = (Word *)
- term_type_info[(Word) arg_pseudo_type_info];
+
+ arg_type_info = MR_get_arg_type_info(term_type_info,
+ arg_pseudo_type_info, data_value, functor_descriptor);
+
if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
fatal_error("make_type_info: "
"unbound type variable");
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/staff/zs/imp/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.30
diff -u -t -r1.30 mercury_type_info.h
--- mercury_type_info.h 1999/10/28 06:23:01 1.30
+++ mercury_type_info.h 1999/12/06 06:21:41
@@ -632,6 +632,9 @@
** ...
** ConstString functorname;
** Word tagbits;
+** Integer num_extra_args; for exist quant args
+** Word locn1; type info locations
+** ...
*/
} MR_TypeLayout_FunctorDescriptor;
@@ -643,6 +646,12 @@
((Integer) 1)
#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_FUNCTOR_TAG \
((Integer) 2)
+#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_EXIST_TYPEINFO_VARCOUNT \
+ ((Integer) 3)
+#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_EXIST_TYPECLASSINFO_VARCOUNT \
+ ((Integer) 4)
+#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_TYPE_INFO_LOCNS \
+ ((Integer) 5)
#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(V) \
((V)[MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_ARITY])
@@ -658,6 +667,31 @@
((Word) ((V)[MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(V) + \
MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_FUNCTOR_TAG]))
+#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_TYPEINFO_VARCOUNT(V) \
+ ((Word) ((V)[MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(V) + \
+ MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_EXIST_TYPEINFO_VARCOUNT]))
+
+#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_TYPECLASSINFO_VARCOUNT(V) \
+ ((Word) ((V)[MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(V) + \
+ MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_EXIST_TYPECLASSINFO_VARCOUNT]))
+
+#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_VARCOUNT(V) \
+ MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_TYPEINFO_VARCOUNT(V) + MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_EXIST_TYPECLASSINFO_VARCOUNT(V)
+
+#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_TYPE_INFO_LOCNS(V) \
+ (((Word *)V) + \
+ MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY((Word *)V) + \
+ MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_TYPE_INFO_LOCNS)
+
+ /*
+ ** Macros for handling type info locations
+ */
+#define MR_TYPE_INFO_LOCN_IS_INDIRECT(t) ((t) & (Unsigned) 1)
+#define MR_TYPE_INFO_LOCN_INDIRECT_GET_TYPEINFO_NUMBER(t) (int) ((t) >> 7)
+#define MR_TYPE_INFO_LOCN_INDIRECT_GET_ARG_NUMBER(t) \
+ (int) (((t) >> 1) & (Unsigned) 63)
+#define MR_TYPE_INFO_LOCN_DIRECT_GET_TYPEINFO_NUMBER(t) (int) ((t) >> 1)
+
/*
** Macros for dealing with shared remote vectors.
*/
@@ -742,8 +776,12 @@
#define MR_typeclass_info_instance_arity(tci) \
((Integer)(*(Word **)(tci))[0])
+#define MR_typeclass_info_num_superclasses(tci) \
+ ((Integer)(*(Word **)(tci))[1])
+#define MR_typeclass_info_num_type_infos(tci) \
+ ((Integer)(*(Word **)(tci))[2])
#define MR_typeclass_info_class_method(tci, n) \
- ((Code *)(*(Word **)tci)[(n)])
+ ((Code *)(*(Word **)tci)[(n+2)])
#define MR_typeclass_info_arg_typeclass_info(tci, n) \
(((Word *)(tci))[(n)])
@@ -760,6 +798,8 @@
/*---------------------------------------------------------------------------*/
Word * MR_create_type_info(Word *, Word *);
+Word * MR_create_type_info_maybe_existq(Word *, Word *, Word *, Word *);
+Word * MR_get_arg_type_info(Word *, Word *, Word *, Word *);
int MR_compare_type_info(Word, Word);
Word MR_collapse_equivalences(Word);
@@ -777,6 +817,9 @@
Word * MR_make_type_info(const Word *term_type_info,
const Word *arg_pseudo_type_info, MR_MemoryList *allocated);
+Word * MR_make_type_info_maybe_existq(const Word *term_type_info,
+ const Word *arg_pseudo_type_info, Word *data_value,
+ Word *functor_descriptor, MR_MemoryList *allocated) ;
void MR_deallocate(MR_MemoryList allocated_memory_cells);
/*---------------------------------------------------------------------------*/
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing scripts
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing trial
cvs diff: Diffing util
==========================================================================
Here is the revised test case. Are there any other cases I should cover? This
is pretty good, but I suspect there are a few others.
==========================================================================
% Test cases for rtti for existential types.
:- module existential_rtti.
:- interface.
:- typeclass c(T) where [].
:- instance c(int) where [].
:- typeclass c2(T1, T2) where [].
:- instance c2(int, string) where [].
:- typeclass c3(T1, T2) where [].
:- instance c3(int, float) where [].
:- type f(X) ---> some [T] f(int, T, list(X), int).
:- type myf ---> some [T] myf(T) => c(T).
:- type f
---> some [T] f(int, T, int)
; some [X] g(float, X, float)
.
:- type g
---> some [T] g(T).
:- type g2 ---> g2(int).
:- type foo ---> foo(string, string).
:- type goo ---> goo ; hoo.
:- type u(X) ---> u(X).
:- type f2(X, Y) ---> some [T1, T2] f2(int, T1, u(X), T2, u(Y), int).
:- type multi ---> some [T1, T2] multi(T1, T2) => c2(T1, T2).
:- type multi2 ---> some [T1,T2,T3] multi2(T1, T2, T3)
=> (c2(T1, T2), c3(T1, T3)).
:- import_module io.
:- pred main(io__state::di, io__state::uo) is det.
:- implementation.
:- import_module list, std_util.
main -->
{ A = 'new myf'(1) },
{ copy(A, ACopy) },
% different types inside
{ B = 'new f'(1, "hello", 42) },
{ copy(B, BCopy) },
{ C = 'new f'(2, 'w', 42) },
{ copy(C, CCopy) },
% an enum
{ D = 'new f'(3, goo, 42) },
{ copy(D, DCopy) },
% existential inside an existential
{ E = 'new f'(4, 'new g'("hello"), 42) },
{ copy(E, ECopy) },
% A no-tag inside
{ F = 'new f'(5, g2(12), 42) },
{ copy(F, FCopy) },
{ G = 'new f'(6, foo("hello", "world"), 42) },
{ copy(G, GCopy) },
{ H = 'new g'(7.0, 'new g'("hello"), 42.0) },
{ copy(H, HCopy) },
% universally quantified argument.
{ I = 'new f'(8, u("hello"), 42) },
{ copy(I, ICopy) },
% multiple existentially and universally quantified arguments
{ J = 'new f2'(9, "hello", u("hello"), 432.1, u("world"), 42) },
{ copy(J, JCopy) },
% multi parameter type class
{ K = 'new multi'(10, "multiparameter") },
{ copy(K, KCopy) },
% multi parameter type class, multiple constraints
{ L = 'new multi2'(11, "multiparameter", 42.0) },
{ copy(L, LCopy) },
io__write_string("Writing some terms: \n"),
io__write(A),
io__nl,
io__write(B),
io__nl,
io__write(C),
io__nl,
io__write(D),
io__nl,
io__write(E),
io__nl,
io__write(F),
io__nl,
io__write(G),
io__nl,
io__write(H),
io__nl,
io__write(I),
io__nl,
io__write(J),
io__nl,
io__write(K),
io__nl,
io__write(L),
io__nl,
io__write_string("Writing copies of terms: \n"),
io__write(ACopy),
io__nl,
io__write(BCopy),
io__nl,
io__write(CCopy),
io__nl,
io__write(DCopy),
io__nl,
io__write(ECopy),
io__nl,
io__write(FCopy),
io__nl,
io__write(GCopy),
io__nl,
io__write(HCopy),
io__nl,
io__write(ICopy),
io__nl,
io__write(JCopy),
io__nl,
io__write(KCopy),
io__nl,
io__write(LCopy),
io__nl,
io__write_string("Writing a deconstructed term: \n"),
{ deconstruct(I, _Functor, _Arity, IArgs) },
io__write_list(IArgs, ", ", io__write),
io__nl,
io__nl.
==========================================================================
dgj
--
David Jeffery (dgj at cs.mu.oz.au) | If your thesis is utterly vacuous
PhD student, | Use first-order predicate calculus.
Dept. of Comp. Sci. & Soft. Eng.| With sufficient formality
The University of Melbourne | The sheerist banality
Australia | Will be hailed by the critics: "Miraculous!"
| -- Anon.
--------------------------------------------------------------------------
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