[m-dev.] diff: MLDS back-end: optimize static ground terms

Fergus Henderson fjh at cs.mu.OZ.AU
Tue May 23 01:59:10 AEST 2000


Estimated hours taken: 16

Implement static allocation of grounds terms for the
MLDS back-end.

compiler/hlds_goal.m:
	Change the `maybe(cell_to_reuse)' field of `construct'
	unifications from a `maybe(cell_to_reuse)' into a
	`how_to_construct' type with three alternatives,
	`reuse_cell(cell_to_reuse)', `construct_dynamically',
	and the new alternative `construct_statically(static_cons)'.
	`static_cons' is a new type that provides information on
	how to construct a static ground term.

compiler/goal_util.m:
compiler/lambda.m:
compiler/magic.m:
compiler/magic_util.m:
compiler/modecheck_unify.m:
compiler/polymorphism.m:
compiler/quantification.m:
	Trivial changes to handle the change to the `maybe(cell_to_reuse)'
	field of `construct' unifications.

compiler/mark_static_terms.m:
	New module.  This traverses the HLDS and marks terms which can
	be construction unifications which can be allocated statically
	with the `construct_statically' flag.

compiler/mercury_compile.m:
	For the MLDS back-end, if the static_ground_terms option is set,
	invoke the mark_static_terms pass.

compiler/ml_unify_gen.m:
	When generating code for construction unifications, pass down
	the `how_to_reuse' field.  If this is `construct_statically',
	then generate a local initialized static constant, rather than
	using `new_object' to allocate the memory dynamically.
	(This required some fairly substantial reorganization.
	I changed ml_gen_construct so that no_tag types and compound
	terms, including closures, are handled separately from
	constants.  I moved some of the code from ml_gen_construct_rep
	into ml_gen_construct, and the remainder, which deals with
	constants, was simplified and renamed ml_get_constant.  The
	code for constructing closures was moved into a separate
	predicate ml_gen_closure, and was simplified by elimination of
	some code duplication.  I also added a bunch of new procedures
	for generating static constants.)

compiler/mlds.m:
	Add a new alternative `mlds__array_type' to the mlds__type type.
	This is needed by ml_unify_gen.m for static constants.

compiler/mlds_to_c.m:
	Handle `mlds__array_type'.  This required splitting
	mlds_output_type into mlds_output_type_prefix and
	mlds_output_type_suffix.

compiler/ml_code_util.m:
	Reorder the code slightly, to improve readability.

Workspace: /home/pgrad/fjh/ws/hg2
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.61
diff -u -d -r1.61 goal_util.m
--- compiler/goal_util.m	2000/02/10 04:47:40	1.61
+++ compiler/goal_util.m	2000/05/21 08:14:37
@@ -431,16 +431,21 @@
 :- mode goal_util__rename_unify(in, in, in, out) is det.
 
 goal_util__rename_unify(
-		construct(Var0, ConsId, Vars0, Modes, Reuse0, Uniq, Aditi),
+		construct(Var0, ConsId, Vars0, Modes, How0, Uniq, Aditi),
 		Must, Subn,
-		construct(Var, ConsId, Vars, Modes, Reuse, Uniq, Aditi)) :-
+		construct(Var, ConsId, Vars, Modes, How, Uniq, Aditi)) :-
 	goal_util__rename_var(Var0, Must, Subn, Var),
 	goal_util__rename_var_list(Vars0, Must, Subn, Vars),
-	( Reuse0 = yes(cell_to_reuse(ReuseVar0, B, C)) ->
+	(
+		How0 = reuse_cell(cell_to_reuse(ReuseVar0, B, C)),
 		goal_util__rename_var(ReuseVar0, Must, Subn, ReuseVar),
-		Reuse = yes(cell_to_reuse(ReuseVar, B, C))
+		How = reuse_cell(cell_to_reuse(ReuseVar, B, C))
 	;
-		Reuse = no
+		How0 = construct_dynamically,
+		How = How0
+	;
+		How0 = construct_statically(_),
+		How = How0
 	).
 goal_util__rename_unify(deconstruct(Var0, ConsId, Vars0, Modes, Cat),
 		Must, Subn, deconstruct(Var, ConsId, Vars, Modes, Cat)) :-
@@ -556,7 +561,7 @@
 goal_util__goal_vars_2(unify(Var, RHS, _, Unif, _), Set0, Set) :-
 	set__insert(Set0, Var, Set1),
 	( Unif = construct(_, _, _, _, CellToReuse, _, _) ->
-		( CellToReuse = yes(cell_to_reuse(Var, _, _)) ->
+		( CellToReuse = reuse_cell(cell_to_reuse(Var, _, _)) ->
 			set__insert(Set1, Var, Set2)
 		;
 			Set2 = Set1
@@ -898,8 +903,8 @@
 goal_expr_contains_reconstruction(some(_, _, Goal)) :-
 	goal_contains_reconstruction(Goal).
 goal_expr_contains_reconstruction(unify(_, _, _, Unify, _)) :-
-	Unify = construct(_, _, _, _, Reuse, _, _),
-	Reuse = yes(_).
+	Unify = construct(_, _, _, _, HowToConstruct, _, _),
+	HowToConstruct = reuse_cell(_).
 
 :- pred goals_contain_reconstruction(list(hlds_goal)).
 :- mode goals_contain_reconstruction(in) is semidet.
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.70
diff -u -d -r1.70 hlds_goal.m
--- compiler/hlds_goal.m	2000/05/05 06:07:44	1.70
+++ compiler/hlds_goal.m	2000/05/22 07:47:38
@@ -423,11 +423,14 @@
 					% expression, this is the list of
 					% modes of the non-local variables
 					% of the lambda expression.
-			maybe(cell_to_reuse),
-					% Cell to destructively update.
+			how_to_construct,
+					% Specify whether to allocate
+					% statically, to allocate dynamically,
+					% or to reuse an existing cell
+					% (and if so, which cell).
 					% Constructions for which this
-					% field is `yes(_)' are described
-					% as "reconstructions".
+					% field is `reuse_cell(_)' are
+					% described as "reconstructions".
 			cell_is_unique,	% Can the cell be allocated
 					% in shared data.
 			maybe(rl_exprn_id)
@@ -571,6 +574,36 @@
 			unify_context	% the context of the unification
 		).
 
+	% Information on how to construct the cell for a
+	% construction unification.  The `construct_statically'
+	% alternative is set by the `mark_static_terms.m' pass,
+	% and is currently only used for the MLDS back-end
+	% (for the LLDS back-end, the same optimization is
+	% handled by code_exprn.m).
+	% The `reuse_cell' alternative is not yet used.
+:- type how_to_construct
+	--->	construct_statically(		% Use a statically initialized
+						% constant
+			args :: list(static_cons)
+		)
+	;	construct_dynamically		% Allocate a new term on the
+						% heap
+	;	reuse_cell(cell_to_reuse)	% Reuse an existing heap cell
+	.
+
+	% Information on how to construct an argument for
+	% a static construction unification.  Each such
+	% argument must itself have been constructed
+	% statically; we store here a subset of the fields
+	% of the original `construct' unification for the arg.
+	% This is used by the MLDS back-end.
+:- type static_cons
+	--->	static_cons(
+			cons_id,		% the cons_id of the functor
+			list(prog_var),		% the list of arg variables
+			list(static_cons)	% how to construct the args
+		).
+
 	% Information used to perform structure reuse on a cell.
 :- type cell_to_reuse
 	---> cell_to_reuse(
@@ -1528,10 +1561,9 @@
 	RHS = functor(ConsId, []),
 	Inst = bound(unique, [functor(ConsId, [])]),
 	Mode = (free -> Inst) - (Inst -> Inst),
-	VarToReuse = no,
 	RLExprnId = no,
 	Unification = construct(Var, ConsId, [], [],
-		VarToReuse, cell_is_unique, RLExprnId),
+		construct_dynamically, cell_is_unique, RLExprnId),
 	Context = unify_context(explicit, []),
 	Goal = unify(Var, RHS, Mode, Unification, Context),
 	set__singleton_set(NonLocals, Var),
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.61
diff -u -d -r1.61 lambda.m
--- compiler/lambda.m	2000/05/11 06:04:01	1.61
+++ compiler/lambda.m	2000/05/18 04:50:12
@@ -549,10 +549,9 @@
 	Functor = functor(cons(PredName, NumArgVars), ArgVars),
 	ConsId = pred_const(PredId, ProcId, EvalMethod),
 
-	VarToReuse = no,
 	RLExprnId = no,
 	Unification = construct(Var, ConsId, ArgVars, UniModes,
-		VarToReuse, cell_is_unique, RLExprnId),
+		construct_dynamically, cell_is_unique, RLExprnId),
 	LambdaInfo = lambda_info(VarSet, VarTypes, Constraints, TVarSet,
 		TVarMap, TCVarMap, Markers, POF, OrigPredName, Owner,
 		ModuleInfo, MustRecomputeNonLocals).
Index: compiler/magic.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic.m,v
retrieving revision 1.17
diff -u -d -r1.17 magic.m
--- compiler/magic.m	2000/05/05 02:42:10	1.17
+++ compiler/magic.m	2000/05/18 04:54:02
@@ -1202,10 +1202,9 @@
 	instmap_delta_init_reachable(Delta0),
 	instmap_delta_insert(Delta0, Var, Inst, Delta),
 	UnifyMode = (free -> Inst) - (Inst -> Inst),
-	ReuseVar = no,
 	RLExprnId = no,
 	Uni = construct(Var, ConsId, [], [],
-		ReuseVar, cell_is_unique, RLExprnId),
+		construct_dynamically, cell_is_unique, RLExprnId),
 	Context = unify_context(explicit, []),
 	goal_info_init(NonLocals, Delta, det, GoalInfo),
 	Goal = unify(Var, functor(ConsId, []), UnifyMode, Uni, Context) -
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.9
diff -u -d -r1.9 magic_util.m
--- compiler/magic_util.m	2000/05/08 06:20:57	1.9
+++ compiler/magic_util.m	2000/05/18 04:56:41
@@ -489,10 +489,9 @@
 		{ Rhs = functor(cons(qualified(PredModule, PredName),
 				Arity), InputVars) },
 
-		{ VarToReuse = no },
 		{ RLExprnId = no },
 		{ Uni = construct(Var, ConsId, InputVars, Modes,
-			VarToReuse, cell_is_unique, RLExprnId) },
+			construct_dynamically, cell_is_unique, RLExprnId) },
 		{ Goal1 = unify(Var, Rhs, UniMode, Uni, Context) - Info },
 
 		{ list__append(InputGoals, [Goal1], InputAndClosure) }
@@ -828,11 +827,10 @@
 		{ Rhs = functor(cons(qualified(SuppModule, SuppName), 
 				SuppArity), LambdaInputs) },
 
-		{ VarToReuse = no },
 		{ RLExprnId = no },
 		{ Unify = construct(InputVar, 
 			pred_const(SuppPredId, SuppProcId, (aditi_bottom_up)), 
-			LambdaInputs, UniModes, VarToReuse,
+			LambdaInputs, UniModes, construct_dynamically,
 			cell_is_unique, RLExprnId) },
 		{ UnifyContext = unify_context(explicit, []) },
 
cvs diff: compiler/mark_static_terms.m is a new entry, no comparison available
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.163
diff -u -d -r1.163 mercury_compile.m
--- compiler/mercury_compile.m	2000/05/16 21:23:26	1.163
+++ compiler/mercury_compile.m	2000/05/22 07:28:17
@@ -60,10 +60,11 @@
 :- import_module bytecode_gen, bytecode.
 
 	% the MLDS back-end
-:- import_module mlds.
-:- import_module ml_code_gen, ml_elim_nested, ml_tailcall.
-:- import_module rtti_to_mlds.
-:- import_module mlds_to_c.
+:- import_module mark_static_terms.		% HLDS -> HLDS
+:- import_module mlds.				% MLDS data structure
+:- import_module ml_code_gen, rtti_to_mlds.	% HLDS/RTTI -> MLDS
+:- import_module ml_elim_nested, ml_tailcall.	% MLDS -> MLDS
+:- import_module mlds_to_c.			% MLDS -> C
 
 	% miscellaneous compiler modules
 :- import_module prog_data, hlds_module, hlds_pred, hlds_out, llds, rl.
@@ -1496,6 +1497,27 @@
 
 %-----------------------------------------------------------------------------%
 
+:- pred mercury_compile__maybe_mark_static_terms(module_info, bool, bool,
+		module_info, io__state, io__state).
+:- mode mercury_compile__maybe_mark_static_terms(in, in, in, out, di, uo)
+		is det.
+
+mercury_compile__maybe_mark_static_terms(HLDS0, Verbose, Stats, HLDS) -->
+	globals__io_lookup_bool_option(static_ground_terms, StaticGroundTerms),
+	( { StaticGroundTerms = yes } ->
+		maybe_write_string(Verbose,
+			"% Marking static ground terms...\n"),
+		maybe_flush_output(Verbose),
+		process_all_nonimported_procs(update_proc(mark_static_terms),
+			HLDS0, HLDS),
+		maybe_write_string(Verbose, "% done.\n"),
+		maybe_report_stats(Stats)
+	;
+		{ HLDS = HLDS0 }
+	).
+
+%-----------------------------------------------------------------------------%
+
 :- pred mercury_compile__maybe_write_dependency_graph(module_info, bool, bool,
 	module_info, io__state, io__state).
 :- mode mercury_compile__maybe_write_dependency_graph(in, in, in, out, di, uo)
@@ -2253,7 +2275,11 @@
 		process_all_nonimported_nonaditi_procs, HLDS53),
 	mercury_compile__maybe_dump_hlds(HLDS53, "53", "simplify2"),
 
-	{ HLDS = HLDS53 },
+	mercury_compile__maybe_mark_static_terms(HLDS53, Verbose, Stats,
+		HLDS60),
+	mercury_compile__maybe_dump_hlds(HLDS60, "60", "mark_static"),
+
+	{ HLDS = HLDS60 },
 	mercury_compile__maybe_dump_hlds(HLDS, "99", "final"),
 
 	maybe_write_string(Verbose, "% Converting HLDS to MLDS...\n"),
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.13
diff -u -d -r1.13 ml_code_util.m
--- compiler/ml_code_util.m	2000/05/17 18:02:15	1.13
+++ compiler/ml_code_util.m	2000/05/18 07:14:02
@@ -962,13 +962,15 @@
 		{ Lval = var(qual(MLDS_Module, "dummy_var")) }
 	;
 		=(MLDSGenInfo),
-		{ ml_gen_info_get_output_vars(MLDSGenInfo, OutputVars) },
 		{ ml_gen_info_get_varset(MLDSGenInfo, VarSet) },
 		{ VarName = ml_gen_var_name(VarSet, Var) },
 		ml_qualify_var(VarName, VarLval),
-		{ MLDS_Type = mercury_type_to_mlds_type(Type) },
+		%
 		% output variables are passed by reference...
+		%
+		{ ml_gen_info_get_output_vars(MLDSGenInfo, OutputVars) },
 		{ list__member(Var, OutputVars) ->
+			MLDS_Type = mercury_type_to_mlds_type(Type),
 			Lval = mem_ref(lval(VarLval), MLDS_Type)
 		;
 			Lval = VarLval
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.23
diff -u -d -r1.23 mlds.m
--- compiler/mlds.m	2000/05/10 18:06:55	1.23
+++ compiler/mlds.m	2000/05/22 06:14:16
@@ -482,6 +482,15 @@
 		% MLDS types defined using mlds__class_defn
 	;	mlds__class_type(mlds__class, arity)	% name, arity
 
+		% MLDS array types.
+		% These are single-dimensional, and can be indexed
+		% using the `field' lval with an `offset' field_id;
+		% indices start at zero.
+		% Currently these are used for static constants
+		% that would otherwise be allocated with a `new_object'
+		% statement.
+	;	mlds__array_type(mlds__type)
+
 		% Pointer types.
 		% Currently these are used for handling output arguments.
 	;	mlds__ptr_type(mlds__type)
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.31
diff -u -d -r1.31 mlds_to_c.m
--- compiler/mlds_to_c.m	2000/05/11 21:10:31	1.31
+++ compiler/mlds_to_c.m	2000/05/22 06:48:55
@@ -433,9 +433,10 @@
 :- mode mlds_output_data_decl(in, in, di, uo) is det.
 
 mlds_output_data_decl(Name, Type) -->
-	mlds_output_type(Type),
+	mlds_output_type_prefix(Type),
 	io__write_char(' '),
-	mlds_output_fully_qualified_name(Name).
+	mlds_output_fully_qualified_name(Name),
+	mlds_output_type_suffix(Type).
 
 :- pred mlds_output_data_defn(mlds__qualified_entity_name, mlds__type,
 			mlds__initializer, io__state, io__state).
@@ -590,13 +591,18 @@
 	( { RetTypes = [] } ->
 		io__write_string("void")
 	; { RetTypes = [RetType] } ->
-		mlds_output_type(RetType)
+		mlds_output_type_prefix(RetType)
 	;
 		{ error("mlds_output_func: multiple return types") }
 	),
 	io__write_char(' '),
 	mlds_output_fully_qualified_name(Name),
-	mlds_output_params(Indent, Name, Parameters).
+	mlds_output_params(Indent, Name, Parameters),
+	( { RetTypes = [RetType2] } ->
+		mlds_output_type_suffix(RetType2)
+	;
+		[]
+	).
 
 :- pred mlds_output_params(indent, qualified_entity_name, mlds__arguments,
 		io__state, io__state).
@@ -617,23 +623,31 @@
 :- mode mlds_output_param(in, in, in, di, uo) is det.
 
 mlds_output_param(_Indent, qual(ModuleName, _FuncName), Name - Type) -->
-	mlds_output_type(Type),
-	io__write_char(' '),
-	mlds_output_fully_qualified_name(qual(ModuleName, Name)).
+	mlds_output_data_decl(qual(ModuleName, Name), Type).
 
-:- pred mlds_output_func_type(func_params, io__state, io__state).
-:- mode mlds_output_func_type(in, di, uo) is det.
+:- pred mlds_output_func_type_prefix(func_params, io__state, io__state).
+:- mode mlds_output_func_type_prefix(in, di, uo) is det.
 
-mlds_output_func_type(Params) -->
-	{ Params = mlds__func_params(Parameters, RetTypes) },
+mlds_output_func_type_prefix(Params) -->
+	{ Params = mlds__func_params(_Parameters, RetTypes) },
 	( { RetTypes = [] } ->
 		io__write_string("void")
 	; { RetTypes = [RetType] } ->
 		mlds_output_type(RetType)
 	;
-		{ error("mlds_output_func_type: multiple return types") }
+		{ error("mlds_output_func_type_prefix: multiple return types") }
 	),
-	io__write_string(" (*)"),
+	% Note that mlds__func_type actually corresponds to a
+	% function _pointer_ type in C.  This is necessary because
+	% function types in C are not first class.
+	io__write_string(" (*").
+
+:- pred mlds_output_func_type_suffix(func_params, io__state, io__state).
+:- mode mlds_output_func_type_suffix(in, di, uo) is det.
+
+mlds_output_func_type_suffix(Params) -->
+	{ Params = mlds__func_params(Parameters, _RetTypes) },
+	io__write_string(")"),
 	mlds_output_param_types(Parameters).
 
 :- pred mlds_output_param_types(mlds__arguments, io__state, io__state).
@@ -811,10 +825,26 @@
 % Code to output types
 %
 
+%
+% Because of the joys of C syntax, the code for outputting
+% types needs to be split into two parts; first the prefix,
+% i.e. the part of the type name that goes before the variable
+% name in a variable declaration, and then the suffix, i.e.
+% the part which goes after the variable name, e.g. the "[]"
+% for array types.
+%
+
 :- pred mlds_output_type(mlds__type, io__state, io__state).
 :- mode mlds_output_type(in, di, uo) is det.
 
-mlds_output_type(mercury_type(Type)) -->
+mlds_output_type(Type) -->
+	mlds_output_type_prefix(Type),
+	mlds_output_type_suffix(Type).
+
+:- pred mlds_output_type_prefix(mlds__type, io__state, io__state).
+:- mode mlds_output_type_prefix(in, di, uo) is det.
+
+mlds_output_type_prefix(mercury_type(Type)) -->
 	( { Type = term__functor(term__atom("character"), [], _) } ->
 		io__write_string("Char")
 	; { Type = term__functor(term__atom("int"), [], _) } ->
@@ -830,46 +860,67 @@
 		% so that distinct Mercury types map to distinct C types
 		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").
-mlds_output_type(mlds__native_bool_type)  --> io__write_string("bool").
-mlds_output_type(mlds__native_char_type)  --> io__write_string("char").
-mlds_output_type(mlds__class_type(Name, Arity)) -->
+mlds_output_type_prefix(mlds__native_int_type)   --> io__write_string("int").
+mlds_output_type_prefix(mlds__native_float_type) --> io__write_string("float").
+mlds_output_type_prefix(mlds__native_bool_type)  --> io__write_string("bool").
+mlds_output_type_prefix(mlds__native_char_type)  --> io__write_string("char").
+mlds_output_type_prefix(mlds__class_type(Name, Arity)) -->
 	io__write_string("struct "),
 	mlds_output_fully_qualified(Name, io__write_string),
 	io__format("_%d", [i(Arity)]).
-mlds_output_type(mlds__ptr_type(Type)) -->
+mlds_output_type_prefix(mlds__ptr_type(Type)) -->
 	mlds_output_type(Type),
 	io__write_string(" *").
-mlds_output_type(mlds__func_type(FuncParams)) -->
-	% XXX C syntax sucks, there's no easy way of
-	% writing these types that will work in all
-	% situations.  Currently we rely on the MLDS code
-	% generator only using function types in certain situations.
-	mlds_output_func_type(FuncParams).
-mlds_output_type(mlds__generic_type) -->
+mlds_output_type_prefix(mlds__array_type(Type)) -->
+	% Here we just output the element type.
+	% The "[]" goes in the type suffix.
+	mlds_output_type(Type).
+mlds_output_type_prefix(mlds__func_type(FuncParams)) -->
+	mlds_output_func_type_prefix(FuncParams).
+mlds_output_type_prefix(mlds__generic_type) -->
 	io__write_string("MR_Box").
-mlds_output_type(mlds__generic_env_ptr_type) -->
+mlds_output_type_prefix(mlds__generic_env_ptr_type) -->
 	io__write_string("void *").
-mlds_output_type(mlds__pseudo_type_info_type) -->
+mlds_output_type_prefix(mlds__pseudo_type_info_type) -->
 	io__write_string("MR_PseudoTypeInfo").
-mlds_output_type(mlds__cont_type) -->
+mlds_output_type_prefix(mlds__cont_type) -->
 	globals__io_lookup_bool_option(gcc_nested_functions, GCC_NestedFuncs),
 	( { GCC_NestedFuncs = yes } ->
 		io__write_string("MR_NestedCont")
 	;
 		io__write_string("MR_Cont")
 	).
-mlds_output_type(mlds__commit_type) -->
+mlds_output_type_prefix(mlds__commit_type) -->
 	globals__io_lookup_bool_option(gcc_local_labels, GCC_LocalLabels),
 	( { GCC_LocalLabels = yes } ->
 		io__write_string("__label__")
 	;
 		io__write_string("jmp_buf")
 	).
-mlds_output_type(mlds__rtti_type(RttiName)) -->
+mlds_output_type_prefix(mlds__rtti_type(RttiName)) -->
 	io__write_string("MR_"),
 	io__write_string(mlds_rtti_type_name(RttiName)).
+
+:- pred mlds_output_type_suffix(mlds__type, io__state, io__state).
+:- mode mlds_output_type_suffix(in, di, uo) is det.
+
+mlds_output_type_suffix(mercury_type(_)) --> [].
+mlds_output_type_suffix(mlds__native_int_type) --> [].
+mlds_output_type_suffix(mlds__native_float_type) --> [].
+mlds_output_type_suffix(mlds__native_bool_type) --> [].
+mlds_output_type_suffix(mlds__native_char_type) --> [].
+mlds_output_type_suffix(mlds__class_type(_, _)) --> [].
+mlds_output_type_suffix(mlds__ptr_type(_)) --> [].
+mlds_output_type_suffix(mlds__array_type(_)) -->
+	io__write_string("[]").
+mlds_output_type_suffix(mlds__func_type(FuncParams)) -->
+	mlds_output_func_type_suffix(FuncParams).
+mlds_output_type_suffix(mlds__generic_type) --> [].
+mlds_output_type_suffix(mlds__generic_env_ptr_type) --> [].
+mlds_output_type_suffix(mlds__pseudo_type_info_type) --> [].
+mlds_output_type_suffix(mlds__cont_type) --> [].
+mlds_output_type_suffix(mlds__commit_type) --> [].
+mlds_output_type_suffix(mlds__rtti_type(_)) --> [].
 
 %-----------------------------------------------------------------------------%
 %
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.9
diff -u -d -r1.9 ml_unify_gen.m
--- compiler/ml_unify_gen.m	2000/05/17 16:01:40	1.9
+++ compiler/ml_unify_gen.m	2000/05/22 15:32:04
@@ -79,7 +79,7 @@
 :- import_module rtti.
 :- import_module code_util. % XXX needed for `code_util__cons_id_to_tag'.
 
-:- import_module int, string, list, require, std_util, term, varset.
+:- import_module bool, int, string, list, require, std_util, term, varset.
 
 %-----------------------------------------------------------------------------%
 
@@ -122,7 +122,7 @@
 	ml_gen_set_success(Test, Context, MLDS_Statement).
 
 ml_gen_unification(construct(Var, ConsId, Args, ArgModes,
-		MaybeCellToReuse, _CellIsUnique, MaybeAditiRLExprnID),
+		HowToConstruct, _CellIsUnique, MaybeAditiRLExprnID),
 		CodeModel, Context, MLDS_Decls, MLDS_Statements) -->
 	{ require(unify(CodeModel, model_det),
 		"ml_code_gen: construct not det") },
@@ -131,12 +131,12 @@
 	;
 		true
 	},
-	{ MaybeCellToReuse = yes(_) ->
+	{ HowToConstruct = reuse_cell(_) ->
 		sorry("cell reuse")
 	;
 		true
 	},
-	ml_gen_construct(Var, ConsId, Args, ArgModes, Context,
+	ml_gen_construct(Var, ConsId, Args, ArgModes, HowToConstruct, Context,
 		MLDS_Decls, MLDS_Statements).
 ml_gen_unification(deconstruct(Var, ConsId, Args, ArgModes, CanFail),
 		CodeModel, Context, MLDS_Decls, MLDS_Statements) -->
@@ -157,107 +157,169 @@
 ml_gen_unification(complicated_unify(_, _, _), _, _, [], []) -->
 	% simplify.m should convert these into procedure calls
 	{ error("ml_code_gen: complicated unify") }.
-
 
+	% ml_gen_construct generations code for a construction unification.
+	%
+	% Note that the code for ml_gen_static_const_arg is very similar to
+	% the code here, and any changes may need to be done in both places.
+	%
 :- pred ml_gen_construct(prog_var, cons_id, prog_vars, list(uni_mode),
-		prog_context, mlds__defns, mlds__statements,
+		how_to_construct, prog_context, mlds__defns, mlds__statements,
 		ml_gen_info, ml_gen_info).
-:- mode ml_gen_construct(in, in, in, in, in, out, out, in, out) is det.
+:- mode ml_gen_construct(in, in, in, in, in, in, out, out, in, out) is det.
 
-ml_gen_construct(Var, ConsId, Args, ArgModes, Context,
+ml_gen_construct(Var, ConsId, Args, ArgModes, HowToConstruct, Context,
 		MLDS_Decls, MLDS_Statements) -->
 	%
 	% figure out how this cons_id is represented
 	%
 	ml_variable_type(Var, Type),
 	ml_cons_id_to_tag(ConsId, Type, Tag),
-	%
-	% generate code to construct the specified representation
-	%
-	ml_gen_construct_rep(Tag, ConsId, Var, Args, ArgModes, Context,
-			MLDS_Decls, 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, in, out, out, in, out) is det.
-
-ml_gen_construct_rep(string_constant(String), _, Var, Args, _ArgModes, Context,
-		[], [MLDS_Statement]) -->
-	( { Args = [] } ->
-		[]
+	(
+		%
+		% no_tag types
+		%
+		{ Tag = no_tag }
+	->
+		( { Args = [Arg], ArgModes = [ArgMode] } ->
+			ml_variable_type(Arg, ArgType),
+			ml_variable_type(Var, VarType),
+			ml_gen_var(Arg, ArgLval),
+			ml_gen_var(Var, VarLval),
+			ml_gen_sub_unify(ArgMode, ArgLval, ArgType, VarLval,
+				VarType, Context, [], MLDS_Statements),
+			{ MLDS_Decls = [] }
+		;
+			{ error("ml_code_gen: no_tag: arity != 1") }
+		)
 	;
-		{ error("ml_code_gen: string constant has args") }
-	),
-	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,
-		[], [MLDS_Statement]) -->
-	( { Args = [] } ->
-		[]
+		%
+		% lambda expressions
+		%
+		{ Tag = pred_closure_tag(PredId, ProcId, EvalMethod) }
+	->
+		ml_gen_closure(PredId, ProcId, EvalMethod, Var, Args,
+				ArgModes, HowToConstruct, Context,
+				MLDS_Decls, MLDS_Statements)
 	;
-		{ error("ml_code_gen: int constant has args") }
-	),
-	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,
-		[], [MLDS_Statement]) -->
-	( { Args = [] } ->
-		[]
+		%
+		% ordinary compound terms
+		%
+		{ Tag = unshared_tag(TagVal),
+		  MaybeSecondaryTag = no
+		; Tag = shared_remote_tag(TagVal, SecondaryTag),
+		  MaybeSecondaryTag = yes(SecondaryTag)
+		}
+	->
+		ml_gen_compound(TagVal, MaybeSecondaryTag, ConsId, Var, Args,
+			ArgModes, HowToConstruct, Context,
+			MLDS_Decls, MLDS_Statements)
 	;
-		{ error("ml_code_gen: float constant has args") }
-	),
-	ml_gen_var(Var, VarLval),
-	{ MLDS_Statement = ml_gen_assign(VarLval, const(float_const(Float)),
-		Context) }.
-
-ml_gen_construct_rep(no_tag, _ConsId, Var, Args, Modes, Context,
-		MLDS_Decls, MLDS_Statements) -->
-	( { Args = [Arg], Modes = [Mode] } ->
-		ml_variable_type(Arg, ArgType),
-		ml_variable_type(Var, VarType),
-		ml_gen_var(Arg, ArgLval),
+		%
+		% constants
+		%
+		{ Args = [] }
+	->
 		ml_gen_var(Var, VarLval),
-		ml_gen_sub_unify(Mode, ArgLval, ArgType, VarLval, VarType,
-			Context, [], MLDS_Statements),
-		{ MLDS_Decls = [] }
+		ml_gen_constant(Tag, Type, Rval),
+		{ MLDS_Statement = ml_gen_assign(VarLval, Rval, Context) },
+		{ MLDS_Decls = [] },
+		{ MLDS_Statements = [MLDS_Statement] }
 	;
-		{ error("ml_code_gen: no_tag: arity != 1") }
+		{ error("ml_gen_construct: unknown compound term") }
 	).
 
-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_static_const_arg is similar to ml_gen_construct
+	% with HowToConstruct = construct_statically(_),
+	% except that for compound terms, rather than generating
+	% a new static constant, it just generates a reference
+	% to one that has already been defined.
+	%
+	% Note that any changes here may require similar changes to
+	% ml_gen_construct.
+	%
+:- pred ml_gen_static_const_arg(prog_var, static_cons, mlds__rval,
+	ml_gen_info, ml_gen_info).
+:- mode ml_gen_static_const_arg(in, in, out, in, out) is det.
 
-ml_gen_construct_rep(shared_local_tag(Bits1, Num1), _ConsId, Var, Args,
-		_ArgModes, Context, [], [MLDS_Statement]) -->
-	( { Args = [] } ->
-		[]
-	;
-		{ error("ml_code_gen: shared_local_tag constant has args") }
-	),
-	ml_gen_var(Var, VarLval),
-	{ MLDS_Statement = ml_gen_assign(VarLval, 
-		mkword(Bits1, unop(std_unop(mkbody), const(int_const(Num1)))),
-		Context) }.
+ml_gen_static_const_arg(Var, static_cons(ConsId, ArgVars, StaticArgs), Rval) -->
+	%
+	% figure out how this argument is represented
+	%
+	ml_variable_type(Var, VarType),
+	ml_cons_id_to_tag(ConsId, VarType, Tag),
 
-ml_gen_construct_rep(type_ctor_info_constant(ModuleName0, TypeName, TypeArity),
-		_ConsId, Var, Args, _ArgModes, Context,
-		[], [MLDS_Statement]) -->
-	( { Args = [] } ->
-		[]
+	(
+		%
+		% no_tag types
+		%
+		{ Tag = no_tag }
+	->
+		( { ArgVars = [Arg], StaticArgs = [StaticArg] } ->
+			% construct (statically) the argument,
+			% and then convert it to the appropriate type
+			ml_gen_static_const_arg(Arg, StaticArg, ArgRval),
+			ml_variable_type(Arg, ArgType),
+			{ ml_gen_box_or_unbox_rval(ArgType, VarType,
+				ArgRval, Rval) }
+		;
+			{ error("ml_code_gen: no_tag: arity != 1") }
+		)
 	;
-		{ error("ml_code_gen: type-info constant has args") }
-	),
-	ml_gen_var(Var, VarLval),
+		%
+		% compound terms, including lambda expressions
+		%
+		{ Tag = pred_closure_tag(_, _, _), TagVal = 0
+		; Tag = unshared_tag(TagVal)
+		; Tag = shared_remote_tag(TagVal, _SecondaryTag)
+		}
+	->
+		%
+		% If this argument is something that would normally be allocated
+		% on the heap, just generate a reference to the static constant
+		% that we must have already generated for it.
+		%
+		ml_gen_static_const_addr(Var, ConstAddrRval),
+		{ TagVal = 0 ->
+			TaggedRval = ConstAddrRval
+		;
+			TaggedRval = mkword(TagVal, ConstAddrRval)
+		},
+		{ Rval = unop(cast(mercury_type(VarType)), TaggedRval) }
+	;
+		%
+		% If this argument is just a constant,
+		% then generate the rval for the constant
+		%
+		{ StaticArgs = [] }
+	->
+		ml_gen_constant(Tag, VarType, Rval)
+	;
+		{ error("ml_gen_static_const_arg: unknown compound term") }
+	).
+
+	%
+	% generate the rval for a given constant
 	%
+:- pred ml_gen_constant(cons_tag, prog_type, mlds__rval,
+		ml_gen_info, ml_gen_info).
+:- mode ml_gen_constant(in, in, out, in, out) is det.
+
+ml_gen_constant(string_constant(String), _, const(string_const(String)))
+	--> [].
+
+ml_gen_constant(int_constant(Int), _, const(int_const(Int))) --> [].
+
+ml_gen_constant(float_constant(Float), _, const(float_const(Float))) --> [].
+
+ml_gen_constant(shared_local_tag(Bits1, Num1), _, Rval) -->
+	{ Rval = mkword(Bits1,
+		unop(std_unop(mkbody), const(int_const(Num1)))) }.
+
+ml_gen_constant(type_ctor_info_constant(ModuleName0, TypeName, TypeArity),
+		VarType, Rval) -->
+	%
 	% Although the builtin types `int', `float', etc. are treated as part
 	% of the `builtin' module, for historical reasons they don't have
 	% any qualifiers at this point, so we need to add the `builtin'
@@ -272,63 +334,52 @@
 	{ RttiTypeId = rtti_type_id(ModuleName, TypeName, TypeArity) },
 	{ DataAddr = data_addr(MLDS_Module,
 		rtti(RttiTypeId, type_ctor_info)) },
-	ml_variable_type(Var, VarType),
-	{ MLDS_Statement = ml_gen_assign(VarLval, 
-		unop(cast(mercury_type(VarType)),
-			const(data_addr_const(DataAddr))),
-		Context) }.
-ml_gen_construct_rep(base_typeclass_info_constant(ModuleName, ClassId,
-			Instance), _ConsId, Var, Args, _ArgModes, Context,
-		[], [MLDS_Statement]) -->
-	( { Args = [] } ->
-		[]
-	;
-		{ error("ml_code_gen: typeclass-info constant has args") }
-	),
-	ml_gen_var(Var, VarLval),
+	{ Rval = unop(cast(mercury_type(VarType)),
+			const(data_addr_const(DataAddr))) }.
+
+ml_gen_constant(base_typeclass_info_constant(ModuleName, ClassId,
+			Instance), VarType, Rval) -->
 	{ MLDS_Module = mercury_module_name_to_mlds(ModuleName) },
 	{ DataAddr = data_addr(MLDS_Module,
 		base_typeclass_info(ClassId, Instance)) },
-	ml_variable_type(Var, VarType),
-	{ MLDS_Statement = ml_gen_assign(VarLval, 
-		unop(cast(mercury_type(VarType)),
-			const(data_addr_const(DataAddr))),
-		Context) }.
+	{ Rval = unop(cast(mercury_type(VarType)),
+			const(data_addr_const(DataAddr))) }.
 
-ml_gen_construct_rep(tabling_pointer_constant(PredId, ProcId), _ConsId,
-		Var, Args, _ArgModes, Context, [], [MLDS_Statement]) -->
-	( { Args = [] } ->
-		[]
-	;
-		{ error("ml_code_gen: tabling pointer constant has args") }
-	),
-	ml_gen_var(Var, VarLval),
+ml_gen_constant(tabling_pointer_constant(PredId, ProcId), VarType, Rval) -->
 	=(Info),
 	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
 	{ ml_gen_pred_label(ModuleInfo, PredId, ProcId,
 		PredLabel, PredModule) },
 	{ DataAddr = data_addr(PredModule,
 			tabling_pointer(PredLabel - ProcId)) },
-	ml_variable_type(Var, VarType),
-	{ MLDS_Statement = ml_gen_assign(VarLval, 
-		unop(cast(mercury_type(VarType)),
-			const(data_addr_const(DataAddr))),
-		Context) }.
+	{ Rval = unop(cast(mercury_type(VarType)),
+			const(data_addr_const(DataAddr))) }.
 
-ml_gen_construct_rep(code_addr_constant(PredId, ProcId), _ConsId,
-		Var, Args, _ArgModes, Context, [], [MLDS_Statement]) -->
-	( { Args = [] } ->
-		[]
-	;
-		{ error("ml_code_gen: address constant has args") }
-	),
-	ml_gen_var(Var, VarLval),
-	ml_gen_proc_addr_rval(PredId, ProcId, ProcAddrRval),
-	{ MLDS_Statement = ml_gen_assign(VarLval, ProcAddrRval, Context) }.
+ml_gen_constant(code_addr_constant(PredId, ProcId), _, ProcAddrRval) -->
+	ml_gen_proc_addr_rval(PredId, ProcId, ProcAddrRval).
 
-ml_gen_construct_rep(pred_closure_tag(PredId, ProcId, EvalMethod), _ConsId,
-		Var, ArgVars, ArgModes, Context,
-		MLDS_Decls, MLDS_Statements) -->
+% tags which are not (necessarily) constants are handled
+% in ml_gen_construct and ml_gen_static_const_arg,
+% so we don't need to handle them here.
+ml_gen_constant(no_tag, _, _) -->
+	{ error("ml_gen_constant: no_tag") }.
+ml_gen_constant(unshared_tag(_), _, _) -->
+	{ error("ml_gen_constant: unshared_tag") }.
+ml_gen_constant(shared_remote_tag(_, _), _, _) -->
+	{ error("ml_gen_constant: shared_remote_tag") }.
+ml_gen_constant(pred_closure_tag(_, _, _), _, _) -->
+	{ error("ml_gen_constant: pred_closure_tag") }.
+
+%-----------------------------------------------------------------------------%
+
+:- pred ml_gen_closure(pred_id, proc_id, lambda_eval_method, prog_var,
+		prog_vars, list(uni_mode), how_to_construct, prog_context,
+		mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
+:- mode ml_gen_closure(in, in, in, in, in, in, in, in, out, out, in, out)
+		is det.
+
+ml_gen_closure(PredId, ProcId, EvalMethod, Var, ArgVars, ArgModes,
+		HowToConstruct, Context, MLDS_Decls, MLDS_Statements) -->
 	% This constructs a closure.
 	% The representation of closures for the LLDS backend is defined in
 	% runtime/mercury_ho_call.h.
@@ -348,14 +399,6 @@
 	),
 
 	%
-	% Compute the lval where we will put the final result,
-	% and its type.
-	%
-	ml_gen_var(Var, VarLval),
-	ml_variable_type(Var, Type),
-	{ MLDS_Type = mercury_type_to_mlds_type(Type) },
-
-	%
 	% Generate a dummy value for the closure layout
 	% (we do this just to match the structure used
 	% by the LLDS closure representation)
@@ -383,17 +426,6 @@
 		Context, WrapperFuncRval, WrapperFuncType),
 
 	%
-	% 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) },
-
-	%
 	% Compute the rval which holds the number of arguments
 	%
 	{ NumArgsRval = const(int_const(NumArgs)) },
@@ -402,38 +434,22 @@
 	%
 	% the pointer will not be tagged (i.e. the tag will be zero)
 	%
-	{ MaybeTag = yes(0) },
+	{ Tag = 0 },
 	{ CtorName = "<closure>" },
 
 	%
-	% put all the arguments of the closure together
+	% put all the extra arguments of the closure together
 	%
-	{ ArgRvals = [ClosureLayoutRval, WrapperFuncRval, NumArgsRval
-		| ArgRvals0] },
-	{ MLDS_ArgTypes = [ClosureLayoutType, WrapperFuncType, NumArgsType
-			| MLDS_ArgTypes0] },
+	{ ExtraArgRvals = [ClosureLayoutRval, WrapperFuncRval, NumArgsRval] },
+	{ ExtraArgTypes = [ClosureLayoutType, WrapperFuncType, NumArgsType] },
 
-	%
-	% Compute the number of bytes to allocate
 	%
-	{ list__length(ArgRvals, TotalNumArgs) },
-	{ SizeInWordsRval = const(int_const(TotalNumArgs)) },
-	{ SizeOfWordRval = ml_sizeof_word_rval },
-	{ SizeInBytesRval = binop((*), SizeInWordsRval, SizeOfWordRval) },
-	
-	%
-	% Now put it all together.
+	% generate a `new_object' statement (or static constant)
+	% for the closure
 	%
-	{ MLDS_Decls = [] },
-	{ MakeNewObject = new_object(VarLval, 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] }.
-
-%-----------------------------------------------------------------------------%
+	ml_gen_new_object(Tag, CtorName, Var, ExtraArgRvals, ExtraArgTypes,
+			ArgVars, ArgModes, HowToConstruct, Context,
+			MLDS_Decls, MLDS_Statements).
 
 	%
 	% ml_gen_closure_wrapper:
@@ -730,6 +746,8 @@
 			NumClosureArgs, ClosureArgLvals0),
 		{ ClosureArgLvals = [FieldLval | ClosureArgLvals0] }
 	).
+
+%-----------------------------------------------------------------------------%
 		
 	% convert a cons_id for a given type to a cons_tag
 ml_cons_id_to_tag(ConsId, Type, Tag) -->
@@ -738,71 +756,280 @@
 	{ code_util__cons_id_to_tag(ConsId, Type, ModuleInfo, Tag) }.
 
 	% generate code to construct a new object
-:- pred ml_gen_new_object(mlds__tag, maybe(int), cons_id, prog_var, prog_vars,
-		list(uni_mode), prog_context, mlds__defns, mlds__statements,
+:- pred ml_gen_compound(mlds__tag, maybe(int), cons_id, prog_var, prog_vars,
+		list(uni_mode), how_to_construct, prog_context,
+		mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
+:- mode ml_gen_compound(in, in, in, in, in, in, in, in, out, out, in, out)
+		is det.
+
+ml_gen_compound(Tag, MaybeSecondaryTag, ConsId, Var, ArgVars, ArgModes,
+		HowToConstruct, Context, MLDS_Decls, MLDS_Statements) -->
+	ml_cons_name(ConsId, CtorName),
+	% 
+	% If there is a secondary tag, it goes in the first field
+	%
+	{ MaybeSecondaryTag = yes(SecondaryTag) ->
+		SecondaryTagRval = const(int_const(SecondaryTag)),
+		SecondaryTagType = mlds__native_int_type,
+		ExtraRvals = [SecondaryTagRval],
+		ExtraArgTypes = [SecondaryTagType]
+	;
+		ExtraRvals = [],
+		ExtraArgTypes = []
+	},
+	ml_gen_new_object(Tag, CtorName, Var, ExtraRvals, ExtraArgTypes,
+			ArgVars, ArgModes, HowToConstruct, Context,
+			MLDS_Decls, MLDS_Statements).
+
+	%
+	% ml_gen_new_object:
+	%	Generate a `new_object' statement, or a static constant,
+	%	depending on the value of the how_to_construct argument.
+	%	The `ExtraRvals' and `ExtraTypes' arguments specify
+	%	additional constants to insert at the start of the
+	%	argument list.
+	%
+:- pred ml_gen_new_object(mlds__tag, ctor_name, prog_var, list(mlds__rval),
+		list(mlds__type), prog_vars, list(uni_mode), how_to_construct,
+		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)
+:- mode ml_gen_new_object(in, in, 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) -->
+ml_gen_new_object(Tag, CtorName, Var, ExtraRvals, ExtraTypes,
+		ArgVars, ArgModes, HowToConstruct, Context,
+		MLDS_Decls, MLDS_Statements) -->
 	%
 	% Determine the variable's type and lval,
-	% and determine the constructor name and the tag to use.
+	% the tag to use, and the types of the argument vars.
 	%
 	ml_variable_type(Var, Type),
 	{ MLDS_Type = mercury_type_to_mlds_type(Type) },
-	ml_gen_var(Var, Lval),
-	ml_cons_name(ConsId, CtorName),
+	ml_gen_var(Var, VarLval),
 	{ 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__native_int_type,
-		ArgRvals = [SecondaryTagRval | ArgRvals0],
-		MLDS_ArgTypes = [SecondaryTagType | MLDS_ArgTypes0]
+	(
+		{ HowToConstruct = construct_dynamically },
+
+		%
+		% Generate rvals for the arguments
+		%
+		ml_gen_var_list(ArgVars, ArgLvals),
+		=(Info),
+		{ ml_gen_info_get_module_info(Info, ModuleInfo) },
+		{ ml_gen_cons_args(ArgLvals, ArgTypes, ArgModes, ModuleInfo,
+			ArgRvals0) },
+
+		%
+		% Insert the extra rvals at the start
+		%
+		{ list__append(ExtraRvals, ArgRvals0, ArgRvals) },
+		{ list__append(ExtraTypes, MLDS_ArgTypes0, MLDS_ArgTypes) },
+
+		%
+		% 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) },
+		
+		%
+		% Generate a `new_object' statement to dynamically allocate
+		% the memory for this term from the heap.  The `new_object'
+		% statement will also initialize the fields of this term
+		% with boxed versions of the specified arguments.
+		%
+		{ MakeNewObject = new_object(VarLval, 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 = [] }
 	;
-		ArgRvals = ArgRvals0,
-		MLDS_ArgTypes = MLDS_ArgTypes0
-	},
+		{ HowToConstruct = construct_statically(StaticArgs) },
+
+		%
+		% Generate rvals for the arguments
+		%
+		ml_gen_static_const_arg_list(ArgVars, StaticArgs, ArgRvals0),
+
+		%
+		% Insert the extra rvals at the start
+		%
+		{ list__append(ExtraRvals, ArgRvals0, ArgRvals1) },
+		{ list__append(ExtraTypes, MLDS_ArgTypes0, MLDS_ArgTypes) },
+
+		%
+		% Box all the arguments
+		%
+		ml_gen_box_const_rval_list(MLDS_ArgTypes, ArgRvals1,
+			Context, BoxConstDefns, ArgRvals),
+
+		%
+		% Generate a local static constant for this term.
+		%
+		ml_gen_static_const_name(Var, ConstName),
+		{ ConstType = mlds__array_type(mlds__generic_type) },
+		{ ArgInits = list__map(func(X) = init_obj(X), ArgRvals) },
+		{ Initializer = init_array(ArgInits) },
+		{ ConstDefn = ml_gen_static_const_defn(ConstName, ConstType,
+			Initializer, Context) },
+
+		%
+		% Assign the address of the local static constant to
+		% the variable.
+		%
+		ml_gen_static_const_addr(Var, ConstAddrRval),
+		{ MaybeTag = no ->
+			TaggedRval = ConstAddrRval
+		;
+			TaggedRval = mkword(Tag, ConstAddrRval)
+		},
+		{ Rval = unop(cast(mercury_type(Type)), TaggedRval) },
+		{ AssignStatement = ml_gen_assign(VarLval, Rval, Context) },
+		{ MLDS_Decls = list__append(BoxConstDefns, [ConstDefn]) },
+		{ MLDS_Statements = [AssignStatement] }
+	;
+		{ HowToConstruct = reuse_cell(_) },
+		{ sorry("cell reuse") }
+	).
+
+:- pred ml_gen_box_const_rval_list(list(mlds__type), list(mlds__rval),
+		prog_context, mlds__defns, list(mlds__rval),
+		ml_gen_info, ml_gen_info).
+:- mode ml_gen_box_const_rval_list(in, in, in, out, out, in, out) is det.
+
+ml_gen_box_const_rval_list([], [], _, [], []) --> [].
+ml_gen_box_const_rval_list([Type | Types], [Rval | Rvals], Context,
+		ConstDefns, [BoxedRval | BoxedRvals]) -->
+	ml_gen_box_const_rval(Type, Rval, Context, ConstDefns1, BoxedRval),
+	ml_gen_box_const_rval_list(Types, Rvals, Context, ConstDefns2,
+		BoxedRvals),
+	{ ConstDefns = list__append(ConstDefns1, ConstDefns2) }.
+ml_gen_box_const_rval_list([], [_|_], _, _, _) -->
+	{ error("ml_gen_box_const_rval_list: length mismatch") }.
+ml_gen_box_const_rval_list([_|_], [], _, _, _) -->
+	{ error("ml_gen_box_const_rval_list: length mismatch") }.
+
+:- pred ml_gen_box_const_rval(mlds__type, mlds__rval, prog_context,
+		mlds__defns, mlds__rval, ml_gen_info, ml_gen_info).
+:- mode ml_gen_box_const_rval(in, in, in, out, out, in, out) is det.
+
+ml_gen_box_const_rval(Type, Rval, Context, ConstDefns, BoxedRval) -->
+	(
+		{ Type = mercury_type(term__variable(_))
+		; Type = mlds__generic_type
+		}
+	->
+		{ BoxedRval = Rval },
+		{ ConstDefns = [] }
+	;
+		%
+		% We need to handle floats specially,
+		% since boxed floats normally get heap allocated,
+		% whereas for other types boxing is just a cast
+		% (casts are OK in static initializers,
+		% but calls to malloc() are not).
+		%
+		{ Type = mercury_type(term__functor(term__atom("float"),
+				[], _))
+		; Type = mlds__native_float_type
+		}
+	->
+		%
+		% Generate a local static constant for this float
+		%
+		ml_gen_info_new_conv_var(SequenceNum),
+		{ string__format("float_%d", [i(SequenceNum)], ConstName) },
+		{ Initializer = init_obj(Rval) },
+		{ ConstDefn = ml_gen_static_const_defn(ConstName, Type,
+			Initializer, Context) },
+		{ ConstDefns = [ConstDefn] },
+		%
+		% Return as the boxed rval the address of that constant,
+		% cast to mlds__generic_type
+		%
+		ml_qualify_var(ConstName, ConstLval),
+		{ ConstAddrRval = mem_addr(ConstLval) },
+		{ BoxedRval = unop(cast(mlds__generic_type), ConstAddrRval) }
+	;
+		{ BoxedRval = unop(box(Type), Rval) },
+		{ ConstDefns = [] }
+	).
+	
+:- pred ml_gen_static_const_arg_list(list(prog_var), list(static_cons),
+		list(mlds__rval), ml_gen_info, ml_gen_info).
+:- mode ml_gen_static_const_arg_list(in, in, out, in, out) is det.
 
+ml_gen_static_const_arg_list([], [], []) --> [].
+ml_gen_static_const_arg_list([Var | Vars], [StaticCons | StaticConses],
+		[Rval | Rvals]) -->
+	ml_gen_static_const_arg(Var, StaticCons, Rval),
+	ml_gen_static_const_arg_list(Vars, StaticConses, Rvals).
+ml_gen_static_const_arg_list([_|_], [], _) -->
+	{ error("ml_gen_static_const_arg_list: length mismatch") }.
+ml_gen_static_const_arg_list([], [_|_], _) -->
+	{ error("ml_gen_static_const_arg_list: length mismatch") }.
+
+	% Generate the name of the local static constant
+	% for a given variable.
 	%
-	% Compute the number of bytes to allocate
+:- pred ml_gen_static_const_name(prog_var, mlds__var_name,
+		ml_gen_info, ml_gen_info).
+:- mode ml_gen_static_const_name(in, out, in, out) is det.
+ml_gen_static_const_name(Var, ConstName) -->
+	=(MLDSGenInfo),
+	{ ml_gen_info_get_varset(MLDSGenInfo, VarSet) },
+	{ VarName = ml_gen_var_name(VarSet, Var) },
+	{ string__format("const_%s", [s(VarName)], ConstName) }.
+
+	% Generate an rval containing the address of the local static constant
+	% for a given variable.
 	%
-	{ list__length(ArgRvals, NumArgs) },
-	{ SizeInWordsRval = const(int_const(NumArgs)) },
-	{ SizeOfWordRval = ml_sizeof_word_rval },
-	{ SizeInBytesRval = binop((*), SizeInWordsRval, SizeOfWordRval) },
-	
+:- pred ml_gen_static_const_addr(prog_var, mlds__rval,
+		ml_gen_info, ml_gen_info).
+:- mode ml_gen_static_const_addr(in, out, in, out) is det.
+ml_gen_static_const_addr(Var, ConstAddrRval) -->
+	ml_gen_static_const_name(Var, ConstName),
+	ml_qualify_var(ConstName, ConstLval),
+	{ ConstAddrRval = mem_addr(ConstLval) }.
+
+	% Generate a definition of a local static constant,
+	% given the constant's name, type, and initializer.
 	%
-	% Now put it all together.
+:- func ml_gen_static_const_defn(mlds__var_name, mlds__type, mlds__initializer,
+		prog_context) = mlds__defn.
+ml_gen_static_const_defn(ConstName, ConstType, Initializer, Context) =
+		MLDS_Defn :-
+	Name = data(var(ConstName)),
+	Defn = data(ConstType, Initializer),
+	DeclFlags = ml_static_const_decl_flags,
+	MLDS_Context = mlds__make_context(Context),
+	MLDS_Defn = mlds__defn(Name, MLDS_Context, DeclFlags, Defn).
+
+	% Return the declaration flags appropriate for an
+	% initialized local static constant.
 	%
-	{ 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 = [] }.
+:- func ml_static_const_decl_flags = mlds__decl_flags.
+ml_static_const_decl_flags = MLDS_DeclFlags :-
+	Access = private,
+	PerInstance = one_copy,
+	Virtuality = non_virtual,
+	Finality = overridable,
+	Constness = const,
+	Abstractness = concrete,
+	MLDS_DeclFlags = init_decl_flags(Access, PerInstance,
+		Virtuality, Finality, Constness, Abstractness).
 
 :- pred ml_cons_name(cons_id, ctor_name, ml_gen_info, ml_gen_info).
 :- mode ml_cons_name(in, out, in, out) is det.
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.41
diff -u -d -r1.41 modecheck_unify.m
--- compiler/modecheck_unify.m	1999/09/13 10:14:43	1.41
+++ compiler/modecheck_unify.m	2000/05/18 04:59:25
@@ -1038,7 +1038,7 @@
 			RHS = RHS0
 		),
 		Unification = construct(X, ConsId, ArgVars, ArgModes,
-			no, cell_is_unique, AditiInfo),
+			construct_dynamically, cell_is_unique, AditiInfo),
 		ModeInfo = ModeInfo0
 	;
 		instmap__is_reachable(InstMap)
@@ -1093,10 +1093,9 @@
 		mode_is_output(ModuleInfo, ModeOfX)
 	->
 		% It's a construction.
-		ReuseVar = no,
 		RLExprnId = no,
 		Unification = construct(X, ConsId, ArgVars, ArgModes,
-			ReuseVar, cell_is_unique, RLExprnId),
+			construct_dynamically, cell_is_unique, RLExprnId),
 
 		% For existentially quantified data types,
 		% check that any type_info or type_class_info variables in the
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.185
diff -u -d -r1.185 polymorphism.m
--- compiler/polymorphism.m	2000/04/14 08:38:15	1.185
+++ compiler/polymorphism.m	2000/05/18 05:06:50
@@ -2196,10 +2196,9 @@
 	BaseTypeClassInfoTerm = functor(ConsId, []),
 
 		% create the construction unification to initialize the variable
-	ReuseVar = no,
 	RLExprnId = no,
 	BaseUnification = construct(BaseVar, ConsId, [], [],
-			ReuseVar, cell_is_shared, RLExprnId),
+			construct_dynamically, cell_is_shared, RLExprnId),
 	BaseUnifyMode = (free -> ground(shared, no)) -
 			(ground(shared, no) -> ground(shared, no)),
 	BaseUnifyContext = unify_context(explicit, []),
@@ -2233,7 +2232,7 @@
 	list__length(NewArgVars, NumArgVars),
 	list__duplicate(NumArgVars, UniMode, UniModes),
 	Unification = construct(NewVar, NewConsId, NewArgVars,
-		UniModes, ReuseVar, cell_is_unique, RLExprnId),
+		UniModes, construct_dynamically, cell_is_unique, RLExprnId),
 	UnifyMode = (free -> ground(shared, no)) -
 			(ground(shared, no) -> ground(shared, no)),
 	UnifyContext = unify_context(explicit, []),
@@ -2523,10 +2522,9 @@
 polymorphism__init_with_int_constant(CountVar, Num, CountUnifyGoal) :-
 
 	CountConsId = int_const(Num),
-	ReuseVar = no,
 	RLExprnId = no,
 	CountUnification = construct(CountVar, CountConsId, [], [],
-		ReuseVar, cell_is_shared, RLExprnId),
+		construct_dynamically, cell_is_shared, RLExprnId),
 
 	CountTerm = functor(CountConsId, []),
 	CountInst = bound(unique, [functor(int_const(Num), [])]),
@@ -2639,10 +2637,9 @@
 		   ground(shared, no) - ground(shared, no)),
 	list__length(ArgVars, NumArgVars),
 	list__duplicate(NumArgVars, UniMode, UniModes),
-	ReuseVar = no,
 	RLExprnId = no,
 	Unification = construct(TypeInfoVar, ConsId, ArgVars, UniModes,
-			ReuseVar, cell_is_unique, RLExprnId),
+			construct_dynamically, cell_is_unique, RLExprnId),
 	UnifyMode = (free -> ground(shared, no)) -
 			(ground(shared, no) -> ground(shared, no)),
 	UnifyContext = unify_context(explicit, []),
@@ -2695,10 +2692,9 @@
 		VarSet0, VarTypes0, TypeCtorInfoVar, VarSet, VarTypes),
 
 	% create the construction unification to initialize the variable
-	ReuseVar = no,
 	RLExprnId = no,
 	Unification = construct(TypeCtorInfoVar, ConsId, [], [],
-			ReuseVar, cell_is_shared, RLExprnId),
+			construct_dynamically, cell_is_shared, RLExprnId),
 	UnifyMode = (free -> ground(shared, no)) -
 			(ground(shared, no) -> ground(shared, no)),
 	UnifyContext = unify_context(explicit, []),
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.72
diff -u -d -r1.72 quantification.m
--- compiler/quantification.m	2000/02/18 07:44:53	1.72
+++ compiler/quantification.m	2000/05/18 05:10:22
@@ -445,8 +445,11 @@
 	quantification__get_lambda_outside(LambdaOutsideVars),
 	{ quantification__get_unify_typeinfos(Unification0, TypeInfoVars) },
 
-	{ Unification0 = construct(_, _, _, _, CellToReuse0, _, _) ->
-		CellToReuse = CellToReuse0
+	{
+		Unification0 = construct(_, _, _, _,
+			reuse_cell(CellToReuse0), _, _)
+	->
+		CellToReuse = yes(CellToReuse0)
 	;
 		CellToReuse = no
 	},
@@ -692,13 +695,13 @@
 	%
 	{
 		Unification0 = construct(ConstructVar, ConsId, Args0,
-			ArgModes0, Reuse, Uniq, AditiInfo)
+			ArgModes0, HowToConstruct, Uniq, AditiInfo)
 	->
 		map__from_corresponding_lists(Args0, ArgModes0, ArgModesMap),
 		set__to_sorted_list(NonLocals, Args),
 		map__apply_to_list(Args, ArgModesMap, ArgModes),
 		Unification = construct(ConstructVar, ConsId, Args,
-			ArgModes, Reuse, Uniq, AditiInfo)
+			ArgModes, HowToConstruct, Uniq, AditiInfo)
 	;
 		% after mode analysis, unifications with lambda variables
 		% should always be construction unifications, but
@@ -891,8 +894,8 @@
 		unify(A, B, _, Unification, _), Set0, LambdaSet0,
 		Set, LambdaSet) :-
 	set__insert(Set0, A, Set1),
-	( Unification = construct(_, _, _, _, Reuse0, _, _) ->
-		Reuse = Reuse0
+	( Unification = construct(_, _, _, _, reuse_cell(Reuse0), _, _) ->
+		Reuse = yes(Reuse0)
 	;
 		Reuse = no
 	),

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