[m-dev.] diff: MLDS back-end: implement `pragma c_code'

[Fergus Henderson]

Estimated hours taken: 8

compiler/ml_code_gen.m:
compiler/mlds_to_c.m:
	Implement `pragma c_code' (except for the model_non case)
	and `pragma c_header_code' for the MLDS back-end.
	Note that model_non `pragma c_code' is still not yet
	implemented, and neither is `pragma export'.

compiler/ml_code_gen.m:
	Implement code generation for par_conj goals --
	for now, we just generate sequential code for them.

Workspace: /mnt/hg/home/hg/fjh/mercury
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.22
diff -u -d -r1.22 ml_code_gen.m
--- ml_code_gen.m	1999/12/03 20:22:45	1.22
+++ ml_code_gen.m	1999/12/06 07:17:37
@@ -611,6 +611,7 @@
 
 :- import_module ml_base_type_info.
 :- import_module llds. % XXX needed for `code_model'.
+:- import_module export, llds_out. % XXX needed for pragma C code
 :- import_module code_util. % XXX needed for `code_util__compiler_generated'.
 			    % and `code_util__cons_id_to_tag'.
 :- import_module goal_util.
@@ -640,12 +641,13 @@
 :- mode ml_gen_foreign_code(in, out, di, uo) is det.
 
 ml_gen_foreign_code(ModuleInfo, MLDS_ForeignCode) -->
+	{ module_info_get_c_header(ModuleInfo, C_Header_Info) },
+	{ module_info_get_c_body_code(ModuleInfo, C_Body_Info) },
+	{ ConvBody = (func(S - C) = user_c_code(S, C)) },
+	{ User_C_Code = list__map(ConvBody, C_Body_Info) },
 	%
 	% XXX not yet implemented -- this is just a stub
 	%
-	{ module_info_get_c_header(ModuleInfo, C_Header_Info) },
-	{ module_info_get_c_body_code(ModuleInfo, _C_Body_Info) },
-	{ User_C_Code = [] },
 	{ C_Exports = [] },
 	{ MLDS_ForeignCode = mlds__foreign_code(C_Header_Info, User_C_Code,
 			C_Exports) }.
@@ -1296,9 +1298,13 @@
 		MLDS_Decls, MLDS_Statements) -->
 	ml_gen_disj(Goals, CodeModel, Context, MLDS_Decls, MLDS_Statements).
 
-ml_gen_goal_expr(par_conj(_Goals, _SM), _, _, _, _) -->
-	% XXX not yet implemented
-	{ sorry("parallel conjunction") }.
+ml_gen_goal_expr(par_conj(Goals, _SM), CodeModel, Context,
+		MLDS_Decls, MLDS_Statements) -->
+	%
+	% XXX currently we treat parallel conjunction the same as
+	%     sequential conjunction -- parallelism is not yet implemented
+	%
+	ml_gen_conj(Goals, CodeModel, Context, MLDS_Decls, MLDS_Statements).
 
 ml_gen_goal_expr(generic_call(GenericCall, Vars, Modes, Detism), CodeModel,
 		Context, MLDS_Decls, MLDS_Statements) -->
@@ -1330,14 +1336,351 @@
 	ml_gen_unification(Unification, CodeModel, Context,
 		MLDS_Decls, MLDS_Statements).
 
-ml_gen_goal_expr(pragma_c_code(_, _, _, _, _ArgNames, _, _PragmaCode),
-		_, _, [], []) -->
-	{ sorry("C interface") }.
+ml_gen_goal_expr(pragma_c_code(Attributes,
+                PredId, ProcId, ArgVars, ArgDatas, OrigArgTypes, PragmaImpl),
+		CodeModel, OuterContext, MLDS_Decls, MLDS_Statements) -->
+        (
+                { PragmaImpl = ordinary(C_Code, _MaybeContext) },
+                ml_gen_ordinary_pragma_c_code(CodeModel, Attributes,
+                        PredId, ProcId, ArgVars, ArgDatas, OrigArgTypes,
+                        C_Code, OuterContext, MLDS_Decls, MLDS_Statements)
+        ;
+                { PragmaImpl = nondet( _, _, _, _, _, _, _, _, _) },
+		{ sorry("nondet pragma c_code") }
+		/*
+                { PragmaImpl = nondet(
+                        Fields, FieldsContext, First, FirstContext,
+                        Later, LaterContext, Treat, Shared, SharedContext) },
+                ml_gen_nondet_pragma_c_code(CodeModel, Attributes,
+                        PredId, ProcId, ArgVars, ArgDatas, OrigArgTypes,
+                        Fields, FieldsContext, First, FirstContext,
+                        Later, LaterContext, Treat, Shared, SharedContext,
+                        MLDS_Decls, MLDS_Statements)
+		*/
+        ).
 
 ml_gen_goal_expr(bi_implication(_, _), _, _, _, _) -->
 	% these should have been expanded out by now
 	{ error("ml_gen_goal_expr: unexpected bi_implication") }.
+
+:- pred ml_gen_ordinary_pragma_c_code(code_model, pragma_c_code_attributes,
+		pred_id, proc_id, list(prog_var), list(maybe(pair(string, mode))),
+		list(prog_type), string, prog_context,
+		mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
+:- mode ml_gen_ordinary_pragma_c_code(in, in, in, in, in, in, 
+		in, in, in, out, out, in, out) is det.
+
+	% We generate code of the following form:
+	%
+	% model_det pragma_c_code:
+	%
+	%	{
+	% 		<declaration of one local variable for each arg>
+	%
+	%		<assign input args>
+	%		<obtain global lock>
+	%		<c code>
+	%		<release global lock>
+	%		<assign output args>
+	%	}
+	%		
+	% model_semi pragma_c_code:
+	%
+	%	{
+	% 		<declaration of one local variable for each arg>
+	%		#define SUCCESS_INDICATOR <succeeded>
+	%
+	%		<assign input args>
+	%		<obtain global lock>
+	%		<c code>
+	%		<release global lock>
+	%		if (SUCCESS_INDICATOR) {
+	%			<assign output args>
+	%		}
+	%	}
+	%		
+	% Note that we generate this code directly as
+	% `target_code(lang_C, <string>)' instructions in the MLDS.
+	% It would probably be nicer to encode more of the structure
+	% in the MLDS, so that (a) we could do better MLDS optimization
+	% and (b) so that the generation of C code strings could be
+	% isolated in mlds_to_c.m.  Also we will need to do something
+	% different for targets other than C, e.g. when compiling to
+	% Java.
+	%
+ml_gen_ordinary_pragma_c_code(CodeModel, Attributes,
+		PredId, _ProcId, ArgVars, ArgDatas, OrigArgTypes,
+		C_Code, Context, MLDS_Decls, MLDS_Statements) -->
+	%
+	% Combine all the information about the each arg
+	%
+	{ ml_make_c_arg_list(ArgVars, ArgDatas, OrigArgTypes,
+		ArgList) },
+
+	%
+	% Generate <declaration of one local variable for each arg>
+	%
+	{ ml_gen_pragma_c_decls(ArgList, ArgDeclsList) },
+
+	%
+	% Generate code to set the values of the input variables.
+	%
+	list__map_foldl(ml_gen_pragma_c_input_arg, ArgList, AssignInputsList),
+
+	%
+	% Generate code to assign the values of the output variables.
+	%
+	list__map_foldl(ml_gen_pragma_c_output_arg, ArgList, AssignOutputsList),
+
+	%
+	% Generate code fragments to obtain and release the global lock
+	% (this is used for ensuring thread safety in a concurrent
+	% implementation)
+	% XXX we should only generate these if the `parallel' option
+	% was enabled
+	%
+	=(MLDSGenInfo),
+	{ thread_safe(Attributes, ThreadSafe) },
+	{ ThreadSafe = thread_safe ->
+		ObtainLock = "",
+		ReleaseLock = ""
+	;
+		ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo),
+		module_info_pred_info(ModuleInfo, PredId, PredInfo),
+		pred_info_name(PredInfo, Name),
+		llds_out__quote_c_string(Name, MangledName),
+		string__append_list(["\tMR_OBTAIN_GLOBAL_LOCK(""",
+			MangledName, """);\n"], ObtainLock),
+		string__append_list(["\tMR_RELEASE_GLOBAL_LOCK(""",
+			MangledName, """);\n"], ReleaseLock)
+	},
+
+	%
+	% Put it all together
+	%
+	{ string__append_list(ArgDeclsList, ArgDecls) },
+	{ string__append_list(AssignInputsList, AssignInputsCode) },
+	{ string__append_list(AssignOutputsList, AssignOutputsCode) },
+	( { CodeModel = model_det } ->
+		{ string__append_list([
+				"{\n",
+				ArgDecls,
+				"\n",
+				AssignInputsCode,
+				ObtainLock,
+				"\t\t{\n",
+				C_Code,
+				"\n\t\t}\n",
+				ReleaseLock,
+				AssignOutputsCode,
+				"}\n"],
+			Combined_C_Code) }
+	; { CodeModel = model_semi } ->
+		ml_success_lval(SucceededLval),
+		{ ml_gen_c_code_for_rval(lval(SucceededLval), SucceededVar) },
+		{ DefineSuccessIndicator = string__format(
+			"#define SUCCESS_INDICATOR = %s\n",
+			[s(SucceededVar)]) },
+		{ MaybeAssignOutputsCode = string__format(
+			"\tif (SUCCESS_INDICATOR) {\n%s\n\t}",
+			[s(AssignOutputsCode)]) },
+		{ UndefSuccessIndicator = "#undef SUCCESS_INDICATOR" },
+		{ string__append_list([
+				"{\n",
+				ArgDecls,
+				DefineSuccessIndicator,
+				"\n",
+				AssignInputsCode,
+				ObtainLock,
+				"\t\t{\n",
+				C_Code,
+				"\n\t\t}\n",
+				ReleaseLock,
+				MaybeAssignOutputsCode,
+				UndefSuccessIndicator,
+				"}\n"],
+			Combined_C_Code) }
+	;
+		{ error("ml_gen_ordinary_pragma_c_code: unexpected code model") }
+	),
+	{ C_Code_Stmt = target_code(lang_C, Combined_C_Code) },
+	{ C_Code_Statement = mlds__statement(atomic(C_Code_Stmt),
+		mlds__make_context(Context)) },
+	{ MLDS_Statements = [C_Code_Statement] },
+	{ MLDS_Decls = [] }.
+
+%---------------------------------------------------------------------------%
+
+%
+% we gather all the information about each pragma_c argument
+% together into this struct
+%
+
+:- type ml_c_arg
+	--->	ml_c_arg(
+			prog_var,
+			maybe(pair(string, mode)),	% name and mode
+			prog_type	% original type before
+					% inlining/specialization
+					% (the actual type may be an instance
+					% of this type, if this type is
+					% polymorphic).
+		).
+
+:- pred ml_make_c_arg_list(list(prog_var)::in,
+		list(maybe(pair(string, mode)))::in, list(prog_type)::in,
+		list(ml_c_arg)::out) is det.
+
+ml_make_c_arg_list(Vars, ArgDatas, Types, ArgList) :-
+	( Vars = [], ArgDatas = [], Types = [] ->
+		ArgList = []
+	; Vars = [V|Vs], ArgDatas = [N|Ns], Types = [T|Ts] ->
+		Arg = ml_c_arg(V, N, T),
+		ml_make_c_arg_list(Vs, Ns, Ts, Args),
+		ArgList = [Arg | Args]
+	;
+		error("ml_code_gen:make_c_arg_list - length mismatch")
+	).
+
+%---------------------------------------------------------------------------%
+
+% ml_gen_pragma_c_decls generates C code to declare the arguments
+% for a `pragma c_code' declaration.
+%
+:- pred ml_gen_pragma_c_decls(list(ml_c_arg)::in, list(string)::out) is det.
+
+ml_gen_pragma_c_decls([], []).
+ml_gen_pragma_c_decls([Arg|Args], [Decl|Decls]) :-
+	ml_gen_pragma_c_decl(Arg, Decl),
+	ml_gen_pragma_c_decls(Args, Decls).
+
+% ml_gen_pragma_c_decl generates C code to declare an argument
+% of a `pragma c_code' declaration.
+%
+:- pred ml_gen_pragma_c_decl(ml_c_arg::in, string::out) is det.
+
+ml_gen_pragma_c_decl(ml_c_arg(_Var, MaybeNameAndMode, Type), DeclString) :-
+	(
+		MaybeNameAndMode = yes(ArgName - _Mode),
+		\+ var_is_singleton(ArgName)
+	->
+		export__type_to_type_string(Type, TypeString),
+		string__format("\t%s %s;\n", [s(TypeString), s(ArgName)],
+			DeclString)
+	;
+		% if the variable doesn't occur in the ArgNames list,
+		% it can't be used, so we just ignore it
+		DeclString = ""
+	).
+
+%-----------------------------------------------------------------------------%
+
+% var_is_singleton determines whether or not a given pragma_c variable
+% is singleton (i.e. starts with an underscore)
+%
+% Singleton vars should be ignored when generating the declarations for
+% pragma_c arguments because:
+%
+%	- they should not appear in the C code
+% 	- they could clash with the system name space
+%
+:- pred var_is_singleton(string) is semidet.
+:- mode var_is_singleton(in) is semidet.
+
+var_is_singleton(Name) :-
+	string__first_char(Name, '_', _).
+
+%-----------------------------------------------------------------------------%
+
+% ml_gen_pragma_c_input_arg generates C code to assign the value of an input
+% arg for a `pragma c_code' declaration.
+%
+:- pred ml_gen_pragma_c_input_arg(ml_c_arg::in, string::out,
+		ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_c_input_arg(ml_c_arg(Var, MaybeNameAndMode, OrigType),
+		AssignInputString) -->
+	=(MLDSGenInfo),
+	{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
+	(
+		{ MaybeNameAndMode = yes(ArgName - Mode) },
+		{ \+ var_is_singleton(ArgName) },
+		{ mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_in) }
+	->
+		ml_variable_type(Var, VarType),
+		ml_gen_var(Var, VarLval),
+		{ type_util__is_dummy_argument_type(VarType) ->
+			% 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.
+			Var_ArgName = "0"
+		;
+			ml_gen_box_or_unbox_rval(VarType, OrigType, lval(VarLval),
+				ArgRval),
+			ml_gen_c_code_for_rval(ArgRval, Var_ArgName)
+		},
+		{ string__format("\t%s = %s;\n", [s(ArgName), s(Var_ArgName)],
+			AssignInputString) }
+	;
+		% if the variable doesn't occur in the ArgNames list,
+		% it can't be used, so we just ignore it
+		{ AssignInputString = "" }
+	).
+
+% ml_gen_pragma_c_output_arg generates C code to assign the value of an output
+% arg for a `pragma c_code' declaration.
+%
+:- pred ml_gen_pragma_c_output_arg(ml_c_arg::in, string::out,
+		ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_gen_pragma_c_output_arg(ml_c_arg(Var, MaybeNameAndMode, OrigType),
+		AssignOutputString) -->
+	=(MLDSGenInfo),
+	{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
+	(
+		{ MaybeNameAndMode = yes(ArgName - Mode) },
+		{ \+ var_is_singleton(ArgName) },
+		{ \+ type_util__is_dummy_argument_type(OrigType) },
+		{ mode_to_arg_mode(ModuleInfo, Mode, OrigType, top_out) }
+	->
+		ml_variable_type(Var, VarType),
+		ml_gen_var(Var, VarLval),
+		{ ml_gen_box_or_unbox_rval(OrigType, VarType, lval(VarLval),
+			ArgRval) },
+		{ ml_gen_c_code_for_rval(ArgRval, Var_ArgName) },
+		{ string__format("\t%s = %s;\n", [s(Var_ArgName), s(ArgName)],
+			AssignOutputString) }
+	;
+		% if the variable doesn't occur in the ArgNames list,
+		% it can't be used, so we just ignore it
+		{ AssignOutputString = "" }
+	).
+
+	%
+	% XXX this is a bit of a hack --
+	% for `pragma c_code', we generate the C code for an mlds__rval
+	% directly rather than going via the MLDS
+	%
+:- pred ml_gen_c_code_for_rval(mlds__rval::in, string::out) is det.
+ml_gen_c_code_for_rval(ArgRval, Var_ArgName) :-
+	( ArgRval = lval(var(qual(ModuleName, VarName))) ->
+		SymName = mlds_module_name_to_sym_name(ModuleName),
+		llds_out__sym_name_mangle(SymName, MangledModuleName),
+		llds_out__name_mangle(VarName, MangledVarName),
+		string__append_list([MangledModuleName, "__",
+			MangledVarName], Var_ArgName)
+	; ArgRval = lval(mem_ref(lval(var(qual(ModuleName, VarName))))) ->
+		SymName = mlds_module_name_to_sym_name(ModuleName),
+		llds_out__sym_name_mangle(SymName, MangledModuleName),
+		llds_out__name_mangle(VarName, MangledVarName),
+		string__append_list(["*", MangledModuleName, "__",
+			MangledVarName], Var_ArgName)
+	;
+		sorry("complicated pragma c_code")
+	).
 
 %-----------------------------------------------------------------------------%
 %
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.19
diff -u -d -r1.19 mlds_to_c.m
--- mlds_to_c.m	1999/12/03 20:22:45	1.19
+++ mlds_to_c.m	1999/12/06 06:14:40
@@ -32,6 +32,7 @@
 
 :- implementation.
 
+:- import_module llds. % XXX needed for C interface types
 :- import_module llds_out. % XXX needed for llds_out__name_mangle.
 :- import_module globals, options, passes_aux.
 :- import_module builtin_ops, c_util, modules.
@@ -245,21 +246,43 @@
 		io__state, io__state).
 :- mode mlds_output_c_hdr_decls(in, in, di, uo) is det.
 
-% XXX not yet implemented
-mlds_output_c_hdr_decls(_, _) --> [].
+mlds_output_c_hdr_decls(Indent, ForeignCode) -->
+	% XXX we don't yet handle `pragma export' decls
+	{ ForeignCode = mlds__foreign_code(RevHeaderCode, _RevBodyCode,
+		_ExportDefns) },
+	{ HeaderCode = list__reverse(RevHeaderCode) },
+	io__write_list(HeaderCode, "\n", mlds_output_c_hdr_decl(Indent)).
+
+:- pred mlds_output_c_hdr_decl(indent, c_header_code, io__state, io__state).
+:- mode mlds_output_c_hdr_decl(in, in, di, uo) is det.
+
+mlds_output_c_hdr_decl(_Indent, Code - Context) -->
+	mlds_output_context(mlds__make_context(Context)),
+	io__write_string(Code).
 
 :- pred mlds_output_c_decls(indent, mlds__foreign_code, io__state, io__state).
 :- mode mlds_output_c_decls(in, in, di, uo) is det.
 
-% XXX not yet implemented
+% all of the declarations go in the header file or as c_code
 mlds_output_c_decls(_, _) --> [].
 
 :- pred mlds_output_c_defns(indent, mlds__foreign_code, io__state, io__state).
 :- mode mlds_output_c_defns(in, in, di, uo) is det.
 
-% XXX not yet implemented
-mlds_output_c_defns(_, _) --> [].
+mlds_output_c_defns(Indent, ForeignCode) -->
+	% XXX export decls
+	{ ForeignCode = mlds__foreign_code(_RevHeaderCode, RevBodyCode,
+		_ExportDefns) },
+	{ BodyCode = list__reverse(RevBodyCode) },
+	io__write_list(BodyCode, "\n", mlds_output_c_defn(Indent)).
 
+:- pred mlds_output_c_defn(indent, user_c_code, io__state, io__state).
+:- mode mlds_output_c_defn(in, in, di, uo) is det.
+
+mlds_output_c_defn(_Indent, user_c_code(Code, Context)) -->
+	mlds_output_context(mlds__make_context(Context)),
+	io__write_string(Code).
+
 %-----------------------------------------------------------------------------%
 %
 % Code to output declarations and definitions
@@ -1409,18 +1432,16 @@
 	%
 	% foreign language interfacing
 	%
-mlds_output_atomic_stmt(_Indent, target_code(_TargetLang, _CodeString), _) -->
-	{ error("mlds_to_c.m: sorry, target_code not implemented") }.
-/*
-		target_code(target_lang, string)
-			% Do whatever is specified by the string,
-			% which can be any piece of code in the specified
-			% target language (C, assembler, or whatever)
-			% that does not have any non-local flow of control.
-*/
+mlds_output_atomic_stmt(_Indent, target_code(TargetLang, CodeString), Context) -->
+	( { TargetLang = lang_C } ->
+		mlds_output_context(Context),
+		io__write_string(CodeString)
+	;
+		{ error("mlds_to_c.m: sorry, target_code only works for lang_C") }
+	).
 
-:- pred mlds_output_init_args(list(rval), list(mlds__type), mlds__context,
-		int, mlds__lval, tag, indent, io__state, io__state).
+:- pred mlds_output_init_args(list(mlds__rval), list(mlds__type), mlds__context,
+		int, mlds__lval, mlds__tag, indent, io__state, io__state).
 :- mode mlds_output_init_args(in, in, in, in, in, in, in, di, uo) is det.
 
 mlds_output_init_args([_|_], [], _, _, _, _, _) -->
@@ -1752,7 +1773,7 @@
 
 %-----------------------------------------------------------------------------%
 
-:- pred mlds_output_tag(tag, io__state, io__state).
+:- pred mlds_output_tag(mlds__tag, io__state, io__state).
 :- mode mlds_output_tag(in, di, uo) is det.
 
 mlds_output_tag(Tag) -->

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