[m-dev.] for review: RTTI for existential types
David Glen JEFFERY
dgj at cs.mu.OZ.AU
Wed Nov 24 16:57:59 AEDT 1999
Estimated hours taken: 120
Implement RTTI for functors with existentially typed arguments.
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/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.
compiler/mercury_type_info.h:
Change some prototypes and add macros to access the new information in
the functor descriptor.
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/11/24 04:54:41
@@ -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,142 @@
),
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, NumExtraArgs, 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],
- EndRvals).
+ EndRvals0),
+ list__append(EndRvals0, [yes(const(int_const(NumExtraArgs)))|ExistQVarLocns], EndRvals).
+
+:- pred base_type_layout__generate_type_info_locns(list(tvar),
+ list(class_constraint), map(tvar, rval), int, layout_info).
+:- mode base_type_layout__generate_type_info_locns(in, in, out, out, in) is det.
+
+base_type_layout__generate_type_info_locns(Tvars, Constraints, Locns,
+ NumExtraArgs, 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),
+ NumExtraArgs = NumConstraints + NUnconstrained.
+
+:- 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 +1146,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 +1251,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 +1321,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 +1336,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
+ ;
+ throw("base_type_layout: var not in list"-Var-NumUnivQTvars-ExistQTvars)
+ )
+ ),
base_type_layout__max_varint(MaxVarInt),
require(VarInt < MaxVarInt,
"type_ctor_layout: type variable representation exceeds limit"),
@@ -1183,6 +1379,8 @@
:- pred base_type_layout__remove_create(rval, maybe(rval)).
:- mode base_type_layout__remove_create(in, out) is det.
+:- import_module exception.
+
base_type_layout__remove_create(Rval0, Rval) :-
(
Rval0 = create(_, [PTI], _, _, _, _)
@@ -1285,57 +1483,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/stack_layout.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/stack_layout.m,v
retrieving revision 1.38
diff -u -t -r1.38 stack_layout.m
--- stack_layout.m 1999/11/15 10:16:50 1.38
+++ stack_layout.m 1999/11/24 04:41:30
@@ -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.173
diff -u -t -r1.173 std_util.m
--- std_util.m 1999/11/16 12:18:19 1.173
+++ std_util.m 1999/11/24 04:55:58
@@ -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)").
@@ -1806,7 +1806,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
@@ -1834,7 +1834,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]);
@@ -2099,6 +2098,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;
@@ -2193,6 +2193,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;
@@ -2206,6 +2207,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;
@@ -2234,6 +2236,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,
@@ -2253,8 +2258,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;
@@ -2272,6 +2280,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,
@@ -2296,8 +2305,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;
@@ -2305,7 +2317,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);
@@ -2314,7 +2327,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;
@@ -2334,6 +2348,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_CHAR:
@@ -2349,6 +2364,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_FLOAT:
@@ -2367,6 +2383,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_STRING:
@@ -2383,6 +2400,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_PRED:
@@ -2392,6 +2410,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_UNIV:
@@ -2418,6 +2437,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_TYPEINFO:
@@ -2428,6 +2448,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_TYPECLASSINFO:
@@ -2438,6 +2459,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_ARRAY:
@@ -2448,6 +2470,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_SUCCIP:
@@ -2457,6 +2480,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_HP:
@@ -2466,6 +2490,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_CURFR:
@@ -2475,6 +2500,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_MAXFR:
@@ -2484,6 +2510,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_REDOFR:
@@ -2493,6 +2520,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_REDOIP:
@@ -2502,6 +2530,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:
@@ -2511,6 +2540,7 @@
info->argument_vector = NULL;
info->type_info_vector = NULL;
info->arity = 0;
+ info->num_extra_args = 0;
break;
case MR_TYPECTOR_REP_TICKET:
@@ -2520,6 +2550,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 */
@@ -2777,7 +2808,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_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/11/24 05:16:15
@@ -154,23 +154,85 @@
** 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);
+}
+
+/* XXX Do I need to change MR_make_type_info too? As far as I can tell,
+ * MR_make_type_info is never called on arguments of constructors, but I don't
+ * know whether that is by design or not... Tyse? Fergus? */
+
+ /*
+ ** 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;
Word *type_info;
+ int num_univ_type_infos;
+
/*
** The arg_pseudo_type_info might be a polymorphic variable.
** 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];
+ 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 (type_info_locn && (Unsigned) 1) {
+
+ /* This is indirect; the type-info is inside a
+ * typeclass-info */
+
+ int typeinfo_number;
+ int arg_number;
+
+ typeinfo_number = type_info_locn >> 7;
+
+ arg_number = (type_info_locn >> 1)
+ & (Unsigned) 63;
+
+ arg_type_info =
+ MR_typeclass_info_type_info(
+ data_value[arg_number],
+ typeinfo_number);
+ }
+ else {
+ /* This is direct */
+
+ arg_type_info =
+ (Word *)data_value[type_info_locn>>1];
+ }
+ }
+
if (TYPEINFO_IS_VARIABLE(arg_type_info)) {
fatal_error("MR_create_type_info: "
"unbound type variable");
@@ -202,10 +264,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]) {
@@ -370,6 +433,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);
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/11/24 05:20:37
@@ -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,10 @@
((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_VARCOUNT \
+ ((Integer) 3)
+#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_TYPE_INFO_LOCNS \
+ ((Integer) 4)
#define MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(V) \
((V)[MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_ARITY])
@@ -658,6 +665,15 @@
((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_VARCOUNT(V) \
+ ((Word) ((V)[MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_ARITY(V) + \
+ MR_TYPE_CTOR_LAYOUT_FUNCTOR_DESCRIPTOR_OFFSET_FOR_EXIST_VARCOUNT]))
+
+#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 dealing with shared remote vectors.
*/
@@ -760,6 +776,7 @@
/*---------------------------------------------------------------------------*/
Word * MR_create_type_info(Word *, Word *);
+Word * MR_create_type_info_maybe_existq(Word *, Word *, Word *, Word *);
int MR_compare_type_info(Word, Word);
Word MR_collapse_equivalences(Word);
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
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