[m-dev.] diff: MLDS back-end: misc bug fixes
Fergus Henderson
fjh at cs.mu.OZ.AU
Tue May 2 03:39:43 AEST 2000
Estimated hours taken: 10
Lots of bug fixes for the MLDS back-end.
compiler/ml_unify_gen.m:
- Fix a bug where it was getting the field type and class type
in the wrong order when generating fields of closures.
- When generating secondary tag test, ensure that we unbox
(i.e. cast) the secondary tag properly.
- When generating code for deconstruction unifications,
generate the correct field types, and pass them down to
ml_gen_unify_arg... but then ignore them, since currently
we store all fields as boxed (mlds__generic_type).
compiler/ml_unify_gen.m:
compiler/ml_call_gen.m:
- Fix a bug where it was not properly boxing/unboxing/casting
things when generating unifications of no_tag types.
compiler/mlds.m:
- Add some comments about the treatment of field types in
`new_object' statements and `field' lvals.
compiler/mlds_to_c.m:
- Use llds_out__sym_name_mangle rather than prog_out__write_sym
to write out module names, since the latter was doing the wrong
thing for nested modules.
- s/Word/MR_Word/g
compiler/ml_code_gen.m:
- When generating pragma c_code, make sure to cast polymorphically
typed arguments from MR_Word to MR_Box or vice versa, since the
C interface uses MR_Word (for backwards compatiblity) while the
MLDS back-end uses MR_Box for the C type of variables which
in Mercury are polymorphically typed.
- For semidet pragma c_code, add a `;' after the user's code,
like we do for the det and nondet cases, and like the LLDS
back-end does in all cases.
library/builtin.m:
- Fix `gcc -Wmissing-prototypes' warning about
mercury__builtin__copy_2_p_{0,1} being defined
without having been first declared.
- Avoid assuming that MR_Box is Word.
- s/Word/MR_Word/g
- Fix a bug: s/#ifdef HIGHLEVEL_CODE/#ifdef MR_HIGHLEVEL_CODE/
^^^
library/private_builtin.m:
- Add a missing #include.
- If MR_HIGHLEVEL_CODE is defined, use MR_box_float() and
MR_unbox_float() rather than word_to_float() and float_to_word();
this is necessary because float_to_word() uses MR_hp.
library/std_util.m:
runtime/mercury.h:
- Fix some code and documentation rot: s/type_info/type_desc/
library/std_util.m:
runtime/mercury_type_info.h:
- Add `const' in various places, to avoid warnings that occur
when compiling with --high-level-code.
runtime/mercury.h:
- Change `MR_Box' from `Word' to `void *'.
This is needed to avoid problems with casts to Word
in static initializers. It is also better style,
since `MR_Box' is intended as a generic type
and C uses `void *' as its generic type.
- Add a couple of nasty hacks to get things to compile.
runtime/mercury_type_info.h:
- Use a different type for procedure addresses in the MLDS back-end.
runtime/mercury_heap.h:
- Add definitions of create{1,2,3}{,_msg} for the MLDS back-end.
These are needed since they are used by the
MR_list_{empty,cons}{,_msg} macros in runtime/mercury_tags.h,
which are used in quite a few places in pragma c_code in the
standard library.
Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.4
diff -u -d -r1.4 ml_call_gen.m
--- compiler/ml_call_gen.m 2000/03/30 05:41:47 1.4
+++ compiler/ml_call_gen.m 2000/05/01 17:03:44
@@ -490,6 +490,19 @@
ArgRval = unop(box(mercury_type(SourceType)), VarRval)
;
%
+ % if converting from one concrete type to a different
+ % one, then cast
+ %
+ % This is needed to handle construction/deconstruction
+ % unifications for no_tag types.
+ %
+ ;
+ \+ type_util__type_unify(SourceType, DestType,
+ [], map__init, _)
+ ->
+ ArgRval = unop(cast(mercury_type(DestType)), VarRval)
+ ;
+ %
% otherwise leave unchanged
%
ArgRval = VarRval
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.33
diff -u -d -r1.33 ml_code_gen.m
--- compiler/ml_code_gen.m 2000/04/18 16:41:47 1.33
+++ compiler/ml_code_gen.m 2000/05/01 08:42:28
@@ -1630,7 +1630,7 @@
ObtainLock,
"\t\t{\n",
C_Code,
- "\n\t\t}\n",
+ "\n\t\t;}\n",
ReleaseLock,
MaybeAssignOutputsCode,
UndefSuccessIndicator,
@@ -1758,8 +1758,13 @@
ArgRval),
ml_gen_c_code_for_rval(ArgRval, Var_ArgName)
},
- { string__format("\t%s = %s;\n", [s(ArgName), s(Var_ArgName)],
- AssignInputString) }
+ { type_util__var(VarType, _) ->
+ Cast = "(MR_Word) "
+ ;
+ Cast = ""
+ },
+ { string__format("\t%s = %s%s;\n", [s(ArgName), s(Cast),
+ s(Var_ArgName)], AssignInputString) }
;
% if the variable doesn't occur in the ArgNames list,
% it can't be used, so we just ignore it
@@ -1787,8 +1792,13 @@
{ ml_gen_box_or_unbox_rval(OrigType, VarType, lval(VarLval),
ArgRval) },
{ ml_gen_c_code_for_rval(ArgRval, Var_ArgName) },
- { string__format("\t%s = %s;\n", [s(Var_ArgName), s(ArgName)],
- AssignOutputString) }
+ { type_util__var(VarType, _) ->
+ Cast = "(MR_Box) "
+ ;
+ Cast = ""
+ },
+ { string__format("\t%s = %s%s;\n", [s(Var_ArgName), s(Cast),
+ s(ArgName)], AssignOutputString) }
;
% if the variable doesn't occur in the ArgNames list,
% it can't be used, so we just ignore it
@@ -1818,7 +1828,7 @@
% XXX don't complain until run-time
% sorry("complicated pragma c_code")
Var_ArgName =
- "*(fatal_error(""complicated pragma c_code""),(Word *)0)"
+ "*(fatal_error(""complicated pragma c_code""),(MR_Word *)0)"
).
%-----------------------------------------------------------------------------%
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.21
diff -u -d -r1.21 mlds.m
--- compiler/mlds.m 2000/04/21 02:47:18 1.21
+++ compiler/mlds.m 2000/05/01 16:22:48
@@ -813,7 +813,17 @@
% The arguments to the constructor.
list(mlds__type)
% The types of the arguments to the
- % constructor.
+ % constructor.
+ %
+ % Note that currently we store all
+ % fields as type mlds__generic_type.
+ % But the type here is the actual
+ % argument type, which does not
+ % have to be mlds__generic_type.
+ % It is the responsibility of the
+ % MLDS->target code output phase
+ % to box the arguments if necessary.
+ %
)
; mark_hp(mlds__lval)
@@ -931,6 +941,16 @@
% The FieldType is the type of the field.
% The ClassType is the type of the object from
% which we are fetching the field.
+ %
+ % Note that currently we store all fields
+ % of objects created with new_object
+ % as type mlds__generic_type. For such objects,
+ % the type here should be mlds__generic_type,
+ % not the actual type of the field.
+ % If the actual type is different, then it
+ % is the HLDS->MLDS code generator's
+ % responsibility to insert the necessary
+ % code to handle boxing/unboxing.
%
% values somewhere in memory
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.27
diff -u -d -r1.27 mlds_to_c.m
--- compiler/mlds_to_c.m 2000/04/25 11:32:03 1.27
+++ compiler/mlds_to_c.m 2000/05/01 17:30:46
@@ -189,11 +189,12 @@
io__nl,
mlds_indent(Indent),
io__write_string("#ifndef MR_HEADER_GUARD_"),
- prog_out__write_sym_name(ModuleName),
+ { llds_out__sym_name_mangle(ModuleName, MangledModuleName) },
+ io__write_string(MangledModuleName),
io__nl,
mlds_indent(Indent),
io__write_string("#define MR_HEADER_GUARD_"),
- prog_out__write_sym_name(ModuleName),
+ io__write_string(MangledModuleName),
io__nl,
io__nl,
mlds_indent(Indent),
@@ -792,7 +793,7 @@
;
% XXX we ought to use pointers to struct types here,
% so that distinct Mercury types map to distinct C types
- io__write_string("Word")
+ io__write_string("MR_Word")
).
mlds_output_type(mlds__native_int_type) --> io__write_string("int").
mlds_output_type(mlds__native_float_type) --> io__write_string("float").
@@ -1393,7 +1394,7 @@
io__write_string(" = "),
( { MaybeTag = yes(Tag0) } ->
{ Tag = Tag0 },
- io__write_string("(Word) MR_mkword("),
+ io__write_string("(MR_Word) MR_mkword("),
mlds_output_tag(Tag),
io__write_string(", "),
{ EndMkword = ")" }
@@ -1466,6 +1467,10 @@
mlds_output_init_args([], [], _, _, _, _, _) --> [].
mlds_output_init_args([Arg|Args], [ArgType|ArgTypes], Context,
ArgNum, Target, Tag, Indent) -->
+ %
+ % Currently all fields of new_object instructions are
+ % represented as MR_Box, so we need to box them if necessary.
+ %
mlds_indent(Context, Indent),
io__write_string("MR_field("),
mlds_output_tag(Tag),
@@ -1473,7 +1478,7 @@
mlds_output_lval(Target),
io__write_string(", "),
io__write_int(ArgNum),
- io__write_string(") = (Word) "),
+ io__write_string(") = (MR_Word) "),
mlds_output_boxed_rval(ArgType, Arg),
io__write_string(";\n"),
mlds_output_init_args(Args, ArgTypes, Context,
@@ -1487,12 +1492,23 @@
:- pred mlds_output_lval(mlds__lval, io__state, io__state).
:- mode mlds_output_lval(in, di, uo) is det.
-mlds_output_lval(field(MaybeTag, Rval, offset(OffsetRval), _, _)) -->
- % XXX this generated code is ugly;
- % it would be nicer to use a different macro
- % than MR_field(), one which had type `MR_Box'
- % rather than `Word'.
- io__write_string("(* (MR_Box *) &"),
+mlds_output_lval(field(MaybeTag, Rval, offset(OffsetRval),
+ FieldType, _ClassType)) -->
+ (
+ { FieldType = mlds__generic_type
+ ; FieldType = mlds__mercury_type(term__variable(_))
+ }
+ ->
+ % XXX this generated code is ugly;
+ % it would be nicer to use a different macro
+ % than MR_field(), one which had type `MR_Box'
+ % rather than `Word'.
+ io__write_string("(* (MR_Box *) &")
+ ;
+ % The field type for field(_, _, offset(_), _, _) lvals
+ % must be something that maps to MR_Box.
+ { error("unexpected field type") }
+ ),
( { MaybeTag = yes(Tag) } ->
io__write_string("MR_field("),
mlds_output_tag(Tag),
@@ -1500,7 +1516,7 @@
;
io__write_string("MR_mask_field(")
),
- io__write_string("(Word) "),
+ io__write_string("(MR_Word) "),
mlds_output_rval(Rval),
io__write_string(", "),
mlds_output_rval(OffsetRval),
@@ -1600,7 +1616,7 @@
****/
mlds_output_rval(mkword(Tag, Rval)) -->
- io__write_string("(Word) MR_mkword("),
+ io__write_string("(MR_Word) MR_mkword("),
mlds_output_tag(Tag),
io__write_string(", "),
mlds_output_rval(Rval),
@@ -1655,7 +1671,12 @@
mlds_output_rval(Exprn),
io__write_string(")")
;
- io__write_string("((MR_Box) ("),
+ % We cast first to MR_Word, and then to MR_Box.
+ % This is done to avoid spurious warnings about "cast from
+ % pointer to integer of different size" from gcc.
+ % XXX The generated code would be more readable if we
+ % only did this for the cases where it was necessary.
+ io__write_string("((MR_Box) (MR_Word) ("),
mlds_output_rval(Exprn),
io__write_string("))")
).
@@ -1674,9 +1695,14 @@
mlds_output_rval(Exprn),
io__write_string(")")
;
+ % We cast first to MR_Word, and then to the desired type.
+ % This is done to avoid spurious warnings about "cast from
+ % pointer to integer of different size" from gcc.
+ % XXX The generated code would be more readable if we
+ % only did this for the cases where it was necessary.
io__write_string("(("),
mlds_output_type(Type),
- io__write_string(") "),
+ io__write_string(") (MR_Word) "),
mlds_output_rval(Exprn),
io__write_string(")")
).
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.5
diff -u -d -r1.5 ml_unify_gen.m
--- compiler/ml_unify_gen.m 2000/04/21 02:47:19 1.5
+++ compiler/ml_unify_gen.m 2000/05/01 16:22:14
@@ -195,9 +195,10 @@
MLDS_Decls, MLDS_Statements) -->
( { Args = [Arg], Modes = [Mode] } ->
ml_variable_type(Arg, ArgType),
+ ml_variable_type(Var, VarType),
ml_gen_var(Arg, ArgLval),
ml_gen_var(Var, VarLval),
- ml_gen_sub_unify(ArgLval, Mode, ArgType, VarLval,
+ ml_gen_sub_unify(Mode, ArgLval, ArgType, VarLval, VarType,
Context, [], MLDS_Statements),
{ MLDS_Decls = [] }
;
@@ -698,7 +699,7 @@
{ FieldId = offset(const(int_const(ArgNum + Offset))) },
% XXX these types might not be right
{ FieldLval = field(yes(0), lval(ClosureLval), FieldId,
- mlds__generic_env_ptr_type, mlds__generic_type) },
+ mlds__generic_type, mlds__generic_env_ptr_type) },
%
% recursively handle the remaining fields
%
@@ -887,7 +888,7 @@
ml_variable_type(Arg, ArgType),
ml_gen_var(Arg, ArgLval),
ml_gen_var(Var, VarLval),
- ml_gen_sub_unify(ArgLval, Mode, ArgType, VarLval,
+ ml_gen_sub_unify(Mode, ArgLval, ArgType, VarLval, Type,
Context, [], MLDS_Statements)
;
{ error("ml_code_gen: no_tag: arity != 1") }
@@ -896,28 +897,63 @@
{ Tag = unshared_tag(UnsharedTag) },
ml_gen_var(Var, VarLval),
ml_variable_types(Args, ArgTypes),
- ml_gen_unify_args(Args, Modes, ArgTypes, Type,
+ ml_field_types(Type, ConsId, ArgTypes, FieldTypes),
+ ml_gen_unify_args(Args, Modes, ArgTypes, FieldTypes, Type,
VarLval, 0, UnsharedTag, Context, MLDS_Statements)
;
{ Tag = shared_remote_tag(PrimaryTag, _SecondaryTag) },
ml_gen_var(Var, VarLval),
ml_variable_types(Args, ArgTypes),
- ml_gen_unify_args(Args, Modes, ArgTypes, Type,
+ ml_field_types(Type, ConsId, ArgTypes, FieldTypes),
+ ml_gen_unify_args(Args, Modes, ArgTypes, FieldTypes, Type,
VarLval, 1, PrimaryTag, Context, MLDS_Statements)
;
{ Tag = shared_local_tag(_Bits1, _Num1) },
{ MLDS_Statements = [] } % if this is det, then nothing happens
).
+ % Given a type and a cons_id, and also the types of the actual
+ % arguments of that cons_id in some particular use of it,
+ % look up the original types of the fields of that cons_id from
+ % the type definition. Note that the field types need not be
+ % the same as the actual argument types; for polymorphic types,
+ % 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.
+
+ml_field_types(Type, ConsId, ArgTypes, FieldTypes) -->
+ %
+ % Lookup the field types for the arguments of this cons_id
+ %
+ =(Info),
+ { 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, _, _) },
+ %
+ % Add the types 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) },
+ { NumExtraTypes = NumArgs - NumFieldTypes0 },
+ { ExtraFieldTypes = list__take_upto(NumExtraTypes, ArgTypes) },
+ { FieldTypes = list__append(ExtraFieldTypes, FieldTypes0) }.
+
:- pred ml_gen_unify_args(prog_vars, list(uni_mode), 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, out, in, out) is det.
+ 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.
-ml_gen_unify_args(Args, Modes, ArgTypes, VarType, VarLval, ArgNum,
+ml_gen_unify_args(Args, Modes, ArgTypes, FieldTypes, VarType, VarLval, ArgNum,
PrimaryTag, Context, MLDS_Statements) -->
(
- ml_gen_unify_args_2(Args, Modes, ArgTypes, VarType,
+ ml_gen_unify_args_2(Args, Modes, ArgTypes, FieldTypes, VarType,
VarLval, ArgNum, PrimaryTag, Context,
[], MLDS_Statements0)
->
@@ -927,64 +963,70 @@
).
:- pred ml_gen_unify_args_2(prog_vars, list(uni_mode), list(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_args_2(in, in, in, in, in, in, in, in, in, out, in, out)
- is semidet.
+ list(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_args_2(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([], [], [], _, _, _, _, _, _, Statements, Statements) -->
+ [].
ml_gen_unify_args_2([Arg|Args], [Mode|Modes], [ArgType|ArgTypes],
- VarType, VarLval, ArgNum, PrimaryTag, Context,
- MLDS_Statements0, MLDS_Statements) -->
+ [FieldType|FieldTypes], VarType, VarLval, ArgNum, PrimaryTag,
+ Context, MLDS_Statements0, MLDS_Statements) -->
{ ArgNum1 = ArgNum + 1 },
- ml_gen_unify_args_2(Args, Modes, ArgTypes, VarType, VarLval, ArgNum1,
- PrimaryTag, Context, MLDS_Statements0, MLDS_Statements1),
- ml_gen_unify_arg(Arg, Mode, ArgType, VarType, VarLval, ArgNum,
- PrimaryTag, Context, MLDS_Statements1, MLDS_Statements).
+ ml_gen_unify_args_2(Args, Modes, ArgTypes, FieldTypes, VarType,
+ VarLval, ArgNum1, PrimaryTag, Context,
+ MLDS_Statements0, MLDS_Statements1),
+ ml_gen_unify_arg(Arg, Mode, ArgType, FieldType, VarType, VarLval,
+ ArgNum, PrimaryTag, Context,
+ MLDS_Statements1, MLDS_Statements).
-:- pred ml_gen_unify_arg(prog_var, uni_mode, prog_type, prog_type,
+:- 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, out, in, out)
+:- mode ml_gen_unify_arg(in, in, in, in, in, in, in, in, in, in, out, in, out)
is det.
-ml_gen_unify_arg(Arg, Mode, ArgType, VarType, VarLval, ArgNum, PrimaryTag,
- Context, MLDS_Statements0, MLDS_Statements) -->
+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) },
+
+ %
% Generate lvals for the LHS and the RHS
%
{ FieldId = offset(const(int_const(ArgNum))) },
- { MLDS_ArgType = mercury_type_to_mlds_type(ArgType) },
+ { MLDS_FieldType = mercury_type_to_mlds_type(BoxedFieldType) },
{ MLDS_VarType = mercury_type_to_mlds_type(VarType) },
{ FieldLval = field(yes(PrimaryTag), lval(VarLval), FieldId,
- MLDS_ArgType, MLDS_VarType) },
+ MLDS_FieldType, MLDS_VarType) },
ml_gen_var(Arg, ArgLval),
+
%
% Now generate code to unify them
%
- ml_gen_sub_unify(ArgLval, Mode, ArgType, FieldLval, Context,
- MLDS_Statements0, MLDS_Statements).
+ ml_gen_sub_unify(Mode, ArgLval, ArgType, FieldLval, BoxedFieldType,
+ Context, MLDS_Statements0, MLDS_Statements).
-:- pred ml_gen_sub_unify(mlds__lval, uni_mode, prog_type, mlds__lval,
+:- pred ml_gen_sub_unify(uni_mode, mlds__lval, prog_type, mlds__lval, prog_type,
prog_context, mlds__statements, mlds__statements,
ml_gen_info, ml_gen_info).
-:- mode ml_gen_sub_unify(in, in, in, in, in, in, out, in, out) is det.
+:- mode ml_gen_sub_unify(in, in, in, in, in, in, in, out, in, out) is det.
-ml_gen_sub_unify(ArgLval, Mode, ArgType, FieldLval, Context,
+ml_gen_sub_unify(Mode, ArgLval, ArgType, FieldLval, FieldType, Context,
MLDS_Statements0, MLDS_Statements) -->
%
- % With the current low-level data representation,
- % we store all fields as boxed, so we need to box
- % values when storing them into fields and unbox them
- % when extracting them from fields.
- % Hence we compute a polymorphic type here, for use in
- % the calls to ml_gen_box_or_unbox_rval below.
- %
- { varset__init(TypeVarSet0) },
- { varset__new_var(TypeVarSet0, TypeVar, _TypeVarSet) },
- { type_util__var(BoxedFieldType, TypeVar) },
-
- %
% Figure out the direction of data-flow from the mode,
% and generate code accordingly
%
@@ -1013,7 +1055,7 @@
{ LeftMode = top_in },
{ RightMode = top_out }
->
- { ml_gen_box_or_unbox_rval(BoxedFieldType, ArgType,
+ { ml_gen_box_or_unbox_rval(FieldType, ArgType,
lval(FieldLval), FieldRval) },
{ MLDS_Statement = ml_gen_assign(ArgLval, FieldRval,
Context) },
@@ -1023,7 +1065,7 @@
{ LeftMode = top_out },
{ RightMode = top_in }
->
- { ml_gen_box_or_unbox_rval(ArgType, BoxedFieldType,
+ { ml_gen_box_or_unbox_rval(ArgType, FieldType,
lval(ArgLval), ArgRval) },
{ MLDS_Statement = ml_gen_assign(FieldLval, ArgRval,
Context) },
@@ -1140,10 +1182,16 @@
binop(and,
binop(eq, unop(std_unop(tag), Rval),
unop(std_unop(mktag), const(int_const(Bits)))),
- binop(eq, lval(field(yes(Bits), Rval,
+ binop(eq, % Note: with the current low-level data
+ % representation, all fields -- even the
+ % secondary tag -- are boxed, and so we
+ % need to unbox (i.e. cast) it back to
+ % the right type here.
+ unop(unbox(mlds__native_int_type),
+ lval(field(yes(Bits), Rval,
offset(const(int_const(0))),
- mlds__native_int_type,
- mercury_type_to_mlds_type(VarType))),
+ mlds__generic_type,
+ mercury_type_to_mlds_type(VarType)))),
const(int_const(Num)))).
ml_gen_tag_test_rval(shared_local_tag(Bits, Num), _, Rval) =
binop(eq, Rval,
Index: library/builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/builtin.m,v
retrieving revision 1.32
diff -u -d -r1.32 builtin.m
--- library/builtin.m 2000/04/21 02:47:29 1.32
+++ library/builtin.m 2000/04/25 16:28:59
@@ -234,7 +234,7 @@
:- pragma c_code("
-#ifndef HIGHLEVEL_CODE
+#ifndef MR_HIGHLEVEL_CODE
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO_FULL(builtin, , int, 0,
MR_TYPECTOR_REP_INT,
@@ -383,18 +383,26 @@
:- pragma c_header_code("#include ""mercury_deep_copy.h""").
+:- pragma c_header_code("
+#ifdef MR_HIGHLEVEL_CODE
+ void mercury__builtin__copy_2_p_0(MR_Word, MR_Box, MR_Box *);
+ void mercury__builtin__copy_2_p_1(MR_Word, MR_Box, MR_Box *);
+#endif
+").
+
:- pragma c_code("
#ifdef MR_HIGHLEVEL_CODE
void
-mercury__builtin__copy_2_p_0(Word type_info, MR_Box value, MR_Box * copy)
+mercury__builtin__copy_2_p_0(MR_Word type_info, MR_Box value, MR_Box * copy)
{
- *copy = deep_copy(&value, (Word *) type_info, NULL, NULL);
+ MR_Word val = (MR_Word) value;
+ *copy = (MR_Box) deep_copy(&val, (MR_TypeInfo) type_info, NULL, NULL);
}
void
-mercury__builtin__copy_2_p_1(Word type_info, MR_Box x, MR_Box * y)
+mercury__builtin__copy_2_p_1(MR_Word type_info, MR_Box x, MR_Box * y)
{
mercury__builtin__copy_2_p_0(type_info, x, y);
}
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.48
diff -u -d -r1.48 private_builtin.m
--- library/private_builtin.m 2000/04/21 02:47:29 1.48
+++ library/private_builtin.m 2000/04/22 19:47:19
@@ -1139,6 +1139,7 @@
#include ""mercury_misc.h"" /* for fatal_error(); */
#include ""mercury_type_info.h"" /* for MR_TypeCtorInfo_Struct; */
+#include ""mercury_tabling.h"" /* for MR_TrieNode, etc. */
extern MR_STATIC_CODE_CONST struct MR_TypeCtorInfo_Struct
mercury_data___type_ctor_info_int_0;
@@ -1246,8 +1247,15 @@
MR_TrieNode table;
table = (MR_TrieNode) T;
- MR_TABLE_SAVE_ANSWER(table, Offset, float_to_word(F),
+#ifdef MR_HIGHLEVEL_CODE
+ MR_TABLE_SAVE_ANSWER(table, Offset,
+ MR_box_float(F),
+ &mercury_data___type_ctor_info_float_0);
+#else
+ MR_TABLE_SAVE_ANSWER(table, Offset,
+ float_to_word(F),
&mercury_data___type_ctor_info_float_0);
+#endif
").
:- pragma c_code(table_save_any_ans(T::in, Offset::in, V::in),
@@ -1287,7 +1295,11 @@
MR_TrieNode table;
table = (MR_TrieNode) T;
+#ifdef MR_HIGHLEVEL_CODE
+ F = MR_unbox_float(MR_TABLE_GET_ANSWER(table, Offset));
+#else
F = word_to_float(MR_TABLE_GET_ANSWER(table, Offset));
+#endif
").
:- pragma c_code(table_restore_any_ans(T::in, Offset::in, V::out),
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.189
diff -u -d -r1.189 std_util.m
--- library/std_util.m 2000/04/18 03:44:42 1.189
+++ library/std_util.m 2000/04/25 11:35:04
@@ -71,7 +71,7 @@
:- mode det_univ_to_type(in, out) is det.
% univ_type(Univ):
- % returns the type_info for the type stored in `Univ'.
+ % returns the type_desc for the type stored in `Univ'.
%
:- func univ_type(univ) = type_desc.
@@ -1310,12 +1310,12 @@
typedef struct ML_Construct_Info_Struct {
ConstString functor_name;
Integer arity;
- MR_PseudoTypeInfo *arg_pseudo_type_infos;
+ const MR_PseudoTypeInfo *arg_pseudo_type_infos;
MR_TypeCtorRep type_ctor_rep;
union {
- MR_EnumFunctorDesc *enum_functor_desc;
- MR_NotagFunctorDesc *notag_functor_desc;
- MR_DuFunctorDesc *du_functor_desc;
+ const MR_EnumFunctorDesc *enum_functor_desc;
+ const MR_NotagFunctorDesc *notag_functor_desc;
+ const MR_DuFunctorDesc *du_functor_desc;
} functor_info;
} ML_Construct_Info;
@@ -1330,7 +1330,7 @@
MR_TypeInfoParams type_params);
extern Word ML_pseudo_type_info_vector_to_type_info_list(int arity,
MR_TypeInfoParams type_params,
- MR_PseudoTypeInfo *arg_pseudo_type_infos);
+ const MR_PseudoTypeInfo *arg_pseudo_type_infos);
extern bool ML_get_functors_check_range(int functor_number,
MR_TypeInfo type_info,
ML_Construct_Info *construct_info);
@@ -1338,7 +1338,7 @@
Word arg_list, Word term_vector);
extern bool ML_typecheck_arguments(MR_TypeInfo type_info,
int arity, Word arg_list,
- MR_PseudoTypeInfo *arg_pseudo_type_infos);
+ const MR_PseudoTypeInfo *arg_pseudo_type_infos);
extern MR_TypeInfo ML_make_type(int arity, MR_TypeCtorDesc type_ctor_desc,
Word arg_type_list);
").
@@ -1805,7 +1805,7 @@
case MR_TYPECTOR_REP_DU:
case MR_TYPECTOR_REP_DU_USEREQ:
{
- MR_DuFunctorDesc *functor_desc;
+ const MR_DuFunctorDesc *functor_desc;
Word arg_list;
Word ptag;
Word arity;
@@ -2040,7 +2040,7 @@
bool
ML_typecheck_arguments(MR_TypeInfo type_info, int arity, Word arg_list,
- MR_PseudoTypeInfo *arg_pseudo_type_infos)
+ const MR_PseudoTypeInfo *arg_pseudo_type_infos)
{
MR_TypeInfo arg_type_info;
MR_TypeInfo list_arg_type_info;
@@ -2225,7 +2225,7 @@
Word
ML_pseudo_type_info_vector_to_type_info_list(int arity,
- MR_TypeInfoParams type_params, MR_PseudoTypeInfo *arg_pseudo_type_infos)
+ MR_TypeInfoParams type_params, const MR_PseudoTypeInfo *arg_pseudo_type_infos)
{
MR_TypeInfo arg_type;
Word type_info_list;
Index: runtime/mercury.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.h,v
retrieving revision 1.4
diff -u -d -r1.4 mercury.h
--- runtime/mercury.h 2000/04/25 11:32:09 1.4
+++ runtime/mercury.h 2000/05/01 17:14:31
@@ -54,7 +54,7 @@
/*
** The MR_Box type is used for representing polymorphic types.
*/
-typedef Word MR_Box;
+typedef void *MR_Box;
/*
** With the low-level data representation, the MR_Word type
@@ -167,11 +167,36 @@
mercury__builtin__builtin__type_ctor_info_func_0,
mercury__array__array__type_ctor_info_array_1,
mercury__std_util__std_util__type_ctor_info_univ_0,
- mercury__std_util__std_util__type_ctor_info_type_info_0,
+ mercury__std_util__std_util__type_ctor_info_type_desc_0,
mercury__private_builtin__private_builtin__type_ctor_info_type_ctor_info_1,
mercury__private_builtin__private_builtin__type_ctor_info_type_info_1,
mercury__private_builtin__private_builtin__type_ctor_info_typeclass_info_1,
mercury__private_builtin__private_builtin__type_ctor_info_base_typeclass_info_1;
+
+/*
+** XXX this is a hack
+** Currently we don't get the #includes quite right;
+** this is a work-around to make the standard library compile.
+*/
+extern const MR_TypeCtorInfo_Struct
+ mercury__tree234__tree234__type_ctor_info_tree234_2;
+
+/*
+** XXX this is a bit of a hack: really we should change it so that
+** the generated MLDS code always qualifies things with `builtin:',
+** but currently it doesn't, so we use the following #defines as
+** a work-around.
+*/
+#define mercury__builtin____type_ctor_info_int_0 \
+ mercury__builtin__builtin__type_ctor_info_int_0
+#define mercury__builtin____type_ctor_info_string_0 \
+ mercury__builtin__builtin__type_ctor_info_string_0
+#define mercury__builtin____type_ctor_info_float_0 \
+ mercury__builtin__builtin__type_ctor_info_float_0
+#define mercury__builtin____type_ctor_info_character_0 \
+ mercury__builtin__builtin__type_ctor_info_character_0
+#define mercury__builtin____type_ctor_info_pred_0 \
+ mercury__builtin__builtin__type_ctor_info_pred_0
/*
** The compiler generates references to this constant.
Index: runtime/mercury_heap.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_heap.h,v
retrieving revision 1.13
diff -u -d -r1.13 mercury_heap.h
--- runtime/mercury_heap.h 1999/09/27 05:20:45 1.13
+++ runtime/mercury_heap.h 2000/04/22 19:58:56
@@ -169,6 +169,48 @@
tag_incr_hp_atomic_msg((dest), MR_mktag(0), (count), \
proclabel, (type))
+#ifdef MR_HIGHLEVEL_CODE
+
+MR_EXTERN_INLINE Word create1(Word w1);
+MR_EXTERN_INLINE Word create2(Word w1, Word w2);
+MR_EXTERN_INLINE Word create3(Word w1, Word w2, Word w3) ;
+
+MR_EXTERN_INLINE Word
+create1(Word w1)
+{
+ Word *p = (Word *) MR_new_object(Word, 1 * sizeof(Word), "create1");
+ p[0] = w1;
+ return (Word) p;
+}
+
+MR_EXTERN_INLINE Word
+create2(Word w1, Word w2)
+{
+ Word *p = (Word *) MR_new_object(Word, 2 * sizeof(Word), "create2");
+ p[0] = w1;
+ p[1] = w2;
+ return (Word) p;
+}
+
+MR_EXTERN_INLINE Word
+create3(Word w1, Word w2, Word w3)
+{
+ Word *p = (Word *) MR_new_object(Word, 3 * sizeof(Word), "create3");
+ p[0] = w1;
+ p[1] = w2;
+ p[2] = w3;
+ return (Word) p;
+}
+
+#define MR_create1_msg(w1, proclabel, type) \
+ create1((w1))
+#define MR_create2_msg(w1, w2, proclabel, type) \
+ create2((w1), (w2))
+#define MR_create3_msg(w1, w2, w3, proclabel, type) \
+ create3((w1), (w2), (w3))
+
+#else /* ! MR_HIGHLEVEL_CODE */
+
/*
** Note that gcc optimizes `hp += 2; return hp - 2;'
** to `tmp = hp; hp += 2; return tmp;', so we don't need to use
@@ -235,6 +277,8 @@
MR_hp[-1] = (Word) (w3), \
/* return */ (Word) (MR_hp - 3) \
)
+
+#endif /* ! MR_HIGHLEVEL_CODE */
/*
** Indended for use in handwritten C code where the Mercury registers
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.49
diff -u -d -r1.49 mercury_type_info.h
--- runtime/mercury_type_info.h 2000/04/21 02:47:35 1.49
+++ runtime/mercury_type_info.h 2000/05/01 17:20:20
@@ -581,7 +581,7 @@
MR_int_least8_t MR_du_functor_primary;
MR_int_least32_t MR_du_functor_secondary;
MR_int_least32_t MR_du_functor_ordinal;
- MR_PseudoTypeInfo *MR_du_functor_arg_types;
+ const MR_PseudoTypeInfo *MR_du_functor_arg_types;
const ConstString *MR_du_functor_arg_names;
const MR_DuExistInfo *MR_du_functor_exist_info;
} MR_DuFunctorDesc;
@@ -651,7 +651,7 @@
typedef struct {
MR_int_least32_t MR_sectag_sharers;
MR_Sectag_Locn MR_sectag_locn;
- const MR_DuFunctorDesc **MR_sectag_alternatives;
+ const MR_DuFunctorDesc * const * MR_sectag_alternatives;
} MR_DuPtagLayout;
typedef MR_DuPtagLayout *MR_DuTypeLayout;
@@ -705,6 +705,22 @@
/*---------------------------------------------------------------------------*/
/*
+** Some types are defined differently for the MLDS back-end.
+*/
+
+#ifdef MR_HIGHLEVEL_CODE
+ /*
+ ** XXX This should be `MR_Box', but MR_Box is not visible here
+ ** (due to a cyclic dependency problem), so we use `void *' instead.
+ */
+ typedef void * MR_ProcAddr;
+#else
+ typedef Code *MR_ProcAddr;
+#endif
+
+/*---------------------------------------------------------------------------*/
+
+/*
** This type describes the layout in any kind of discriminated union
** type: du, enum and notag. In an equivalence type, it gives the identity
** of the equivalent-to type.
@@ -763,12 +779,12 @@
struct MR_TypeCtorInfo_Struct {
Integer arity;
- Code *unify_pred;
- Code *new_unify_pred;
- Code *compare_pred;
+ MR_ProcAddr unify_pred;
+ MR_ProcAddr new_unify_pred;
+ MR_ProcAddr compare_pred;
MR_TypeCtorRep type_ctor_rep;
- Code *solver_pred;
- Code *init_pred;
+ MR_ProcAddr solver_pred;
+ MR_ProcAddr init_pred;
ConstString type_ctor_module_name;
ConstString type_ctor_name;
Integer type_ctor_version;
@@ -780,7 +796,7 @@
/*
** The following fields will be added later, once we can exploit them:
** union MR_TableNode_Union **type_std_table;
-** Code *prettyprinter;
+** MR_ProcAddr prettyprinter;
*/
};
--
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