[m-dev.] for review: implement pragma export for MLDS backend

[Peter Ross]

Hi,

For Fergus to review.
I would imagine DJ should also have a look at it.


===================================================================


Estimated hours taken: 12

Implement `pragma export' for the MLDS backend.

compiler/mlds.m:
    Add a new type mlds__pragma_export.  It records the exported name,
    the MLDS name of the exported procedure and its function parameters.

compiler/ml_code_gen.m:
    For every pragma export declaration, we associate the information
    used to generate the function prototype for the MLDS entity.

compiler/mlds_to_c.m:
    Output a declaration for the exported procedure to the header file.
    Output a definition for the exported procedure to the source file.
    The declaration is constructed by outputing the function prototype
    for the MLDS function, but using the exported name instead.
    The definition is constructed by defining a function which directly
    calls the MLDS function.

compiler/hlds_module.m:
    Add a prog_context field to the type pragma_exported_proc.

compiler/make_hlds.m:
    Fill in the context field of pragma_exported_proc.

compiler/dead_proc_elim.m:
compiler/export.m:
    Ignore the new context field in they type pragma_exported_proc.
   

Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.56
diff -u -r1.56 dead_proc_elim.m
--- compiler/dead_proc_elim.m	2000/06/27 05:34:25	1.56
+++ compiler/dead_proc_elim.m	2000/07/12 15:44:39
@@ -163,7 +163,7 @@
 dead_proc_elim__initialize_pragma_exports([], Queue, Queue, Needed, Needed).
 dead_proc_elim__initialize_pragma_exports([PragmaProc | PragmaProcs],
 		Queue0, Queue, Needed0, Needed) :-
-	PragmaProc = pragma_exported_proc(PredId, ProcId, _CFunction),
+	PragmaProc = pragma_exported_proc(PredId, ProcId, _CFunction, _Ctxt),
 	queue__put(Queue0, proc(PredId, ProcId), Queue1),
 	map__set(Needed0, proc(PredId, ProcId), no, Needed1),
 	dead_proc_elim__initialize_pragma_exports(PragmaProcs,
Index: compiler/export.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.32
diff -u -r1.32 export.m
--- compiler/export.m	2000/02/16 06:05:52	1.32
+++ compiler/export.m	2000/07/12 15:44:41
@@ -84,7 +84,7 @@
 
 export__get_c_export_decls_2(_Preds, [], []).
 export__get_c_export_decls_2(Preds, [E|ExportedProcs], C_ExportDecls) :-
-	E = pragma_exported_proc(PredId, ProcId, C_Function),
+	E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
 	get_export_info(Preds, PredId, ProcId, _Exported, C_RetType,
 		_DeclareReturnVal, _FailureAction, _SuccessAction,
 		HeadArgInfoTypes),
@@ -164,7 +164,7 @@
 
 export__to_c(_Preds, [], _Module, []).
 export__to_c(Preds, [E|ExportedProcs], Module, ExportedProcsCode) :-
-	E = pragma_exported_proc(PredId, ProcId, C_Function),
+	E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
 	get_export_info(Preds, PredId, ProcId, Exported,
 		C_RetType, MaybeDeclareRetval, MaybeFail, MaybeSucceed,
 		ArgInfoTypes),
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.56
diff -u -r1.56 hlds_module.m
--- compiler/hlds_module.m	2000/05/16 21:23:24	1.56
+++ compiler/hlds_module.m	2000/07/12 15:44:45
@@ -48,7 +48,8 @@
 	--->	pragma_exported_proc(
 			pred_id,
 			proc_id,
-			string	% the name of the C function
+			string,	% the name of the C function
+			prog_context
 		).
 
 	% This structure contains the information we need to generate
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.336
diff -u -r1.336 make_hlds.m
--- compiler/make_hlds.m	2000/06/06 05:45:08	1.336
+++ compiler/make_hlds.m	2000/07/12 15:45:10
@@ -786,7 +786,7 @@
 			{ module_info_get_pragma_exported_procs(Module0,
 				PragmaExportedProcs0) },
 			{ NewExportedProc = pragma_exported_proc(PredId,
-				ProcId, C_Function) },
+				ProcId, C_Function, Context) },
 			{ PragmaExportedProcs = 
 				[NewExportedProc|PragmaExportedProcs0]},
 			{ module_info_set_pragma_exported_procs(Module0,
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.52
diff -u -r1.52 ml_code_gen.m
--- compiler/ml_code_gen.m	2000/06/06 06:21:22	1.52
+++ compiler/ml_code_gen.m	2000/07/12 15:45:17
@@ -691,12 +691,9 @@
 	{ 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
-	%
-	{ C_Exports = [] },
+	{ ml_gen_pragma_export(ModuleInfo, MLDS_PragmaExports) },
 	{ MLDS_ForeignCode = mlds__foreign_code(C_Header_Info, User_C_Code,
-			C_Exports) }.
+			MLDS_PragmaExports) }.
 
 :- pred ml_gen_imports(module_info, mlds__imports).
 :- mode ml_gen_imports(in, out) is det.
@@ -716,6 +713,35 @@
 
 %-----------------------------------------------------------------------------%
 %
+% For each pragma export declaration we associate with it the 
+% information used to generate the function prototype for the MLDS
+% entity.
+%
+
+:- pred ml_gen_pragma_export(module_info, list(mlds__pragma_export)).
+:- mode ml_gen_pragma_export(in, out) is det.
+
+ml_gen_pragma_export(ModuleInfo, MLDS_PragmaExports) :-
+	module_info_get_pragma_exported_procs(ModuleInfo, PragmaExports),
+	list__map(ml_gen_pragma_export_proc(ModuleInfo),
+			PragmaExports, MLDS_PragmaExports).
+
+:- pred ml_gen_pragma_export_proc(module_info::in,
+		pragma_exported_proc::in, mlds__pragma_export::out) is det.
+
+ml_gen_pragma_export_proc(ModuleInfo,
+		pragma_exported_proc(PredId, ProcId, C_Name, ProgContext),
+		ML_Defn) :-
+
+	MLDS_Name = ml_gen_proc_label(ModuleInfo, PredId, ProcId),
+	MLDS_FuncParams = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+	MLDS_Context = mlds__make_context(ProgContext),
+	ML_Defn = ml_pragma_export(C_Name, MLDS_Name, MLDS_FuncParams,
+			MLDS_Context).
+
+
+%-----------------------------------------------------------------------------%
+%
 % Stuff to generate MLDS code for HLDS predicates & functions.
 %
 
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.27
diff -u -r1.27 mlds.m
--- compiler/mlds.m	2000/06/06 05:45:20	1.27
+++ compiler/mlds.m	2000/07/12 15:45:20
@@ -607,10 +607,21 @@
 	---> mlds__foreign_code(
 		c_header_info,
 		list(user_c_code),
-		list(c_export)		% XXX we will need to modify
-					% export.m to handle different
-					% target languages
+		list(mlds__pragma_export)
 	).
+
+	%
+	% Information required to generate code for each
+	% `pragma export'.
+	%
+:- type mlds__pragma_export
+	---> ml_pragma_export(
+		string,			% Exported name
+		mlds__entity_name,	% MLDS name for exported entity
+		mlds__func_params,	% MLDS function parameters
+		mlds__context
+	).
+
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.40
diff -u -r1.40 mlds_to_c.m
--- compiler/mlds_to_c.m	2000/06/14 14:54:07	1.40
+++ compiler/mlds_to_c.m	2000/07/12 15:45:27
@@ -123,7 +123,7 @@
 	{ MLDS = mlds(ModuleName, ForeignCode, Imports, Defns) },
 	mlds_output_hdr_start(Indent, ModuleName), io__nl,
 	mlds_output_hdr_imports(Indent, Imports), io__nl,
-	mlds_output_c_hdr_decls(Indent, ForeignCode), io__nl,
+	mlds_output_c_hdr_decls(MLDS_ModuleName, Indent, ForeignCode), io__nl,
 	%
 	% The header file must contain _definitions_ of all public types,
 	% but only _declarations_ of all public variables, constants,
@@ -206,7 +206,7 @@
 	mlds_output_src_start(Indent, ModuleName), io__nl,
 	mlds_output_src_imports(Indent, Imports), io__nl,
 	mlds_output_c_decls(Indent, ForeignCode), io__nl,
-	mlds_output_c_defns(Indent, ForeignCode), io__nl,
+	mlds_output_c_defns(MLDS_ModuleName, Indent, ForeignCode), io__nl,
 	%
 	% The public types have already been defined in the
 	% header file, and the public vars, consts, and functions
@@ -308,16 +308,17 @@
 % C interface stuff
 %
 
-:- pred mlds_output_c_hdr_decls(indent, mlds__foreign_code,
+:- pred mlds_output_c_hdr_decls(mlds_module_name, indent, mlds__foreign_code,
 		io__state, io__state).
-:- mode mlds_output_c_hdr_decls(in, in, di, uo) is det.
+:- mode mlds_output_c_hdr_decls(in, in, in, di, uo) is det.
 
-mlds_output_c_hdr_decls(Indent, ForeignCode) -->
-	% XXX we don't yet handle `pragma export' decls
+mlds_output_c_hdr_decls(ModuleName, Indent, ForeignCode) -->
 	{ ForeignCode = mlds__foreign_code(RevHeaderCode, _RevBodyCode,
-		_ExportDefns) },
+		ExportDefns) },
 	{ HeaderCode = list__reverse(RevHeaderCode) },
-	io__write_list(HeaderCode, "\n", mlds_output_c_hdr_decl(Indent)).
+	io__write_list(HeaderCode, "\n", mlds_output_c_hdr_decl(Indent)),
+	io__write_list(ExportDefns, "\n",
+			mlds_output_pragma_export_decl(ModuleName, 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.
@@ -332,15 +333,18 @@
 % 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.
+:- pred mlds_output_c_defns(mlds_module_name, indent, mlds__foreign_code,
+		io__state, io__state).
+:- mode mlds_output_c_defns(in, in, in, di, uo) is det.
 
-mlds_output_c_defns(Indent, ForeignCode) -->
-	% XXX export decls
+mlds_output_c_defns(ModuleName, Indent, ForeignCode) -->
 	{ ForeignCode = mlds__foreign_code(_RevHeaderCode, RevBodyCode,
-		_ExportDefns) },
+		ExportDefns) },
 	{ BodyCode = list__reverse(RevBodyCode) },
-	io__write_list(BodyCode, "\n", mlds_output_c_defn(Indent)).
+	io__write_list(BodyCode, "\n", mlds_output_c_defn(Indent)),
+	io__write_list(ExportDefns, "\n",
+			mlds_output_pragma_export_defn(ModuleName, 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.
@@ -349,6 +353,55 @@
 	mlds_output_context(mlds__make_context(Context)),
 	io__write_string(Code).
 
+:- pred mlds_output_pragma_export_decl(mlds_module_name, indent,
+		mlds__pragma_export, io__state, io__state).
+:- mode mlds_output_pragma_export_decl(in, in, in, di, uo) is det.
+
+mlds_output_pragma_export_decl(ModuleName, Indent,
+		ml_pragma_export(C_name, _MLDS_Name, Signature, Context)) -->
+	{ Name = string(ModuleName, C_name) },
+	mlds_indent(Context, Indent),
+	mlds_output_func_decl(Indent, Name, Context, Signature),
+	io__write_string(";").
+
+:- pred mlds_output_pragma_export_defn(mlds_module_name, indent,
+		mlds__pragma_export, io__state, io__state).
+:- mode mlds_output_pragma_export_defn(in, in, in, di, uo) is det.
+
+mlds_output_pragma_export_defn(ModuleName, Indent,
+		ml_pragma_export(C_name, MLDS_Name, Signature, Context)) -->
+	{ Name = string(ModuleName, C_name) },
+	mlds_indent(Context, Indent),
+	mlds_output_func_decl(Indent, Name, Context, Signature),
+	io__write_string("{\n"),
+	mlds_indent(Context, Indent),
+	mlds_output_pragma_export_defn_body(ModuleName, MLDS_Name, Signature),
+	io__write_string("}\n").
+
+:- pred mlds_output_pragma_export_defn_body(mlds_module_name, mlds__entity_name,
+		func_params, io__state, io__state).
+:- mode mlds_output_pragma_export_defn_body(in, in, in, di, uo) is det.
+
+mlds_output_pragma_export_defn_body(ModuleName, FuncName, Signature) -->
+	{ Signature = mlds__func_params(Parameters, RetTypes) },
+	{ list__map(fst, Parameters, Names) },
+	{ list__map((pred(Name::in, QualName::out) is det :-
+			QualName = qual(ModuleName, Name)),
+			Names, QualNames) },
+
+	( { RetTypes = [] } ->
+		io__write_string("\t")
+	; { RetTypes = [_] } ->
+		io__write_string("\treturn ")
+	;
+		{ error("mlds_output_pragma_export: multiple return types") }
+	),
+
+	mlds_output_fully_qualified_name(qual(ModuleName, FuncName)),
+	io__write_string("("),
+	io__write_list(QualNames, ",", mlds_output_fully_qualified_name),
+	io__write_string(");\n").
+	
 %-----------------------------------------------------------------------------%
 %
 % Code to output declarations and definitions
@@ -539,7 +592,7 @@
 		{ DefnBody = mlds__function(MaybePredProcId, Signature,
 			_MaybeBody) },
 		mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id),
-		mlds_output_func_decl(Indent, Name, Context, Signature)
+		mlds_output_func_decl(Indent, mlds(Name), Context, Signature)
 	;
 		{ DefnBody = mlds__class(ClassDefn) },
 		mlds_output_class_decl(Indent, Name, ClassDefn)
@@ -826,7 +879,7 @@
 :- mode mlds_output_func(in, in, in, in, in, di, uo) is det.
 
 mlds_output_func(Indent, Name, Context, Signature, MaybeBody) -->
-	mlds_output_func_decl(Indent, Name, Context, Signature),
+	mlds_output_func_decl(Indent, mlds(Name), Context, Signature),
 	(
 		{ MaybeBody = no },
 		io__write_string(";\n")
@@ -896,7 +949,12 @@
 		io__write_string("}\n")	% end the function
 	).
 
-:- pred mlds_output_func_decl(indent, qualified_entity_name, mlds__context,
+:- type func_name
+	--->	mlds(qualified_entity_name)
+	;	string(mlds_module_name, string)
+	.
+
+:- pred mlds_output_func_decl(indent, func_name, mlds__context,
 		func_params, io__state, io__state).
 :- mode mlds_output_func_decl(in, in, in, in, di, uo) is det.
 
@@ -910,35 +968,41 @@
 		{ error("mlds_output_func: multiple return types") }
 	),
 	io__write_char(' '),
-	mlds_output_fully_qualified_name(Name),
-	mlds_output_params(Indent, Name, Context, Parameters),
+	(
+		{ Name = mlds(QualifiedName) },
+		mlds_output_fully_qualified_name(QualifiedName),
+		{ QualifiedName = qual(ModuleName, _) }
+	;
+		{ Name = string(ModuleName, StringName) },
+		io__write_string(StringName)
+	),
+	mlds_output_params(Indent, ModuleName, Context, Parameters),
 	( { RetTypes = [RetType2] } ->
 		mlds_output_type_suffix(RetType2)
 	;
 		[]
 	).
 
-:- pred mlds_output_params(indent, qualified_entity_name, mlds__context,
+:- pred mlds_output_params(indent, mlds_module_name, mlds__context,
 		mlds__arguments, io__state, io__state).
 :- mode mlds_output_params(in, in, in, in, di, uo) is det.
 
-mlds_output_params(Indent, FuncName, Context, Parameters) -->
+mlds_output_params(Indent, ModuleName, Context, Parameters) -->
 	io__write_char('('),
 	( { Parameters = [] } ->
 		io__write_string("void")
 	;
 		io__nl,
 		io__write_list(Parameters, ",\n",
-			mlds_output_param(Indent + 1, FuncName, Context))
+			mlds_output_param(Indent + 1, ModuleName, Context))
 	),
 	io__write_char(')').
 
-:- pred mlds_output_param(indent, qualified_entity_name, mlds__context,
+:- pred mlds_output_param(indent, mlds_module_name, mlds__context,
 		pair(mlds__entity_name, mlds__type), io__state, io__state).
 :- mode mlds_output_param(in, in, in, in, di, uo) is det.
 
-mlds_output_param(Indent, qual(ModuleName, _FuncName), Context,
-		Name - Type) -->
+mlds_output_param(Indent, ModuleName, Context, Name - Type) -->
 	mlds_indent(Context, Indent),
 	mlds_output_data_decl(qual(ModuleName, Name), Type).
 

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