[m-dev.] diff: --high-level-data: use field names instead of offsets
Fergus Henderson
fjh at cs.mu.OZ.AU
Tue Jun 6 00:51:54 AEST 2000
Tyson, you will want to at least review the changes to compiler/mlds.m
in this diff.
----------
Estimated hours taken: 8
For --high-level-data, use field names rather than offsets
when accessing fields.
compiler/hlds_data.m:
Include the field names in the hlds_cons_defn,
for use by ml_unify_gen.m.
compiler/make_hlds.m:
compiler/typecheck.m:
compiler/post_typecheck.m:
compiler/type_util.m:
Minor changes to handle the change to hlds_cons_defn.
compiler/ml_type_gen.m:
For fields of certain types, such as `float', etc.,
generate the field type as a boxed type (mlds__generic_type).
compiler/ml_unify_gen.m:
For --high-level-data, use field names rather than offsets
when accessing fields.
compiler/ml_code_util.m:
Add two new routines for dealing with fields,
`ml_gen_field_name' and `ml_must_box_field_type',
for use by ml_type_gen.m and ml_unify_gen.m.
compiler/mlds.m:
Change the documentation for the ClassType field in `field'
lvals: rename it as `PtrType', and make it clear that this is
the type of the pointer, not the type of the class pointed to.
Also add a new CtorType field to the `named_field' field_id.
compiler/ml_elim_nested.m:
Minor changes to handle the modifications to mlds.m.
compiler/mlds_to_c.m:
Ensure that we name-mangle struct names and field names.
For named_field field accesses, cast the pointer to the type
specified by the new CtorType field before dereferencing it.
Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.45
diff -u -d -r1.45 hlds_data.m
--- compiler/hlds_data.m 2000/03/10 13:37:41 1.45
+++ compiler/hlds_data.m 2000/06/05 06:14:09
@@ -62,8 +62,9 @@
% you can get the tvarset from the hlds__type_defn.
existq_tvars, % existential type vars
list(class_constraint), % existential class constraints
- list(type), % The types of the arguments
- % of this functor (if any)
+ list(constructor_arg), % The field names and types of
+ % the arguments of this functor
+ % (if any)
type_id, % The result type, i.e. the
% type to which this
% cons_defn belongs.
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.335
diff -u -d -r1.335 make_hlds.m
--- compiler/make_hlds.m 2000/05/13 13:56:11 1.335
+++ compiler/make_hlds.m 2000/06/05 06:24:03
@@ -1935,8 +1935,7 @@
Ctors0, Ctors) -->
{ Ctor = ctor(ExistQVars, Constraints, Name, Args) },
{ make_cons_id(Name, Args, TypeId, QualifiedConsId) },
- { assoc_list__values(Args, Types) },
- { ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Types, TypeId,
+ { ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, TypeId,
Context) },
%
% Insert the fully-qualified version of this cons_id into the
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.16
diff -u -d -r1.16 ml_code_util.m
--- compiler/ml_code_util.m 2000/06/05 00:27:24 1.16
+++ compiler/ml_code_util.m 2000/06/05 08:57:47
@@ -224,6 +224,22 @@
%-----------------------------------------------------------------------------%
%
+% Routines for dealing with fields
+%
+
+ % Given the user-specified field name, if any,
+ % and the argument number (starting from one),
+ % generate an MLDS field name.
+:- func ml_gen_field_name(maybe(ctor_field_name), int) = mlds__field_name.
+
+ % Succeed iff the specified type must be boxed when used as a field.
+ % We need to box types that are not word-sized, because the code
+ % for `arg' etc. in std_util.m rely on all arguments being word-sized.
+:- pred ml_must_box_field_type(prog_type, module_info).
+:- mode ml_must_box_field_type(in, in) is semidet.
+
+%-----------------------------------------------------------------------------%
+%
% Routines for handling success and failure
%
@@ -1098,6 +1114,37 @@
Abstractness = concrete,
MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
Virtuality, Finality, Constness, Abstractness).
+
+%-----------------------------------------------------------------------------%
+%
+% Code for dealing with fields
+%
+
+ % Given the user-specified field name, if any,
+ % and the argument number (starting from one),
+ % generate an MLDS field name.
+ %
+ml_gen_field_name(MaybeFieldName, ArgNum) = FieldName :-
+ %
+ % If the programmer specified a field name, we use that,
+ % otherwise we just use `F' followed by the field number.
+ %
+ (
+ MaybeFieldName = yes(QualifiedFieldName),
+ unqualify_name(QualifiedFieldName, FieldName)
+ ;
+ MaybeFieldName = no,
+ FieldName = string__format("F%d", [i(ArgNum)])
+ ).
+
+ % Succeed iff the specified type must be boxed when used as a field.
+ % We need to box types that are not word-sized, because the code
+ % for `arg' etc. in std_util.m rely on all arguments being word-sized.
+ml_must_box_field_type(Type, ModuleInfo) :-
+ classify_type(Type, ModuleInfo, Category),
+ ( Category = float_type
+ ; Category = char_type
+ ).
%-----------------------------------------------------------------------------%
%
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.26
diff -u -d -r1.26 mlds.m
--- compiler/mlds.m 2000/05/31 06:04:04 1.26
+++ compiler/mlds.m 2000/06/05 13:59:14
@@ -941,9 +941,17 @@
---> % offset(N) represents the field
% at offset N Words.
offset(mlds__rval)
- ; % named_field(Name) represents the field
- % with the specified name.
- named_field(mlds__fully_qualified_name(field_name))
+ ; % named_field(Name, CtorType) represents the field
+ % with the specified name. The CtorType gives the
+ % MLDS type for this particular constructor.
+ % The type of the object is given by the PtrType
+ % in the field(..) lval; CtorType may either be
+ % the same as PtrType, or it may be a pointer to
+ % a derived class. In the latter case, the
+ % MLDS->target code back-end is responsible
+ % for inserting a downcast from PtrType to CtorType
+ % before accessing the field.
+ named_field(mlds__fully_qualified_name(field_name), mlds__type)
.
:- type field_name == string.
@@ -967,7 +975,7 @@
---> field(maybe(mlds__tag), mlds__rval, field_id,
mlds__type, mlds__type)
% field(Tag, Address, FieldName, FieldType,
- % ClassType)
+ % PtrType)
% selects a field of a compound term.
% Address is a tagged pointer to a cell
% on the heap; the offset into the cell
@@ -978,8 +986,8 @@
% it is known, since this will lead to
% faster code.
% The FieldType is the type of the field.
- % The ClassType is the type of the object from
- % which we are fetching the field.
+ % The PtrType is the type of the pointer
+ % from which we are fetching the field.
%
% Note that currently we store all fields
% of objects created with new_object
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.37
diff -u -d -r1.37 mlds_to_c.m
--- compiler/mlds_to_c.m 2000/06/05 02:42:41 1.37
+++ compiler/mlds_to_c.m 2000/06/05 14:49:42
@@ -1157,7 +1157,7 @@
% actual enumeration type as a comment.
%
io__write_string("MR_Integer /* actually `enum "),
- mlds_output_fully_qualified(Name, io__write_string),
+ mlds_output_fully_qualified(Name, mlds_output_mangled_name),
io__format("_%d_e", [i(Arity)]),
io__write_string("' */")
;
@@ -1165,7 +1165,7 @@
% since don't use these types directly, we only
% use pointers to them.
io__write_string("struct "),
- mlds_output_fully_qualified(Name, io__write_string),
+ mlds_output_fully_qualified(Name, mlds_output_mangled_name),
io__format("_%d_s", [i(Arity)])
).
mlds_output_type_prefix(mlds__ptr_type(Type)) -->
@@ -2038,28 +2038,34 @@
io__write_string(", "),
mlds_output_rval(OffsetRval),
io__write_string("))").
-mlds_output_lval(field(MaybeTag, PtrRval, named_field(FieldId), _, _)) -->
+mlds_output_lval(field(MaybeTag, PtrRval, named_field(FieldName, CtorType),
+ _FieldType, _PtrType)) -->
+ % XXX we shouldn't bother with this cast in the case where
+ % PtrType == CtorType
+ io__write_string("(("),
+ mlds_output_type(CtorType),
+ io__write_string(") "),
( { MaybeTag = yes(0) } ->
( { PtrRval = mem_addr(Lval) } ->
- mlds_output_bracketed_lval(Lval),
- io__write_string(".")
+ mlds_output_lval(Lval),
+ io__write_string(").")
;
mlds_output_bracketed_rval(PtrRval),
- io__write_string("->")
+ io__write_string(")->")
)
;
( { MaybeTag = yes(Tag) } ->
io__write_string("MR_body("),
- mlds_output_tag(Tag),
- io__write_string(", ")
+ mlds_output_rval(PtrRval),
+ io__write_string(", "),
+ mlds_output_tag(Tag)
;
- io__write_string("MR_strip_tag(")
+ io__write_string("MR_strip_tag("),
+ mlds_output_rval(PtrRval)
),
- mlds_output_rval(PtrRval),
- io__write_string(")"),
- io__write_string("->")
+ io__write_string("))->")
),
- mlds_output_fully_qualified(FieldId, io__write_string).
+ mlds_output_fully_qualified(FieldName, mlds_output_mangled_name).
mlds_output_lval(mem_ref(Rval, _Type)) -->
io__write_string("*"),
mlds_output_bracketed_rval(Rval).
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.8
diff -u -d -r1.8 ml_elim_nested.m
--- compiler/ml_elim_nested.m 2000/05/31 06:04:11 1.8
+++ compiler/ml_elim_nested.m 2000/06/05 14:00:19
@@ -273,11 +273,12 @@
%
QualVarName = qual(ModuleName, VarName),
EnvModuleName = ml_env_module_name(ClassType),
- FieldName = named_field(qual(EnvModuleName, VarName)),
+ FieldName = named_field(qual(EnvModuleName, VarName),
+ mlds__ptr_type(ClassType)),
Tag = yes(0),
EnvPtr = lval(var(qual(ModuleName, "env_ptr"))),
EnvArgLval = field(Tag, EnvPtr, FieldName, FieldType,
- ClassType),
+ mlds__ptr_type(ClassType)),
ArgRval = lval(var(QualVarName)),
AssignToEnv = assign(EnvArgLval, ArgRval),
CodeToCopyArg = mlds__statement(atomic(AssignToEnv), Context),
@@ -834,8 +835,8 @@
:- pred fixup_lval(mlds__lval, mlds__lval, elim_info, elim_info).
:- mode fixup_lval(in, out, in, out) is det.
-fixup_lval(field(MaybeTag, Rval0, FieldId, FieldType, ClassType),
- field(MaybeTag, Rval, FieldId, FieldType, ClassType)) -->
+fixup_lval(field(MaybeTag, Rval0, FieldId, FieldType, PtrType),
+ field(MaybeTag, Rval, FieldId, FieldType, PtrType)) -->
fixup_rval(Rval0, Rval).
fixup_lval(mem_ref(Rval0, Type), mem_ref(Rval, Type)) -->
fixup_rval(Rval0, Rval).
@@ -874,7 +875,8 @@
->
EnvPtr = lval(var(qual(ModuleName, "env_ptr"))),
EnvModuleName = ml_env_module_name(ClassType),
- FieldName = named_field(qual(EnvModuleName, ThisVarName)),
+ FieldName = named_field(qual(EnvModuleName, ThisVarName),
+ mlds__ptr_type(ClassType)),
Tag = yes(0),
Lval = field(Tag, EnvPtr, FieldName, FieldType, ClassType)
;
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.2
diff -u -d -r1.2 ml_type_gen.m
--- compiler/ml_type_gen.m 2000/06/01 08:57:35 1.2
+++ compiler/ml_type_gen.m 2000/06/05 07:31:27
@@ -39,7 +39,7 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module hlds_pred, prog_data, prog_util.
+:- import_module hlds_pred, prog_data, prog_util, type_util.
:- import_module ml_code_util.
:- import_module globals, options.
@@ -344,15 +344,14 @@
ml_gen_du_ctor_member(ModuleInfo, Context, MaybeFieldName - Type, MLDS_Defn,
ArgNum0, ArgNum) :-
- (
- MaybeFieldName = yes(QualifiedFieldName),
- unqualify_name(QualifiedFieldName, FieldName)
+ FieldName = ml_gen_field_name(MaybeFieldName, ArgNum0),
+ ( ml_must_box_field_type(Type, ModuleInfo) ->
+ MLDS_Type = mlds__generic_type
;
- MaybeFieldName = no,
- FieldName = string__format("F%d", [i(ArgNum0)])
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, Type)
),
- MLDS_Defn = ml_gen_var_decl(FieldName, Type,
- mlds__make_context(Context), ModuleInfo),
+ MLDS_Defn = ml_gen_mlds_var_decl(var(FieldName), MLDS_Type,
+ mlds__make_context(Context)),
ArgNum = ArgNum0 + 1.
%-----------------------------------------------------------------------------%
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.13
diff -u -d -r1.13 ml_unify_gen.m
--- compiler/ml_unify_gen.m 2000/05/31 12:58:14 1.13
+++ compiler/ml_unify_gen.m 2000/06/05 08:57:16
@@ -75,7 +75,7 @@
:- implementation.
:- import_module hlds_module, hlds_out, builtin_ops.
-:- import_module ml_call_gen, prog_util, type_util, mode_util.
+:- import_module ml_call_gen, ml_type_gen, prog_util, type_util, mode_util.
:- import_module rtti.
:- import_module code_util. % XXX needed for `code_util__cons_id_to_tag'.
:- import_module globals, options.
@@ -1153,16 +1153,16 @@
{ Tag = unshared_tag(UnsharedTag) },
ml_gen_var(Var, VarLval),
ml_variable_types(Args, ArgTypes),
- ml_field_types(Type, ConsId, ArgTypes, FieldTypes),
- ml_gen_unify_args(Args, Modes, ArgTypes, FieldTypes, Type,
- VarLval, 0, UnsharedTag, Context, MLDS_Statements)
+ ml_field_names_and_types(Type, ConsId, ArgTypes, Fields),
+ ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, Type,
+ VarLval, 0, 1, UnsharedTag, Context, MLDS_Statements)
;
{ Tag = shared_remote_tag(PrimaryTag, _SecondaryTag) },
ml_gen_var(Var, VarLval),
ml_variable_types(Args, ArgTypes),
- ml_field_types(Type, ConsId, ArgTypes, FieldTypes),
- ml_gen_unify_args(Args, Modes, ArgTypes, FieldTypes, Type,
- VarLval, 1, PrimaryTag, Context, MLDS_Statements)
+ ml_field_names_and_types(Type, ConsId, ArgTypes, Fields),
+ ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, Type,
+ VarLval, 1, 1, PrimaryTag, Context, MLDS_Statements)
;
{ Tag = shared_local_tag(_Bits1, _Num1) },
{ MLDS_Statements = [] } % if this is det, then nothing happens
@@ -1176,11 +1176,11 @@
% the types of the actual arguments can be an instance of the
% field types.
%
-:- pred ml_field_types(prog_type, cons_id, list(prog_type), list(prog_type),
- ml_gen_info, ml_gen_info).
-:- mode ml_field_types(in, in, in, out, in, out) is det.
+:- pred ml_field_names_and_types(prog_type, cons_id, list(prog_type),
+ list(constructor_arg), ml_gen_info, ml_gen_info).
+:- mode ml_field_names_and_types(in, in, in, out, in, out) is det.
-ml_field_types(Type, ConsId, ArgTypes, FieldTypes) -->
+ml_field_names_and_types(Type, ConsId, ArgTypes, Fields) -->
%
% Lookup the field types for the arguments of this cons_id
%
@@ -1188,29 +1188,32 @@
{ ml_gen_info_get_module_info(Info, ModuleInfo) },
{ type_util__get_type_and_cons_defn(ModuleInfo, Type, ConsId,
_TypeDefn, ConsDefn) },
- { ConsDefn = hlds_cons_defn(_, _, FieldTypes0, _, _) },
+ { ConsDefn = hlds_cons_defn(_, _, Fields0, _, _) },
%
- % Add the types for any type_infos and/or typeclass_infos
+ % Add the fields for any type_infos and/or typeclass_infos
% inserted for existentially quantified data types.
% For these, we just copy the types from the ArgTypes.
%
{ NumArgs = list__length(ArgTypes) },
- { NumFieldTypes0 = list__length(FieldTypes0) },
+ { NumFieldTypes0 = list__length(Fields0) },
{ NumExtraTypes = NumArgs - NumFieldTypes0 },
{ ExtraFieldTypes = list__take_upto(NumExtraTypes, ArgTypes) },
- { FieldTypes = list__append(ExtraFieldTypes, FieldTypes0) }.
+ { ExtraFields = list__map(func(FieldType) = no - FieldType,
+ ExtraFieldTypes) },
+ { Fields = list__append(ExtraFields, Fields0) }.
-:- pred ml_gen_unify_args(prog_vars, list(uni_mode), list(prog_type),
- list(prog_type), prog_type, mlds__lval, int, mlds__tag,
- prog_context, mlds__statements, ml_gen_info, ml_gen_info).
-:- mode ml_gen_unify_args(in, in, in, in, in, in, in, in, in, out, in, out)
- is det.
+:- pred ml_gen_unify_args(cons_id, prog_vars, list(uni_mode), list(prog_type),
+ list(constructor_arg), prog_type, mlds__lval, int, int,
+ mlds__tag, prog_context, mlds__statements,
+ ml_gen_info, ml_gen_info).
+:- mode ml_gen_unify_args(in, in, in, in, in, in, in, in, in, in, in, out,
+ in, out) is det.
-ml_gen_unify_args(Args, Modes, ArgTypes, FieldTypes, VarType, VarLval, ArgNum,
- PrimaryTag, Context, MLDS_Statements) -->
+ml_gen_unify_args(ConsId, Args, Modes, ArgTypes, Fields, VarType, VarLval,
+ Offset, ArgNum, PrimaryTag, Context, MLDS_Statements) -->
(
- ml_gen_unify_args_2(Args, Modes, ArgTypes, FieldTypes, VarType,
- VarLval, ArgNum, PrimaryTag, Context,
+ ml_gen_unify_args_2(ConsId, Args, Modes, ArgTypes, Fields,
+ VarType, VarLval, Offset, ArgNum, PrimaryTag, Context,
[], MLDS_Statements0)
->
{ MLDS_Statements = MLDS_Statements0 }
@@ -1218,55 +1221,113 @@
{ error("ml_gen_unify_args: length mismatch") }
).
-:- pred ml_gen_unify_args_2(prog_vars, list(uni_mode), list(prog_type),
- list(prog_type), prog_type, mlds__lval, int, mlds__tag,
- prog_context, mlds__statements, mlds__statements,
+:- pred ml_gen_unify_args_2(cons_id, prog_vars, list(uni_mode), list(prog_type),
+ list(constructor_arg), prog_type, mlds__lval, int, int,
+ mlds__tag, prog_context, mlds__statements, mlds__statements,
ml_gen_info, ml_gen_info).
-:- mode ml_gen_unify_args_2(in, in, in, in, in, in, in, in, in, in, out,
+:- mode ml_gen_unify_args_2(in, in, in, in, in, in, in, in, in, in, in, in, out,
in, out) is semidet.
-ml_gen_unify_args_2([], [], [], _, _, _, _, _, _, Statements, Statements) -->
- [].
-ml_gen_unify_args_2([Arg|Args], [Mode|Modes], [ArgType|ArgTypes],
- [FieldType|FieldTypes], VarType, VarLval, ArgNum, PrimaryTag,
+ml_gen_unify_args_2(_, [], [], [], _, _, _, _, _, _, _, Statements, Statements)
+ --> [].
+ml_gen_unify_args_2(ConsId, [Arg|Args], [Mode|Modes], [ArgType|ArgTypes],
+ [Field|Fields], VarType, VarLval, Offset, ArgNum, PrimaryTag,
Context, MLDS_Statements0, MLDS_Statements) -->
+ { Offset1 = Offset + 1 },
{ ArgNum1 = ArgNum + 1 },
- ml_gen_unify_args_2(Args, Modes, ArgTypes, FieldTypes, VarType,
- VarLval, ArgNum1, PrimaryTag, Context,
+ ml_gen_unify_args_2(ConsId, Args, Modes, ArgTypes, Fields, VarType,
+ VarLval, Offset1, ArgNum1, PrimaryTag, Context,
MLDS_Statements0, MLDS_Statements1),
- ml_gen_unify_arg(Arg, Mode, ArgType, FieldType, VarType, VarLval,
- ArgNum, PrimaryTag, Context,
+ ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
+ Offset, ArgNum, PrimaryTag, Context,
MLDS_Statements1, MLDS_Statements).
-:- pred ml_gen_unify_arg(prog_var, uni_mode, prog_type, prog_type, prog_type,
- mlds__lval, int, mlds__tag, prog_context,
- mlds__statements, mlds__statements, ml_gen_info, ml_gen_info).
-:- mode ml_gen_unify_arg(in, in, in, in, in, in, in, in, in, in, out, in, out)
- is det.
+:- pred ml_gen_unify_arg(cons_id, prog_var, uni_mode, prog_type,
+ constructor_arg, prog_type, mlds__lval, int, int, mlds__tag,
+ prog_context, mlds__statements, mlds__statements,
+ ml_gen_info, ml_gen_info).
+:- mode ml_gen_unify_arg(in, in, in, in, in, in, in, in, in, in, in, in, out,
+ in, out) is det.
-ml_gen_unify_arg(Arg, Mode, ArgType, _FieldType, VarType, VarLval, ArgNum,
- PrimaryTag, Context, MLDS_Statements0, MLDS_Statements) -->
- %
- % With the current low-level data representation,
- % we store all fields as boxed, so we ignore _FieldType
- % and instead generate a polymorphic type BoxedFieldType
- % here. This type is used in the calls to
- % ml_gen_box_or_unbox_rval below to ensure that we
- % box values when storing them into fields and
- % unbox them when extracting them from fields.
- %
- { varset__init(TypeVarSet0) },
- { varset__new_var(TypeVarSet0, TypeVar, _TypeVarSet) },
- { type_util__var(BoxedFieldType, TypeVar) },
+ml_gen_unify_arg(ConsId, Arg, Mode, ArgType, Field, VarType, VarLval,
+ Offset, ArgNum, PrimaryTag, Context,
+ MLDS_Statements0, MLDS_Statements) -->
+ { Field = MaybeFieldName - FieldType },
+ =(Info),
+ { ml_gen_info_get_module_info(Info, ModuleInfo) },
+ { module_info_globals(ModuleInfo, Globals) },
+ { globals__lookup_bool_option(Globals, highlevel_data,
+ HighLevelData) },
+ {
+ %
+ % With the low-level data representation,
+ % we access all fields using offsets.
+ %
+ HighLevelData = no,
+ FieldId = offset(const(int_const(Offset)))
+ ;
+ %
+ % With the high-level data representation,
+ % we always used named fields.
+ %
+ HighLevelData = yes,
+ FieldName = ml_gen_field_name(MaybeFieldName, ArgNum),
+ (
+ ConsId = cons(ConsName, ConsArity),
+ type_to_type_id(VarType, TypeId, _)
+ ->
+ ml_gen_type_name(TypeId,
+ qual(MLDS_Module, TypeName), TypeArity),
+ ConsQualifier = mlds__append_class_qualifier(
+ MLDS_Module, TypeName, TypeArity),
+ unqualify_name(ConsName, UnqualConsName),
+ QualConsName = qual(ConsQualifier, UnqualConsName),
+ ConsType = mlds__ptr_type(mlds__class_type(
+ QualConsName, ConsArity, mlds__class)),
+ FieldQualifier = mlds__append_class_qualifier(
+ ConsQualifier, UnqualConsName, ConsArity),
+ QualifiedFieldName = qual(FieldQualifier, FieldName),
+ FieldId = named_field(QualifiedFieldName, ConsType)
+ ;
+ error("ml_gen_unify_args: invalid cons_id or type")
+ )
+ },
+ {
+ %
+ % With the low-level data representation,
+ % we store all fields as boxed, so we ignore the field
+ % type from `Field' and instead generate a polymorphic
+ % type BoxedFieldType which we use for the type of the field.
+ % This type is used in the calls to
+ % ml_gen_box_or_unbox_rval below to ensure that we
+ % box values when storing them into fields and
+ % unbox them when extracting them from fields.
+ %
+ % With the high-level data representation,
+ % we don't box everything, but we still need
+ % to box floating point fields.
+ %
+ (
+ HighLevelData = no
+ ;
+ HighLevelData = yes,
+ ml_must_box_field_type(FieldType, ModuleInfo)
+ )
+ ->
+ varset__init(TypeVarSet0),
+ varset__new_var(TypeVarSet0, TypeVar, _TypeVarSet),
+ type_util__var(BoxedFieldType, TypeVar)
+ ;
+ BoxedFieldType = FieldType
+ },
- %
- % Generate lvals for the LHS and the RHS
- %
- { FieldId = offset(const(int_const(ArgNum))) },
- ml_gen_type(BoxedFieldType, MLDS_FieldType),
+ %
+ % Generate lvals for the LHS and the RHS
+ %
ml_gen_type(VarType, MLDS_VarType),
+ ml_gen_type(BoxedFieldType, MLDS_BoxedFieldType),
{ FieldLval = field(yes(PrimaryTag), lval(VarLval), FieldId,
- MLDS_FieldType, MLDS_VarType) },
+ MLDS_BoxedFieldType, MLDS_VarType) },
ml_gen_var(Arg, ArgLval),
%
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.23
diff -u -d -r1.23 post_typecheck.m
--- compiler/post_typecheck.m 2000/05/09 02:44:28 1.23
+++ compiler/post_typecheck.m 2000/06/05 06:28:16
@@ -986,13 +986,14 @@
% Overloading resolution ignores the class constraints.
ConsDefn = hlds_cons_defn(ConsExistQVars, _,
- ConsArgTypes, ConsTypeId, _),
+ ConsArgs, ConsTypeId, _),
ConsTypeId = TypeId,
module_info_types(ModuleInfo, Types),
map__search(Types, TypeId, TypeDefn),
hlds_data__get_type_defn_tvarset(TypeDefn, TypeTVarSet),
+ assoc_list__values(ConsArgs, ConsArgTypes),
arg_type_list_subsumes(TVarSet, ArgTypes,
TypeTVarSet, ConsExistQVars, ConsArgTypes).
@@ -1147,7 +1148,8 @@
%
type_util__get_type_and_cons_defn(ModuleInfo, TermType,
ConsId, TypeDefn, ConsDefn),
- ConsDefn = hlds_cons_defn(ExistQVars, _, ArgTypes0, _, _),
+ ConsDefn = hlds_cons_defn(ExistQVars, _, Args, _, _),
+ assoc_list__values(Args, ArgTypes0),
( ExistQVars = [] ->
ArgTypes1 = ArgTypes0,
PredInfo = PredInfo0,
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.276
diff -u -d -r1.276 typecheck.m
--- compiler/typecheck.m 2000/05/09 02:44:30 1.276
+++ compiler/typecheck.m 2000/06/05 06:29:42
@@ -4247,8 +4247,9 @@
:- mode convert_cons_defn(typecheck_info_ui, in, out) is det.
convert_cons_defn(TypeCheckInfo, HLDS_ConsDefn, ConsTypeInfo) :-
- HLDS_ConsDefn = hlds_cons_defn(ExistQVars, ExistConstraints, ArgTypes,
+ HLDS_ConsDefn = hlds_cons_defn(ExistQVars, ExistConstraints, Args,
TypeId, Context),
+ assoc_list__values(Args, ArgTypes),
typecheck_info_get_types(TypeCheckInfo, Types),
map__lookup(Types, TypeId, TypeDefn),
hlds_data__get_type_defn_tvarset(TypeDefn, ConsTypeVarSet),
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.82
diff -u -d -r1.82 type_util.m
--- compiler/type_util.m 2000/05/09 02:44:29 1.82
+++ compiler/type_util.m 2000/06/05 06:56:59
@@ -371,7 +371,7 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module bool, int, require, std_util, string, varset.
+:- import_module assoc_list, bool, int, require, std_util, string, varset.
:- import_module prog_io, prog_io_goal, prog_util.
type_util__type_id_module(_ModuleInfo, TypeName - _Arity, ModuleName) :-
@@ -685,8 +685,8 @@
type_util__do_get_type_and_cons_defn(ModuleInfo, VarType,
ConsId, TypeDefn, ConsDefn),
ConsDefn = hlds_cons_defn(ExistQVars0, _Constraints0,
- ArgTypes0, _, _),
- ArgTypes0 \= []
+ Args, _, _),
+ Args \= []
->
hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams),
term__term_list_to_var_list(TypeDefnParams, TypeDefnVars),
@@ -696,6 +696,7 @@
"type_util__get_cons_id_arg_types: existentially typed cons_id"),
map__from_corresponding_lists(TypeDefnVars, TypeArgs, TSubst),
+ assoc_list__values(Args, ArgTypes0),
term__apply_substitution_to_list(ArgTypes0, TSubst, ArgTypes)
;
ArgTypes = []
@@ -718,7 +719,8 @@
% otherwise fail.
type_util__get_existq_cons_defn(ModuleInfo, VarType, ConsId, CtorDefn) :-
type_util__is_existq_cons(ModuleInfo, VarType, ConsId, ConsDefn),
- ConsDefn = hlds_cons_defn(ExistQVars, Constraints, ArgTypes, _, _),
+ ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, _, _),
+ assoc_list__values(Args, ArgTypes),
module_info_types(ModuleInfo, Types),
type_to_type_id(VarType, TypeId, _),
map__lookup(Types, TypeId, TypeDefn),
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
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