[m-dev.] diff: MLDS back-end: various bug fixes

[Fergus Henderson]

Estimated hours taken: 6

Fix some bugs in the MLDS back-end.

compiler/ml_code_gen.m:
	- Make sure that we module-qualify the base_type_infos for the
	  builtin types.
	- Make sure that we unbox (i.e. cast) the closure argument
	  when passing it to a closure wrapper function.
	- Fix a bug where we were generating references to undeclared
	  variables when calling higher-order procedures with arguments
	  of type `io__state' or when passing `io_state' arguments to
	  polymorphic procedures.
	- Export ml_gen_proc_params, for use by ml_base_type_info.m.

compiler/ml_base_type_info.m:
	- Make sure that we "box" (i.e. cast to a common type) the function
	  addresses that we store in base_type_infos, since their number
	  of parameters depends on the type's arity

compiler/mlds_to_c.m:
	- Output `extern' before forward declarations of variables.
	- For mem_addr values, output `&' before the variable name.
	- For mem_addr values, make sure to cast them to `(Word)';
	  this is needed for base_type_infos, which are currently the
	  only thing we use mem_addr values for.  (This code will probably
	  need to change later to accomodate other kinds of mem_addr values.)
	- Enclose header files in the standard `#ifndef ... #define ... ... #endif'
	  header guard, to avoid problems with mutually recursive module
	  interfaces.

Workspace: /d-drive/home/hg/fjh/mercury
Index: compiler/ml_base_type_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_base_type_info.m,v
retrieving revision 1.1
diff -u -d -r1.1 ml_base_type_info.m
--- compiler/ml_base_type_info.m	1999/12/02 05:42:25	1.1
+++ compiler/ml_base_type_info.m	1999/12/03 06:39:05
@@ -209,7 +209,15 @@
         pred_info_module(PredInfo, PredModule),
         MLDS_Module = mercury_module_name_to_mlds(PredModule),
         QualifiedProcLabel = qual(MLDS_Module, PredLabel - ProcId),
-        ProcAddrArg = const(code_addr_const(proc(QualifiedProcLabel))),
+        ProcAddrRval = const(code_addr_const(proc(QualifiedProcLabel))),
+	%
+	% Convert the procedure address to a generic type.
+	% We need to use a generic type because since the actual type
+	% for the procedure will depend on how many type_info parameters
+	% it takes, which will depend on the type's arity.
+	%
+        PredParams = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+        ProcAddrArg = unop(box(mlds__func_type(PredParams)), ProcAddrRval),
 	%
 	% recursively handle the remaining procedures
 	%
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.20
diff -u -d -r1.20 ml_code_gen.m
--- compiler/ml_code_gen.m	1999/12/02 05:42:25	1.20
+++ compiler/ml_code_gen.m	1999/12/03 13:24:18
@@ -597,6 +597,10 @@
 	%
 :- func ml_gen_pred_label(module_info, pred_id, proc_id) = mlds__pred_label.
 
+	% Generate the function prototype for a given procedure.
+	%
+:- func ml_gen_proc_params(module_info, pred_id, proc_id) = mlds__func_params.
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
@@ -1366,7 +1371,8 @@
 	%
 	% insert the `closure_arg' parameter
 	%
-	{ ClosureArg = data(var("closure_arg")) - mlds__generic_env_ptr_type },
+	{ ClosureArgType = mlds__generic_env_ptr_type },
+	{ ClosureArg = data(var("closure_arg")) - ClosureArgType },
 	{ Params0 = mlds__func_params(ArgParams0, RetParam) },
 	{ Params = mlds__func_params([ClosureArg | ArgParams0], RetParam) },
 	{ Signature = mlds__get_func_signature(Params) },
@@ -1400,6 +1406,7 @@
 	ml_gen_arg_list(ArgNames, ArgLvals, ActualArgTypes, BoxedArgTypes,
 		ArgModes, Context, InputRvals, OutputLvals, ConvArgDecls,
 		ConvOutputStatements),
+	{ ClosureRval = unop(unbox(ClosureArgType), lval(ClosureLval)) },
 
 	%
 	% Prepare to generate the call, passing the closure as the first
@@ -1411,7 +1418,7 @@
 	%
 	{ ObjectRval = no },
 	{ DoGenCall = ml_gen_mlds_call(Signature, ObjectRval, FuncRval,
-		[lval(ClosureLval) | InputRvals], OutputLvals,
+		[ClosureRval | InputRvals], OutputLvals,
 		CodeModel, Context) },
 
 	( { ConvArgDecls = [], ConvOutputStatements = [] } ->
@@ -1676,8 +1683,19 @@
 			%
 			% it's an input argument
 			%
+			{ type_util__is_dummy_argument_type(CallerType) ->
+				% The variable may not have been declared,
+				% so we need to generate a dummy value for it.
+				% Using `0' here is more efficient than
+				% using private_builtin__dummy_var, which is
+				% what ml_gen_var will have generated for this
+				% variable.
+				VarRval = const(int_const(0))
+			;
+				VarRval = lval(VarLval)
+			},
 			{ ml_gen_box_or_unbox_rval(CallerType, CalleeType,
-				lval(VarLval), ArgRval) },
+				VarRval, ArgRval) },
 			{ InputRvals = [ArgRval | InputRvals1] },
 			{ OutputLvals = OutputLvals1 },
 			{ ConvDecls = ConvDecls1 },
@@ -1792,18 +1810,24 @@
 		% argument lval
 		ml_qualify_var(ArgVarName, ArgLval),
 
-		% generate a statement to box/unbox the fresh variable
-		% and assign it to the output argument whose address
-		% we were passed.  Note that we swap the caller type
-		% and the callee type, since this is an output not
-		% an input, so the callee type is the source type
-		% and the caller type is the destination type.
-		{ ml_gen_box_or_unbox_rval(CalleeType, CallerType,
-			lval(ArgLval), ConvertedArgRval) },
-		{ AssignStmt = assign(VarLval, ConvertedArgRval) },
-		{ AssignStatement = mlds__statement(atomic(AssignStmt),
-			mlds__make_context(Context)) },
-		{ ConvStatements = [AssignStatement] }
+		( { type_util__is_dummy_argument_type(CallerType) } ->
+			% if it is a dummy argument type (e.g. io__state),
+			% then we don't need to bother assigning it
+			{ ConvStatements = [] }
+		;
+			% generate a statement to box/unbox the fresh variable
+			% and assign it to the output argument whose address
+			% we were passed.  Note that we swap the caller type
+			% and the callee type, since this is an output not
+			% an input, so the callee type is the source type
+			% and the caller type is the destination type.
+			{ ml_gen_box_or_unbox_rval(CalleeType, CallerType,
+				lval(ArgLval), ConvertedArgRval) },
+			{ AssignStmt = assign(VarLval, ConvertedArgRval) },
+			{ AssignStatement = mlds__statement(atomic(AssignStmt),
+				mlds__make_context(Context)) },
+			{ ConvStatements = [AssignStatement] }
+		)
 	).
 	
 %-----------------------------------------------------------------------------%
@@ -2871,7 +2895,7 @@
 		mkword(Bits1, unop(std_unop(mkbody), const(int_const(Num1)))),
 		Context) }.
 
-ml_gen_construct_rep(type_ctor_info_constant(ModuleName, TypeName, TypeArity),
+ml_gen_construct_rep(type_ctor_info_constant(ModuleName0, TypeName, TypeArity),
 		_ConsId, Var, Args, _ArgModes, Context,
 		[], [MLDS_Statement]) -->
 	( { Args = [] } ->
@@ -2880,6 +2904,17 @@
 		{ error("ml_code_gen: type-info constant has args") }
 	),
 	ml_gen_var(Var, VarLval),
+	%
+	% 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'
+	% qualifier now.
+	%
+	{ ModuleName0 = unqualified("") ->
+		mercury_public_builtin_module(ModuleName)
+	;
+		ModuleName = ModuleName0
+	},
 	{ MLDS_Module = mercury_module_name_to_mlds(ModuleName) },
 	{ DataAddr = data_addr(MLDS_Module,
 		type_ctor(info, TypeName, TypeArity)) },
@@ -4057,8 +4092,6 @@
 
 	% Generate the function prototype for a procedure.
 	%
-:- func ml_gen_proc_params(module_info, pred_id, proc_id) = mlds__func_params.
-
 ml_gen_proc_params(ModuleInfo, PredId, ProcId) = FuncParams :-
 	module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
 		PredInfo, ProcInfo),
@@ -4213,19 +4246,30 @@
 :- mode ml_gen_var(in, out, in, out) is det.
 
 ml_gen_var(Var, Lval) -->
-	=(MLDSGenInfo),
-	{ ml_gen_info_get_output_vars(MLDSGenInfo, OutputVars) },
-	{ ml_gen_info_get_varset(MLDSGenInfo, VarSet) },
-	{ ml_gen_info_get_module_name(MLDSGenInfo, ModuleName) },
-	{ MLDS_Module = mercury_module_name_to_mlds(ModuleName) },
-	{ VarName = ml_gen_var_name(VarSet, Var) },
-	{ VarLval = var(qual(MLDS_Module, VarName)) },
-	% output variables are passed by reference...
-	{ list__member(Var, OutputVars) ->
-		Lval = mem_ref(lval(VarLval))
+	ml_variable_type(Var, Type),
+	( { type_util__is_dummy_argument_type(Type) } ->
+		%
+		% The variable won't have been declared, so
+		% we need to generate a dummy lval for this variable.
+		%
+		{ mercury_private_builtin_module(PrivateBuiltin) },
+		{ MLDS_Module = mercury_module_name_to_mlds(PrivateBuiltin) },
+		{ Lval = var(qual(MLDS_Module, "dummy_var")) }
 	;
-		Lval = VarLval
-	}.
+		=(MLDSGenInfo),
+		{ ml_gen_info_get_output_vars(MLDSGenInfo, OutputVars) },
+		{ ml_gen_info_get_varset(MLDSGenInfo, VarSet) },
+		{ ml_gen_info_get_module_name(MLDSGenInfo, ModuleName) },
+		{ MLDS_Module = mercury_module_name_to_mlds(ModuleName) },
+		{ VarName = ml_gen_var_name(VarSet, Var) },
+		{ VarLval = var(qual(MLDS_Module, VarName)) },
+		% output variables are passed by reference...
+		{ list__member(Var, OutputVars) ->
+			Lval = mem_ref(lval(VarLval))
+		;
+			Lval = VarLval
+		}
+	).
 
 	% Lookup the types of a list of variables.
 	%
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.17
diff -u -d -r1.17 mlds_to_c.m
--- compiler/mlds_to_c.m	1999/12/02 05:42:26	1.17
+++ compiler/mlds_to_c.m	1999/12/03 06:06:09
@@ -32,6 +32,7 @@
 
 :- implementation.
 
+:- import_module llds_out. % XXX needed for llds_out__name_mangle.
 :- import_module globals, options, passes_aux.
 :- import_module builtin_ops, c_util, modules.
 :- import_module hlds_pred. % for `pred_proc_id'.
@@ -165,7 +166,16 @@
 	io__write_string("/* :- interface. */\n"),
 	io__nl,
 	mlds_indent(Indent),
-	io__write_string("#include ""mercury_imp.h""\n\n").
+	io__write_string("#ifndef MR_HEADER_GUARD_"),
+	prog_out__write_sym_name(ModuleName),
+	io__nl,
+	mlds_indent(Indent),
+	io__write_string("#define MR_HEADER_GUARD_"),
+	prog_out__write_sym_name(ModuleName),
+	io__nl,
+	io__nl,
+	mlds_indent(Indent),
+	io__write_string("#include ""mercury.h""\n").
 
 :- pred mlds_output_src_start(indent, mercury_module_name,
 		io__state, io__state).
@@ -176,7 +186,7 @@
 	mlds_indent(Indent),
 	io__write_string("/* :- module "),
 	prog_out__write_sym_name(ModuleName),
-	io__write_string(". */\n\n"),
+	io__write_string(". */\n"),
 	mlds_indent(Indent),
 	io__write_string("/* :- implementation. */\n"),
 	io__nl,
@@ -192,6 +202,11 @@
 
 mlds_output_hdr_end(Indent, ModuleName) -->
 	mlds_indent(Indent),
+	io__write_string("#endif /* MR_HEADER_GUARD_"),
+	prog_out__write_sym_name(ModuleName),
+	io__write_string(" */\n"),
+	io__nl,
+	mlds_indent(Indent),
 	io__write_string("/* :- end_interface "),
 	prog_out__write_sym_name(ModuleName),
 	io__write_string(". */\n").
@@ -271,6 +286,13 @@
 mlds_output_decl(Indent, ModuleName, Defn) -->
 	{ Defn = mlds__defn(Name, Context, Flags, DefnBody) },
 	mlds_indent(Context, Indent),
+	( { Name = data(_) } ->
+		% XXX for private data and private functions,
+		% we should use "static"
+		io__write_string("extern ")
+	;
+		[]
+	),
 	mlds_output_decl_flags(Flags),
 	mlds_output_decl_body(Indent, qual(ModuleName, Name), DefnBody).
 
@@ -589,30 +611,27 @@
 
 mlds_output_fully_qualified_name(qual(ModuleName, Name), OutputFunc) -->
 	{ SymName = mlds_module_name_to_sym_name(ModuleName) },
-	{ Separator = "__" },
-	{ sym_name_to_string(SymName, Separator, ModuleNameString) },
-	io__write_string(ModuleNameString),
-	io__write_string(Separator),
+	{ llds_out__sym_name_mangle(SymName, MangledModuleName) },
+	io__write_string(MangledModuleName),
+	io__write_string("__"),
 	OutputFunc(Name).
 
 :- pred mlds_output_module_name(mercury_module_name, io__state, io__state).
 :- mode mlds_output_module_name(in, di, uo) is det.
 
 mlds_output_module_name(ModuleName) -->
-	{ Separator = "__" },
-	{ sym_name_to_string(ModuleName, Separator, ModuleNameString) },
-	io__write_string(ModuleNameString).
+	{ llds_out__sym_name_mangle(ModuleName, MangledModuleName) },
+	io__write_string(MangledModuleName).
 
 :- pred mlds_output_name(mlds__entity_name, io__state, io__state).
 :- mode mlds_output_name(in, di, uo) is det.
 
-% XXX FIXME!
-% XXX we should escape special characters
 % XXX we should avoid appending the arity, modenum, and seqnum
 %     if they are not needed.
 
 mlds_output_name(type(Name, Arity)) -->
-	io__format("%s_%d", [s(Name), i(Arity)]).
+	{ llds_out__name_mangle(Name, MangledName) },
+	io__format("%s_%d", [s(MangledName), i(Arity)]).
 mlds_output_name(data(DataName)) -->
 	mlds_output_data_name(DataName).
 mlds_output_name(function(PredLabel, ProcId, MaybeSeqNum, _PredId)) -->
@@ -632,7 +651,8 @@
 	( { PredOrFunc = predicate, Suffix = "p" }
 	; { PredOrFunc = function, Suffix = "f" }
 	),
-	io__format("%s_%d_%s", [s(Name), i(Arity), s(Suffix)]),
+	{ llds_out__name_mangle(Name, MangledName) },
+	io__format("%s_%d_%s", [s(MangledName), i(Arity), s(Suffix)]),
 	( { MaybeDefiningModule = yes(DefiningModule) } ->
 		io__write_string("_in__"),
 		mlds_output_module_name(DefiningModule)
@@ -641,7 +661,9 @@
 	).
 mlds_output_pred_label(special_pred(PredName, MaybeTypeModule,
 		TypeName, TypeArity)) -->
-	io__write_string(PredName),
+	{ llds_out__name_mangle(PredName, MangledPredName) },
+	{ llds_out__name_mangle(TypeName, MangledTypeName) },
+	io__write_string(MangledPredName),
 	io__write_string("__"),
 	( { MaybeTypeModule = yes(TypeModule) } ->
 		mlds_output_module_name(TypeModule),
@@ -649,25 +671,25 @@
 	;
 		[]
 	),
-	io__write_string(TypeName),
+	io__write_string(MangledTypeName),
 	io__write_string("_"),
 	io__write_int(TypeArity).
 
 :- pred mlds_output_data_name(mlds__data_name, io__state, io__state).
 :- mode mlds_output_data_name(in, di, uo) is det.
 
-% XX some of these should probably be escaped
-
 mlds_output_data_name(var(Name)) -->
-	io__write_string(Name).
+	{ llds_out__name_mangle(Name, MangledName) },
+	io__write_string(MangledName).
 mlds_output_data_name(common(Num)) -->
 	io__write_string("common_"),
 	io__write_int(Num).
 mlds_output_data_name(type_ctor(BaseData, Name, Arity)) -->
+	{ llds_out__name_mangle(Name, MangledName) },
 	io__write_string("base_type_"),
 	io__write(BaseData),
 	io__write_string("_"),
-	io__write_string(Name),
+	io__write_string(MangledName),
 	io__write_string("_"),
 	io__write_int(Arity).
 mlds_output_data_name(base_typeclass_info(_ClassId, _InstanceId)) -->
@@ -1698,9 +1720,13 @@
 :- mode mlds_output_data_addr(in, di, uo) is det.
 
 mlds_output_data_addr(data_addr(ModuleName, DataName)) -->
+	% XXX the cast to (Word) is needed for base_type_infos,
+	% but it might not be right for other data_addr values.
+	io__write_string("((Word) &"),
 	mlds_output_module_name(mlds_module_name_to_sym_name(ModuleName)),
 	io__write_string("__"),
-	mlds_output_data_name(DataName).
+	mlds_output_data_name(DataName),
+	io__write_string(")").
 
 %-----------------------------------------------------------------------------%
 %

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