[m-dev.] diff: MLDS backend: implement compound terms

Fergus Henderson fjh at cs.mu.OZ.AU
Tue Sep 21 08:45:56 AEST 1999


Estimated hours taken: 8

More work on the MLDS back-end:
Implement construction and deconstruction of compound terms
(using, for now, the same data representation as in the LLDS back-end).
Also, fix a few bugs.

compiler/mlds.m:
	Change the `field_id' type to allow fields to be identified
	by offsets rather than names.

compiler/ml_code_gen.m:
	Generate MLDS code for construction and tag tests of compound terms.
	Ensure that non-exported predicates are flagged as having
	`private' rather than `public' access.
	Ensure that we don't generate assignments to undeclared io__state
	arguments.
	Fix a bug in code generation for semidet deconstructions.
	Ensure that we consistently use mode_to_arg_mode rather than
	mode_is_input and mode_is_output.

compiler/mlds_to_c.m:
	Implement code to output `field_id's.
	For `new_object' instructions, handle argument initializers,
	and put the constructor name in quotes when calling MR_new_object().
	Reduce the number of unnecessary parentheses in the output.
	Cast the result of MR_mkword() to Word.

Workspace: /usr/hg2/fjh/mercury
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.6
diff -u -r1.6 ml_code_gen.m
--- compiler/ml_code_gen.m	1999/09/17 18:45:10	1.6
+++ compiler/ml_code_gen.m	1999/09/20 22:42:36
@@ -427,19 +427,19 @@
 %	- code generation for det, semidet, and nondet predicates:
 %		- conjunctions
 %		- disjunctions
+%		- negation
 %		- if-then-else
 %		- predicate calls
 %		- unifications
 %			- assignment
 %			- simple tests
-%			- construction of constants
+%			- constructions
 %			- deconstructions
 %		- switches
 % TODO:
 %	- commits
 %	- c_code pragmas
-%	- construction of compound terms
-%	- XXX construct/deconstruct/complicated unifications
+%	- no_tag types
 %	- construction of closures, and higher-order calls
 %	- class method calls
 %	- type declarations for user-defined types
@@ -472,7 +472,8 @@
 			    % and `code_util__cons_id_to_tag'.
 :- import_module goal_util.
 :- import_module hlds_pred, hlds_goal, hlds_data, prog_data, special_pred.
-:- import_module builtin_ops, passes_aux, type_util, mode_util.
+:- import_module hlds_out, builtin_ops, passes_aux, type_util, mode_util.
+:- import_module prog_util.
 
 :- import_module string, int, varset, term.
 :- import_module list, assoc_list, map, set, stack.
@@ -632,8 +633,13 @@
 	%
 :- func ml_gen_proc_decl_flags(module_info, pred_id, proc_id)
 		= mlds__decl_flags.
-ml_gen_proc_decl_flags(_ModuleInfo, _PredId, _ProcId) = MLDS_DeclFlags :-
-	Access = public, % XXX we should do better than that
+ml_gen_proc_decl_flags(ModuleInfo, PredId, ProcId) = MLDS_DeclFlags :-
+	module_info_pred_info(ModuleInfo, PredId, PredInfo),
+	( procedure_is_exported(PredInfo, ProcId) ->
+		Access = public
+	;
+		Access = private
+	),
 	PerInstance = per_instance,
 	Virtuality = non_virtual,
 	Finality = overridable,
@@ -1050,7 +1056,7 @@
 			% exclude arguments of type io__state etc.
 			{ InputRvals = InputRvals1 },
 			{ OutputLvals = OutputLvals1 }
-		; { mode_is_input(ModuleInfo, Mode) } ->
+		; { mode_to_arg_mode(ModuleInfo, Mode, Type, top_in) } ->
 			{ InputRvals = [lval(VarLval) | InputRvals1] },
 			{ OutputLvals = OutputLvals1 }
 	/************
@@ -1769,7 +1775,7 @@
 	%
 :- func ml_gen_label_func_decl_flags = mlds__decl_flags.
 ml_gen_label_func_decl_flags = MLDS_DeclFlags :-
-	Access = public, % XXX we should do better than that
+	Access = private,
 	PerInstance = per_instance,
 	Virtuality = non_virtual,
 	Finality = overridable,
@@ -1892,12 +1898,25 @@
 :- mode ml_gen_unification(in, in, in, out, out, in, out) is det.
 
 ml_gen_unification(assign(Var1, Var2), CodeModel, Context,
-		[], [MLDS_Statement]) -->
+		[], MLDS_Statements) -->
 	{ require(unify(CodeModel, model_det),
 		"ml_code_gen: assign not det") },
-	ml_gen_var(Var1, Var1Lval),
-	ml_gen_var(Var2, Var2Lval),
-	{ MLDS_Statement = ml_gen_assign(Var1Lval, lval(Var2Lval), Context) }.
+	(
+		%
+		% skip dummy argument types, since they will not have
+		% been declared
+		%
+		ml_variable_type(Var1, Type),
+		{ type_util__is_dummy_argument_type(Type) }
+	->
+		{ MLDS_Statements = [] }
+	;
+		ml_gen_var(Var1, Var1Lval),
+		ml_gen_var(Var2, Var2Lval),
+		{ MLDS_Statement = ml_gen_assign(Var1Lval, lval(Var2Lval),
+			Context) },
+		{ MLDS_Statements = [MLDS_Statement] }
+	).
 
 ml_gen_unification(simple_test(Var1, Var2), CodeModel, Context,
 		[], [MLDS_Statement]) -->
@@ -1976,15 +1995,15 @@
 	%
 	% generate code to construct the specified representation
 	%
-	ml_gen_construct_rep(Tag, Var, Args, ArgModes, Context,
+	ml_gen_construct_rep(Tag, ConsId, Var, Args, ArgModes, Context,
 			MLDS_Decls, MLDS_Statements).
 
-:- pred ml_gen_construct_rep(cons_tag, prog_var, prog_vars, list(uni_mode),
-		prog_context, mlds__defns, mlds__statements,
+:- pred ml_gen_construct_rep(cons_tag, cons_id, prog_var, prog_vars,
+		list(uni_mode), prog_context, mlds__defns, mlds__statements,
 		ml_gen_info, ml_gen_info).
-:- mode ml_gen_construct_rep(in, in, in, in, in, out, out, in, out) is det.
+:- mode ml_gen_construct_rep(in, in, in, in, in, in, out, out, in, out) is det.
 
-ml_gen_construct_rep(string_constant(String), Var, Args, _ArgModes, Context,
+ml_gen_construct_rep(string_constant(String), _, Var, Args, _ArgModes, Context,
 		[], [MLDS_Statement]) -->
 	( { Args = [] } ->
 		[]
@@ -1994,7 +2013,7 @@
 	ml_gen_var(Var, VarLval),
 	{ MLDS_Statement = ml_gen_assign(VarLval, const(string_const(String)),
 		Context) }.
-ml_gen_construct_rep(int_constant(Int), Var, Args, _ArgModes, Context,
+ml_gen_construct_rep(int_constant(Int), _, Var, Args, _ArgModes, Context,
 		[], [MLDS_Statement]) -->
 	( { Args = [] } ->
 		[]
@@ -2004,7 +2023,7 @@
 	ml_gen_var(Var, VarLval),
 	{ MLDS_Statement = ml_gen_assign(VarLval, const(int_const(Int)),
 		Context) }.
-ml_gen_construct_rep(float_constant(Float), Var, Args, _ArgModes, Context,
+ml_gen_construct_rep(float_constant(Float), _, Var, Args, _ArgModes, Context,
 		[], [MLDS_Statement]) -->
 	( { Args = [] } ->
 		[]
@@ -2015,7 +2034,7 @@
 	{ MLDS_Statement = ml_gen_assign(VarLval, const(float_const(Float)),
 		Context) }.
 
-ml_gen_construct_rep(no_tag, _Var, Args, Modes, _Context,
+ml_gen_construct_rep(no_tag, _ConsId, _Var, Args, Modes, _Context,
 		_MLDS_Decls, _MLDS_Statements) -->
 	( { Args = [_Arg], Modes = [_Mode] } ->
 		{ sorry("no_tag types") }
@@ -2028,47 +2047,17 @@
 		{ error("ml_code_gen: no_tag: arity != 1") }
 	).
 
-ml_gen_construct_rep(unshared_tag(_UnsharedTag), _Var, _Args, _ArgModes,
-		_Context, _MLDS_Decls, _MLDS_Statements) -->
-	{ sorry("compound data structures (unshared_tag)") }.
-/****
-	=(Info),
-	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
-	code_info__get_next_cell_number(CellNo),
-	ml_variable_types(Args, ArgTypes),
-	{ unify_gen__generate_cons_args(Args, ArgTypes, Modes, ModuleInfo,
-		RVals) },
-	{ Code = empty },
-	code_info__variable_type(Var, VarType),
-	{ unify_gen__var_type_msg(VarType, VarTypeMsg) },
-	% XXX Later we will need to worry about
-	% whether the cell must be unique or not.
-	{ Expr = create(UnsharedTag, RVals, uniform(no), can_be_either,
-		CellNo, VarTypeMsg) },
-****/
+ml_gen_construct_rep(unshared_tag(Tag), ConsId, Var, Args, ArgModes,
+		Context, MLDS_Decls, MLDS_Statements) -->
+	ml_gen_new_object(Tag, no, ConsId, Var, Args, ArgModes, Context,
+		MLDS_Decls, MLDS_Statements).
+ml_gen_construct_rep(shared_remote_tag(Tag, SecondaryTag), ConsId, Var, Args,
+		ArgModes, Context, MLDS_Decls, MLDS_Statements) -->
+	ml_gen_new_object(Tag, yes(SecondaryTag), ConsId, Var, Args, ArgModes,
+		Context, MLDS_Decls, MLDS_Statements).
 
-ml_gen_construct_rep(shared_remote_tag(_Bits0, _Num0), _Var, _Args, _ArgModes,
-		_Context, _MLDS_Decls, _MLDS_Statements) -->
-	{ sorry("compound data structures (shared_remote_tag)") }.
-/****
-	code_info__get_module_info(ModuleInfo),
-	code_info__get_next_cell_number(CellNo),
-	unify_gen__var_types(Args, ArgTypes),
-	{ unify_gen__generate_cons_args(Args, ArgTypes, Modes, ModuleInfo,
-		RVals0) },
-		% the first field holds the secondary tag
-	{ RVals = [yes(const(int_const(Num0))) | RVals0] },
-	{ Code = empty },
-	code_info__variable_type(Var, VarType),
-	{ unify_gen__var_type_msg(VarType, VarTypeMsg) },
-	% XXX Later we will need to worry about
-	% whether the cell must be unique or not.
-	{ Expr = create(Bits0, RVals, uniform(no), can_be_either,
-		CellNo, VarTypeMsg) },
-	code_info__cache_expression(Var, Expr).
-****/
-ml_gen_construct_rep(shared_local_tag(Bits1, Num1), Var, Args, _ArgModes,
-		Context, [], [MLDS_Statement]) -->
+ml_gen_construct_rep(shared_local_tag(Bits1, Num1), _ConsId, Var, Args,
+		_ArgModes, Context, [], [MLDS_Statement]) -->
 	( { Args = [] } ->
 		[]
 	;
@@ -2080,7 +2069,7 @@
 		Context) }.
 
 ml_gen_construct_rep(type_ctor_info_constant(ModuleName, TypeName, TypeArity),
-		Var, Args, _ArgModes, Context,
+		_ConsId, Var, Args, _ArgModes, Context,
 		[], [MLDS_Statement]) -->
 	( { Args = [] } ->
 		[]
@@ -2094,7 +2083,7 @@
 	{ MLDS_Statement = ml_gen_assign(VarLval, 
 		const(data_addr_const(DataAddr)), Context) }.
 ml_gen_construct_rep(base_typeclass_info_constant(ModuleName, ClassId,
-			Instance), Var, Args, _ArgModes, Context,
+			Instance), _ConsId, Var, Args, _ArgModes, Context,
 		[], [MLDS_Statement]) -->
 	( { Args = [] } ->
 		[]
@@ -2108,8 +2097,8 @@
 	{ MLDS_Statement = ml_gen_assign(VarLval, 
 		const(data_addr_const(DataAddr)), Context) }.
 
-ml_gen_construct_rep(tabling_pointer_constant(PredId, ProcId), Var,
-		Args, _ArgModes, Context, [], [MLDS_Statement]) -->
+ml_gen_construct_rep(tabling_pointer_constant(PredId, ProcId), _ConsId,
+		Var, Args, _ArgModes, Context, [], [MLDS_Statement]) -->
 	( { Args = [] } ->
 		[]
 	;
@@ -2126,8 +2115,8 @@
 	{ MLDS_Statement = ml_gen_assign(VarLval, 
 		const(data_addr_const(DataAddr)), Context) }.
 
-ml_gen_construct_rep(code_addr_constant(PredId, ProcId), Var,
-		Args, _ArgModes, Context, [], [MLDS_Statement]) -->
+ml_gen_construct_rep(code_addr_constant(PredId, ProcId), _ConsId,
+		Var, Args, _ArgModes, Context, [], [MLDS_Statement]) -->
 	( { Args = [] } ->
 		[]
 	;
@@ -2137,8 +2126,8 @@
 	ml_gen_proc_addr_rval(PredId, ProcId, ProcAddrRval),
 	{ MLDS_Statement = ml_gen_assign(VarLval, ProcAddrRval, Context) }.
 
-ml_gen_construct_rep(pred_closure_tag(PredId, ProcId, EvalMethod), _Var,
-		_Args, _ArgModes, _Context, [], [_MLDS_Statement]) -->
+ml_gen_construct_rep(pred_closure_tag(PredId, ProcId, EvalMethod), _ConsId,
+		_Var, _Args, _ArgModes, _Context, [], [_MLDS_Statement]) -->
 	% This constructs a closure.
 	% The representation of closures for the LLDS backend is defined in
 	% runtime/mercury_ho_call.h.
@@ -2202,6 +2191,126 @@
 	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
 	{ code_util__cons_id_to_tag(ConsId, Type, ModuleInfo, Tag) }.
 
+:- pred ml_gen_new_object(mlds__tag, maybe(int), cons_id, prog_var, prog_vars,
+		list(uni_mode), prog_context, mlds__defns, mlds__statements,
+		ml_gen_info, ml_gen_info).
+:- mode ml_gen_new_object(in, in, in, in, in, in, in, out, out, in, out)
+		is det.
+
+ml_gen_new_object(Tag, MaybeSecondaryTag, ConsId, Var, ArgVars, ArgModes,
+		Context, MLDS_Decls, MLDS_Statements) -->
+	%
+	% Determine the variable's type and lval,
+	% and determine the constructor name and the tag to use.
+	%
+	ml_variable_type(Var, Type),
+	{ MLDS_Type = mercury_type_to_mlds_type(Type) },
+	ml_gen_var(Var, Lval),
+	ml_cons_name(ConsId, CtorName),
+	{ Tag = 0 ->
+		MaybeTag = no
+	;
+		MaybeTag = yes(Tag)
+	},
+
+	%
+	% Generate rvals for the arguments
+	%
+	ml_gen_var_list(ArgVars, ArgLvals),
+	ml_variable_types(ArgVars, ArgTypes),
+	{ MLDS_ArgTypes0 = list__map(mercury_type_to_mlds_type, ArgTypes) },
+	=(Info),
+	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
+	{ ml_gen_cons_args(ArgLvals, ArgTypes, ArgModes, ModuleInfo,
+		ArgRvals0) },
+
+	% 
+	% If there is a secondary tag, it goes in the first field
+	%
+	{ MaybeSecondaryTag = yes(SecondaryTag) ->
+		SecondaryTagRval = const(int_const(SecondaryTag)),
+		SecondaryTagType = mlds__int_type,
+		ArgRvals = [SecondaryTagRval | ArgRvals0],
+		MLDS_ArgTypes = [SecondaryTagType | MLDS_ArgTypes0]
+	;
+		ArgRvals = ArgRvals0,
+		MLDS_ArgTypes = MLDS_ArgTypes0
+	},
+
+	%
+	% Compute the number of bytes to allocate
+	%
+	{ list__length(ArgRvals, NumArgs) },
+	{ SizeInWordsRval = const(int_const(NumArgs)) },
+	{ SizeOfWordRval = ml_sizeof_word_rval },
+	{ SizeInBytesRval = binop((*), SizeInWordsRval, SizeOfWordRval) },
+	
+	%
+	% Now put it all together.
+	%
+	{ MakeNewObject = new_object(Lval, MaybeTag, MLDS_Type,
+		yes(SizeInBytesRval), yes(CtorName), ArgRvals,
+		MLDS_ArgTypes) },
+	{ MLDS_Stmt = atomic(MakeNewObject) },
+	{ MLDS_Statement = mlds__statement(MLDS_Stmt,
+		mlds__make_context(Context)) },
+	{ MLDS_Statements = [MLDS_Statement] },
+	{ MLDS_Decls = [] }.
+
+:- pred ml_cons_name(cons_id, ctor_name, ml_gen_info, ml_gen_info).
+:- mode ml_cons_name(in, out, in, out) is det.
+
+ml_cons_name(ConsId, ConsName) -->
+	{ hlds_out__cons_id_to_string(ConsId, ConsName) }.
+
+	% Return an rval for the `SIZEOF_WORD' constant.
+	% This constant is supposed to be defined by the Mercury library.
+	% It holds `sizeof(Word)'.  (Using this constant allows us to avoid
+	% hard-coding the word size without having to add support for
+	% `sizeof' to MLDS.)
+	%
+:- func ml_sizeof_word_rval = mlds__rval.
+ml_sizeof_word_rval = SizeofWordRval :-
+	mercury_private_builtin_module(PrivateBuiltin),
+	MLDS_Module = mercury_module_name_to_mlds(PrivateBuiltin),
+	SizeofWordRval = lval(var(qual(MLDS_Module, "SIZEOF_WORD"))).
+
+:- pred ml_gen_cons_args(list(mlds__lval), list(prog_data__type),
+		list(uni_mode), module_info, list(mlds__rval)).
+:- mode ml_gen_cons_args(in, in, in, in, out) is det.
+
+ml_gen_cons_args(Lvals, Types, Modes, ModuleInfo, Rvals) :-
+	( ml_gen_cons_args_2(Lvals, Types, Modes, ModuleInfo, Rvals0) ->
+		Rvals = Rvals0
+	;
+		error("ml_gen_cons_args: length mismatch")
+	).
+
+	% Create a list of rvals for the arguments
+	% for a construction unification.  For each argument which
+	% is input to the construction unification, we produce the
+	% corresponding lval, but if the argument is free,
+	% we just produce `0', meaning initialize that field to a
+	% null value.  (XXX perhaps we should have a special `null' rval.)
+
+:- pred ml_gen_cons_args_2(list(mlds__lval), list(prog_data__type),
+		list(uni_mode), module_info, list(mlds__rval)).
+:- mode ml_gen_cons_args_2(in, in, in, in, out) is semidet.
+
+ml_gen_cons_args_2([], [], [], _, []).
+ml_gen_cons_args_2([Lval|Lvals], [Type|Types], [UniMode|UniModes],
+			ModuleInfo, [Rval|Rvals]) :-
+	UniMode = ((_LI - RI) -> (_LF - RF)),
+	( mode_to_arg_mode(ModuleInfo, (RI -> RF), Type, top_in) ->
+		Rval = lval(Lval)
+	;
+		% XXX perhaps we should have a special `null' rval.
+		Rval = const(int_const(0))
+	),
+	ml_gen_cons_args_2(Lvals, Types, UniModes, ModuleInfo, Rvals).
+
+%-----------------------------------------------------------------------------%
+
 	% Generate a deterministic deconstruction. In a deterministic
 	% deconstruction, we know the value of the tag, so we don't
 	% need to generate a test.
@@ -2218,7 +2327,7 @@
 %		A2 = arg(X, f, 2);
 %		...
 
-ml_gen_det_deconstruct(Var, ConsId, _Args, _Modes, _Context,
+ml_gen_det_deconstruct(Var, ConsId, Args, Modes, Context,
 		MLDS_Decls, MLDS_Statements) -->
 	{ MLDS_Decls = [] },
 	ml_variable_type(Var, Type),
@@ -2253,14 +2362,6 @@
 		% XXX not yet implemented
 		{ Tag = no_tag },
 		{ sorry("compound terms (no_tag deconstruct)") }
-	;
-		% XXX not yet implemented
-		{ Tag = unshared_tag(_) },
-		{ sorry("compound terms (unshared_tag deconstruct)") }
-	;
-		% XXX not yet implemented
-		{ Tag = shared_remote_tag(_, _) },
-		{ sorry("compound terms (shared_remote_tag deconstruct)") }
 /****
 	;
 		{ Tag = no_tag },
@@ -2272,32 +2373,122 @@
 		;
 			{ error("ml_code_gen: no_tag: arity != 1") }
 		)
+****/
 	;
 		{ Tag = unshared_tag(UnsharedTag) },
-		{ Rval = var(Var) },
-		% XXX FIXME
-		{ ml_gen_make_fields_and_argvars(Args, Rval, 0, UnsharedTag,
-			Fields, ArgVars) },
+		ml_gen_var(Var, VarLval),
 		ml_variable_types(Args, ArgTypes),
-		% XXX FIXME
-		ml_gen_unify_args(Fields, ArgVars, Modes, ArgTypes,
-			MLDS_Statements)
-	;
-		{ Tag = shared_remote_tag(Bits0, _Num0) },
-		{ Rval = var(Var) },
-		% XXX FIXME
-		{ ml_gen_make_fields_and_argvars(Args, Rval, 1,
-			Bits0, Fields, ArgVars) },
+		ml_gen_unify_args(Args, Modes, ArgTypes,
+			VarLval, 0, UnsharedTag, Context, MLDS_Statements)
+	;
+		{ Tag = shared_remote_tag(PrimaryTag, _SecondaryTag) },
+		ml_gen_var(Var, VarLval),
 		ml_variable_types(Args, ArgTypes),
-		% XXX FIXME
-		ml_gen_unify_args(Fields, ArgVars, Modes, ArgTypes,
-			MLDS_Statements)
-****/
+		ml_gen_unify_args(Args, Modes, ArgTypes,
+			VarLval, 1, PrimaryTag, Context, MLDS_Statements)
 	;
 		{ Tag = shared_local_tag(_Bits1, _Num1) },
 		{ MLDS_Statements = [] } % if this is det, then nothing happens
 	).
 
+:- pred ml_gen_unify_args(prog_vars, list(uni_mode), list(prog_data__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, out, in, out) is det.
+
+ml_gen_unify_args(Args, Modes, ArgTypes, VarLval, ArgNum, PrimaryTag, Context,
+		MLDS_Statements) -->
+	(
+		ml_gen_unify_args_2(Args, Modes, ArgTypes,
+			VarLval, ArgNum, PrimaryTag, Context,
+			[], MLDS_Statements0)
+	->
+		{ MLDS_Statements = MLDS_Statements0 }
+	;
+		{ error("ml_gen_unify_args: length mismatch") }
+	).
+
+:- pred ml_gen_unify_args_2(prog_vars, list(uni_mode), list(prog_data__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, out, in, out)
+		is semidet.
+
+ml_gen_unify_args_2([], [], [], _, _, _, _, Statements, Statements) --> [].
+ml_gen_unify_args_2([Arg|Args], [Mode|Modes], [ArgType|ArgTypes],
+			VarLval, ArgNum, PrimaryTag, Context,
+			MLDS_Statements0, MLDS_Statements) -->
+	{ ArgNum1 = ArgNum + 1 },
+	ml_gen_unify_args_2(Args, Modes, ArgTypes, VarLval, ArgNum1,
+		PrimaryTag, Context, MLDS_Statements0, MLDS_Statements1),
+	ml_gen_unify_arg(Arg, Mode, ArgType, VarLval, ArgNum, PrimaryTag,
+		Context, MLDS_Statements1, MLDS_Statements).
+
+:- pred ml_gen_unify_arg(prog_var, uni_mode, prog_data__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, out, in, out)
+		is det.
+
+ml_gen_unify_arg(Arg, Mode, ArgType, VarLval, ArgNum, PrimaryTag, Context,
+		MLDS_Statements0, MLDS_Statements) -->
+	%
+	% Generate lvals for the LHS and the RHS
+	%
+	{ FieldId = offset(const(int_const(ArgNum))) },
+	{ FieldLval = field(yes(PrimaryTag), lval(VarLval), FieldId) },
+	ml_gen_var(Arg, ArgLval),
+
+	%
+	% Figure out the direction of data-flow from the mode,
+	% and generate code accordingly
+	%
+	{ Mode = ((LI - RI) -> (LF - RF)) },
+	=(Info),
+	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
+	{ mode_to_arg_mode(ModuleInfo, (LI -> LF), ArgType, LeftMode) },
+	{ mode_to_arg_mode(ModuleInfo, (RI -> RF), ArgType, RightMode) },
+	(
+		% skip dummy argument types, since they will not have
+		% been declared
+		{ type_util__is_dummy_argument_type(ArgType) }
+	->
+		{ MLDS_Statements = MLDS_Statements0 }
+	;
+		% both input: it's a test unification
+		{ LeftMode = top_in },
+		{ RightMode = top_in }
+	->
+		% This shouldn't happen, since mode analysis should
+		% avoid creating any tests in the arguments
+		% of a construction or deconstruction unification.
+		{ error("test in arg of [de]construction") }
+	;
+		% input - output: it's an assignment to the RHS
+		{ LeftMode = top_in },
+		{ RightMode = top_out }
+	->
+		{ MLDS_Statement = ml_gen_assign(ArgLval, lval(FieldLval),
+			Context) },
+		{ MLDS_Statements = [MLDS_Statement | MLDS_Statements0] }
+	;
+		% output - input: it's an assignment to the LHS
+		{ LeftMode = top_out },
+		{ RightMode = top_in }
+	->
+		{ MLDS_Statement = ml_gen_assign(FieldLval, lval(ArgLval),
+			Context) },
+		{ MLDS_Statements = [MLDS_Statement | MLDS_Statements0] }
+	;
+		% unused - unused: the unification has no effect
+		{ LeftMode = top_unused },
+		{ RightMode = top_unused }
+	->
+		{ MLDS_Statements = MLDS_Statements0 }
+	;
+		{ error("unify_gen__generate_sub_unify: some strange unify") }
+	).
+
 %-----------------------------------------------------------------------------%
 
 	% Generate a semidet deconstruction.
@@ -2324,14 +2515,23 @@
 		MLDS_Decls, MLDS_Statements) -->
 	ml_gen_tag_test(Var, ConsId, TagTestDecls, TagTestStatements,
 		TagTestExpression),
+	ml_gen_set_success(TagTestExpression, Context, SetTagTestResult),
 	ml_gen_det_deconstruct(Var, ConsId, Args, ArgModes, Context,
 		GetArgsDecls, GetArgsStatements),
-	{ GetArgs = ml_gen_block(GetArgsDecls, GetArgsStatements, Context) },
-	{ IfStmt = if_then_else(TagTestExpression, GetArgs, no) },
-	{ IfStatement = mlds__statement(IfStmt,
-		mlds__make_context(Context)) },
-	{ MLDS_Decls = TagTestDecls },
-	{ MLDS_Statements = list__append(TagTestStatements, [IfStatement]) }.
+	{ GetArgsDecls = [], GetArgsStatements = [] ->
+		MLDS_Decls = TagTestDecls,
+		MLDS_Statements = list__append(TagTestStatements,
+			[SetTagTestResult])
+	;
+		GetArgs = ml_gen_block(GetArgsDecls, GetArgsStatements,
+			Context),
+		IfStmt = if_then_else(TagTestExpression, GetArgs, no),
+		IfStatement = mlds__statement(IfStmt,
+			mlds__make_context(Context)),
+		MLDS_Decls = TagTestDecls,
+		MLDS_Statements = list__append(TagTestStatements,
+			[SetTagTestResult, IfStatement])
+	}.
 
 	% ml_gen_tag_test_rval(Var, ConsId, Defns, Statements, Expression):
 	%	Generate code to perform a tag test.
@@ -2389,19 +2589,13 @@
 ml_gen_tag_test_rval(no_tag, _Rval) = const(true).
 ml_gen_tag_test_rval(unshared_tag(UnsharedTag), Rval) =
 	binop(eq, unop(tag, Rval), unop(mktag, const(int_const(UnsharedTag)))).
-ml_gen_tag_test_rval(shared_remote_tag(_, _), _) = _ :-
-	% XXX not yet implemented
-	sorry("compound terms (shared_remote_tag tag test)").
-/***
-This doesn't work because the MLDS doesn't have an appropriate `field' rval.
 ml_gen_tag_test_rval(shared_remote_tag(Bits, Num), Rval) =
 	binop(and,
 		binop(eq,	unop(tag, Rval),
 				unop(mktag, const(int_const(Bits)))), 
 		binop(eq,	lval(field(yes(Bits), Rval,
-					const(int_const(0)))),
+					offset(const(int_const(0))))),
 				const(int_const(Num)))).
-***/
 ml_gen_tag_test_rval(shared_local_tag(Bits, Num), Rval) =
 	binop(eq, Rval, mkword(Bits, unop(mkbody, const(int_const(Num))))).
 
@@ -2804,21 +2998,21 @@
 	% return a list containing only those variables which have
 	% an output mode.
 	%
-:- func select_output_vars(module_info, list(prog_var), list(mode)) =
-		list(prog_var).
+:- func select_output_vars(module_info, list(prog_var), list(mode),
+		map(prog_var, prog_data__type)) = list(prog_var).
 
-select_output_vars(ModuleInfo, HeadVars, HeadModes) = OutputVars :-
+select_output_vars(ModuleInfo, HeadVars, HeadModes, VarTypes) = OutputVars :-
 	( HeadVars = [], HeadModes = [] ->
 		OutputVars = []
 	; HeadVars = [Var|Vars], HeadModes = [Mode|Modes] ->
-		% XXX should we instead use mode_to_arg_mode here?
-		( mode_is_output(ModuleInfo, Mode) ->
+		map__lookup(VarTypes, Var, Type),
+		( \+ mode_to_arg_mode(ModuleInfo, Mode, Type, top_in) ->
 			OutputVars1 = select_output_vars(ModuleInfo,
-					Vars, Modes),
+					Vars, Modes, VarTypes),
 			OutputVars = [Var | OutputVars1]
 		;
 			OutputVars = select_output_vars(ModuleInfo,
-					Vars, Modes)
+					Vars, Modes, VarTypes)
 		)
 	;
 		error("select_output_vars: length mismatch")
@@ -2865,7 +3059,7 @@
 
 ml_gen_arg_decl(ModuleInfo, Var, Type, Mode, VarSet, FuncArg) :-
 	MLDS_Type = mercury_type_to_mlds_type(Type),
-	( mode_is_output(ModuleInfo, Mode) ->
+	( \+ mode_to_arg_mode(ModuleInfo, Mode, Type, top_in) ->
 		MLDS_ArgType = mlds__ptr_type(MLDS_Type)
 	;
 		MLDS_ArgType = MLDS_Type
@@ -2991,7 +3185,8 @@
 	proc_info_varset(ProcInfo, VarSet),
 	proc_info_vartypes(ProcInfo, VarTypes),
 	proc_info_argmodes(ProcInfo, HeadModes),
-	OutputVars = select_output_vars(ModuleInfo, HeadVars, HeadModes),
+	OutputVars = select_output_vars(ModuleInfo, HeadVars, HeadModes,
+		VarTypes),
 	FuncLabelCounter = 0,
 	stack__init(SuccContStack),
 	MLDSGenInfo = ml_gen_info(
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.7
diff -u -r1.7 mlds.m
--- compiler/mlds.m	1999/09/17 14:18:30	1.7
+++ compiler/mlds.m	1999/09/20 20:07:59
@@ -761,18 +761,30 @@
 %-----------------------------------------------------------------------------%
 
 	%
-	% An lval represents a data location or variable that can be used
-	% as the target of an assignment.
-	%
-	% XXX this probably needs work
+	% A field_id represents some data within an object
 	%
 
-:- type field_id == mlds__fully_qualified_name(field_name).
+:- type field_id 
+	--->		% 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))
+	.
+
 :- type field_name == string.
 
+	%
+	% An mlds__var represents a variable or constant.
+	%
 :- type mlds__var == mlds__fully_qualified_name(mlds__var_name).
 :- type mlds__var_name == string.
 
+	%
+	% An lval represents a data location or variable that can be used
+	% as the target of an assignment.
+	%
 :- type mlds__lval 
 
 	%
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.6
diff -u -r1.6 mlds_to_c.m
--- compiler/mlds_to_c.m	1999/09/17 17:19:12	1.6
+++ compiler/mlds_to_c.m	1999/09/20 21:55:24
@@ -849,12 +849,14 @@
 	mlds_indent(Indent),
 	mlds_output_lval(Target),
 	io__write_string(" = "),
-	( { MaybeTag = yes(Tag) } ->
-		io__write_string("MR_mkword("),
+	( { MaybeTag = yes(Tag0) } ->
+		{ Tag = Tag0 },
+		io__write_string("(Word) MR_mkword("),
 		mlds_output_tag(Tag),
 		io__write_string(", "),
 		{ EndMkword = ")" }
 	;
+		{ Tag = 0 },
 		{ EndMkword = "" }
 	),
 	io__write_string("MR_new_object("),
@@ -868,21 +870,16 @@
 	),
 	io__write_string(", "),
 	( { MaybeCtorName = yes(CtorName) } ->
-		io__write_string(CtorName)
+		io__write_char('"'),
+		c_util__output_quoted_string(CtorName),
+		io__write_char('"')
 	;
 		io__write_string("NULL")
 	),
 	io__write_string(")"),
 	io__write_string(EndMkword),
 	io__write_string(";\n"),
-	%
-	% XXX we should handle the constructor arguments / initializer
-	%
-	( { Args = [], ArgTypes = [] } ->
-		[]
-	;
-		{ error("mlds_output_atomic_stmt: new_object initializer") }
-	).
+	mlds_output_init_args(Args, ArgTypes, 0, Target, Tag, Indent).
 
 mlds_output_atomic_stmt(Indent, mark_hp(Lval)) -->
 	mlds_indent(Indent),
@@ -915,6 +912,29 @@
 			% that does not have any non-local flow of control.
 */
 
+:- pred mlds_output_init_args(list(rval), list(mlds__type), int, mlds__lval,
+		tag, int, io__state, io__state).
+:- mode mlds_output_init_args(in, in, in, in, in, in, di, uo) is det.
+
+mlds_output_init_args([_|_], [], _, _, _, _) -->
+	{ error("mlds_output_init_args: length mismatch") }.
+mlds_output_init_args([], [_|_], _, _, _, _) -->
+	{ error("mlds_output_init_args: length mismatch") }.
+mlds_output_init_args([], [], _, _, _, _) --> [].
+mlds_output_init_args([Arg|Args], [_ArgType|ArgTypes], ArgNum, Target, Tag,
+		Indent) -->
+	mlds_indent(Indent),
+	io__write_string("MR_field("),
+	mlds_output_tag(Tag),
+	io__write_string(", "),
+	mlds_output_lval(Target),
+	io__write_string(", "),
+	io__write_int(ArgNum),
+	io__write_string(") = "),
+	mlds_output_rval(Arg),
+	io__write_string(";\n"),
+	mlds_output_init_args(Args, ArgTypes, ArgNum + 1, Target, Tag, Indent).
+
 %-----------------------------------------------------------------------------%
 %
 % Code to output expressions
@@ -923,8 +943,34 @@
 :- 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, _FieldId)) -->
-	{ error("mlds.m: sorry, not yet implemented: field") }.
+mlds_output_lval(field(MaybeTag, Rval, offset(OffsetRval))) -->
+	( { MaybeTag = yes(Tag) } ->
+		io__write_string("MR_field("),
+		mlds_output_tag(Tag),
+		io__write_string(", ")
+	;
+		io__write_string("MR_mask_field(")
+	),
+	mlds_output_rval(Rval),
+	io__write_string(", "),
+	mlds_output_rval(OffsetRval),
+	io__write_string(")").
+mlds_output_lval(field(MaybeTag, Rval, named_field(FieldId))) -->
+	( { MaybeTag = yes(0) } ->
+		mlds_output_rval(Rval)
+	;
+		( { MaybeTag = yes(Tag) } ->
+			io__write_string("MR_body("),
+			mlds_output_tag(Tag),
+			io__write_string(", ")
+		;
+			io__write_string("MR_strip_tag(")
+		),
+		mlds_output_rval(Rval),
+		io__write_string(")")
+	),
+	io__write_string("->"),
+	mlds_output_fully_qualified_name(FieldId, io__write_string).
 mlds_output_lval(mem_ref(Rval)) -->
 	io__write_string("*"),
 	mlds_output_bracketed_rval(Rval).
@@ -935,9 +981,18 @@
 :- mode mlds_output_bracketed_rval(in, di, uo) is det.
 
 mlds_output_bracketed_rval(Rval) -->
-	io__write_char('('),
-	mlds_output_rval(Rval),
-	io__write_char(')').
+	(
+		% if it's just a variable name, then we don't need parentheses
+		{ Rval = lval(var(_))
+		; Rval = const(code_addr_const(_))
+		}
+	->
+		mlds_output_rval(Rval)
+	;
+		io__write_char('('),
+		mlds_output_rval(Rval),
+		io__write_char(')')
+	).
 
 :- pred mlds_output_rval(mlds__rval, io__state, io__state).
 :- mode mlds_output_rval(in, di, uo) is det.
@@ -968,7 +1023,7 @@
 ****/
 
 mlds_output_rval(mkword(Tag, Rval)) -->
-	io__write_string("MR_mkword("),
+	io__write_string("(Word) MR_mkword("),
 	mlds_output_tag(Tag),
 	io__write_string(", "),
 	mlds_output_rval(Rval),

-- 
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