[m-dev.] for review: fix inter-module optimization bugs

Simon Taylor stayl at cs.mu.OZ.AU
Wed Feb 7 14:24:14 AEDT 2001


Estimated hours taken: 3

Fix bugs in `:- pragma import' and `:- pragma export' with
inter-module optimizaton reported by Peter Ross (bug #131069).

compiler/mercury_to_mercury.m:
	The code to output `:- pragma import' declarations was
	writing `:- pragma import(p(Arg1::in, Arg2::out), "imported")'.
	The correct output is `:- pragma import(p(in, out), "imported")'.

compiler/mercury_compile.m:
	For modules containing `:- pragma export' declarations, add
	":- pragma c_header_code("#include ModuleName.h")." to
	the `.opt' file so the C compiler can find the function
	prototypes for Mercury predicates exported to C when
	compiling the C code in the `.opt' file.

	Write the `.h' file for a module when writing the `.opt' file
	when using the LLDS backend to avoid trying to use the `.h' file
	before it has been created.

tests/valid/Mmakefile:
tests/valid/intermod_pragma_import.m:
tests/valid/intermod_pragma_import2.m:
	Test case.

Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.192
diff -u -u -r1.192 mercury_compile.m
--- compiler/mercury_compile.m	2001/02/05 06:55:32	1.192
+++ compiler/mercury_compile.m	2001/02/07 03:19:00
@@ -916,10 +916,56 @@
 	globals__io_lookup_bool_option(verbose, Verbose),
 	globals__io_lookup_bool_option(statistics, Stats),
 	globals__io_lookup_bool_option(termination, Termination),
+	globals__io_get_target(Target),
+	globals__io_lookup_bool_option(highlevel_code, HighLevelCode),
 
 	( { MakeOptInt = yes } ->
-		intermod__write_optfile(HLDS0, HLDS1),
+		{ module_info_name(HLDS0, ModuleName) },
+		{ module_info_get_pragma_exported_procs(HLDS0,
+			PragmaExportedProcs) },
 
+		%
+		% If the module contains `:- pragma export' declarations,
+		% we need to include a
+		% `:- pragma foreign_decl(c, "#include ModuleName.h").'
+		% declaration in the `.opt' file so the C compiler
+		% can find the function declarations for the exported
+		% procedures.
+		%
+
+		(
+			{ PragmaExportedProcs = [_|_] },
+			{ Target = c },
+
+			% High-level code uses a different mechanism
+			% to handle `:- pragma export' which doesn't
+			% need any special treatment here.
+			{ HighLevelCode = no }
+		->
+			% XXX Normally with `--split-c-files,
+			% `get_header_file_include_string'
+			% will return "#include ../ModuleName.h"
+			% We can't explicitly look for `../ModuleName.h'
+			% here because the `.opt' file might be part
+			% of a library, so we need to use the
+			% include path to find the header file.
+			%
+			% I'm not sure why we ever explicitly need the `../'.
+			% The parent directory should always be in the
+			% include path.
+			{ LookInParentDirectory = no },
+
+			get_header_file_include_string(ModuleName,
+				LookInParentDirectory, IncludeString),
+			{ term__context_init(Context) },
+			{ module_add_foreign_decl(c, IncludeString, Context,
+				HLDS0, HLDS0a) }
+		;
+			{ HLDS0a = HLDS0 }
+		),
+
+		intermod__write_optfile(HLDS0a, HLDS1),
+
 		% If intermod_unused_args is being performed, run polymorphism,
 		% mode analysis and determinism analysis, then run unused_args
 		% to append the unused argument information to the `.opt.tmp' 
@@ -927,6 +973,7 @@
 		( { IntermodArgs = yes ; Termination = yes } ->
 			mercury_compile__frontend_pass_2_by_phases(
 				HLDS1, HLDS2, FoundModeError),
+			{ DonePolymorphism = yes `with_type` bool },
 			( { FoundModeError = no } ->
 				( { IntermodArgs = yes } ->
 					mercury_compile__maybe_unused_args(
@@ -936,19 +983,58 @@
 				),
 				( { Termination = yes } ->
 					mercury_compile__maybe_termination(
-						HLDS3, Verbose, Stats, HLDS)
+						HLDS3, Verbose, Stats, HLDS4)
 				;
-					{ HLDS = HLDS3 }
+					{ HLDS4 = HLDS3 }
 				)
 					
 			;
 				io__set_exit_status(1),
-				{ HLDS = HLDS2 }
+				{ HLDS4 = HLDS2 }
 			)
+		;
+			{ DonePolymorphism = no },
+			{ HLDS4 = HLDS1 }
+		),
+		(
+			{ PragmaExportedProcs = [_|_] },
+			{ Target = c },
+
+			% High-level code uses a different mechanism
+			% to handle `:- pragma export' which doesn't
+			% need any special treatment here.
+			{ HighLevelCode = no }
+		->
+			%
+			% If there are `:- pragma export' declarations
+			% in this module, we need to produce the
+			% `.h' file now, because users of the `.opt'
+			% file may need it.
+			%
+	
+			(
+				{ DonePolymorphism = yes },
+				{ HLDS5 = HLDS4 }
+			;
+				{ DonePolymorphism = no },
+				% Ensure that polymorphism has adjusted the
+				% argument lists of procedures exported to C.
+				% XXX We should only process the
+				% exported predicates.
+				mercury_compile__maybe_polymorphism(HLDS4,
+					Verbose, Stats, HLDS5)
+			),
+
+			% XXX We should only process the exported predicates.
+			mercury_compile__map_args_to_regs(HLDS5,
+				Verbose, Stats, HLDS),
+			{ export__get_foreign_export_decls(HLDS,
+				Foreign_ExportDecls) },
+			export__produce_header_file(Foreign_ExportDecls,
+				ModuleName)
 		;
-			{ HLDS = HLDS1 }
+			{ HLDS = HLDS4 }
 		),
-		{ module_info_name(HLDS, ModuleName) },
 		module_name_to_file_name(ModuleName, ".opt", yes, OptName),
 		update_interface(OptName),
 		touch_interface_datestamp(ModuleName, ".optdate")
@@ -2427,19 +2513,10 @@
 		{ C_HeaderCode = C_HeaderCode0 }
 	;
 		{ C_ExportDecls = [_|_] },
-		module_name_to_file_name(ModuleName, ".h", no, HeaderFileName),
-                globals__io_lookup_bool_option(split_c_files, SplitFiles),
-                { 
-			SplitFiles = yes,
-                        string__append_list(
-                                ["#include ""../", HeaderFileName, """\n"],
-				IncludeString)
-                ;
-			SplitFiles = no,
-                        string__append_list(
-				["#include """, HeaderFileName, """\n"],
-				IncludeString)
-                },
+		globals__io_lookup_bool_option(split_c_files,
+			HeaderInParentDirectory),
+		get_header_file_include_string(ModuleName,
+			HeaderInParentDirectory, IncludeString),
 
 		{ term__context_init(Context) },
 		{ Include = foreign_decl_code(c, IncludeString, Context) },
@@ -2449,6 +2526,24 @@
 			% first.
 		{ list__append(C_HeaderCode0, [Include], C_HeaderCode) }
 	).
+
+:- pred get_header_file_include_string(module_name, bool, string,
+		io__state, io__state).
+:- mode get_header_file_include_string(in, in, out, di, uo) is det.
+
+get_header_file_include_string(ModuleName, SplitFiles, IncludeString) -->
+	module_name_to_file_name(ModuleName, ".h", no, HeaderFileName),
+	{ 
+		SplitFiles = yes,
+		string__append_list(
+			["#include ""../", HeaderFileName, """\n"],
+			IncludeString)
+	;
+		SplitFiles = no,
+		string__append_list(
+			["#include """, HeaderFileName, """\n"],
+			IncludeString)
+	}.
 
 :- pred get_c_body_code(foreign_body_info, list(user_foreign_code)).
 :- mode get_c_body_code(in, out) is det.
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.181
diff -u -u -r1.181 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m	2000/11/23 04:32:40	1.181
+++ compiler/mercury_to_mercury.m	2001/02/07 03:19:38
@@ -2223,15 +2223,38 @@
 mercury_output_pragma_foreign_code(Attributes, PredName, PredOrFunc, Vars0,
 		VarSet, PragmaCode) -->
 	(
-		{ PragmaCode = import(_, _, _, _) }
-	->
-		io__write_string(":- pragma import(")
-	;
-		io__write_string(":- pragma foreign_code("),
-		{ foreign_language(Attributes, Lang) },
-		mercury_output_foreign_language_string(Lang),
-		io__write_string(", ")
-	),
+		{ PragmaCode = import(C_Function, _, _, _) },
+		% The predicate or function arguments in a `:- pragma import'
+		% declaration are not named.
+		{ ImportModes = list__map(
+			(func(pragma_var(_, _, ImportMode)) = ImportMode),
+			Vars0) },
+
+		mercury_output_pragma_import(PredName, PredOrFunc,
+			ImportModes, Attributes, C_Function)
+	;
+		{ PragmaCode = ordinary(_, _) },
+		mercury_output_pragma_foreign_code_2(Attributes, PredName,
+			PredOrFunc, Vars0, VarSet, PragmaCode)
+	;
+		{ PragmaCode = nondet(_, _, _, _, _, _, _, _, _) },
+		mercury_output_pragma_foreign_code_2(Attributes, PredName,
+			PredOrFunc, Vars0, VarSet, PragmaCode)
+	).
+
+:- pred mercury_output_pragma_foreign_code_2(
+		pragma_foreign_code_attributes, sym_name,
+		pred_or_func, list(pragma_var), prog_varset,
+		pragma_foreign_code_impl, io__state, io__state).
+:- mode mercury_output_pragma_foreign_code_2(
+		in, in, in, in, in, in, di, uo) is det.
+
+mercury_output_pragma_foreign_code_2(Attributes, PredName, PredOrFunc, Vars0,
+		VarSet, PragmaCode) -->
+	io__write_string(":- pragma foreign_code("),
+	{ foreign_language(Attributes, Lang) },
+	mercury_output_foreign_language_string(Lang),
+	io__write_string(", "),
 	mercury_output_sym_name(PredName),
 	{
 		PredOrFunc = predicate,
@@ -2288,10 +2311,9 @@
 		mercury_output_foreign_code_string(Shared),
 		io__write_string(")")
 	;
-		{ PragmaCode = import(Name, _, _, _) },
-		io__write_string(""""),
-		io__write_string(Name),
-		io__write_string("""")
+		{ PragmaCode = import(_, _, _, _) },
+		% This should be handle in mercury_output_pragma_foreign_code.
+		{ error("mercury_output_pragma_foreign_code_2") }
 	),
 	io__write_string(").\n").
 
@@ -2445,9 +2467,9 @@
 	),
 	io__write_string(", "),
 	mercury_output_pragma_foreign_attributes(Attributes),
-	io__write_string(", "),
+	io__write_string(", """),
 	io__write_string(C_Function),
-	io__write_string(").\n").
+	io__write_string(""").\n").
 
 :- pred mercury_output_pragma_export(sym_name, pred_or_func, list(mode),
 	string, io__state, io__state).
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.82
diff -u -u -r1.82 Mmakefile
--- tests/valid/Mmakefile	2001/01/21 03:01:12	1.82
+++ tests/valid/Mmakefile	2001/02/06 04:18:01
@@ -82,6 +82,7 @@
 	intermod_lambda.m \
 	intermod_nested_module.m \
 	intermod_nested_uniq.m \
+	intermod_pragma_import.m \
 	intermod_quote.m \
 	intermod_record.m \
 	intermod_test.m \
@@ -240,6 +241,8 @@
 MCFLAGS-intermod_nested_module2	= --intermodule-optimization
 MCFLAGS-intermod_nested_uniq	= --intermodule-optimization
 MCFLAGS-intermod_nested_uniq2	= --intermodule-optimization
+MCFLAGS-intermod_pragma_import	= --intermodule-optimization
+MCFLAGS-intermod_pragma_import2	= --intermodule-optimization
 MCFLAGS-intermod_quote		= --intermodule-optimization
 MCFLAGS-intermod_quote2		= --intermodule-optimization
 MCFLAGS-intermod_record		= --intermodule-optimization
Index: tests/valid/intermod_pragma_import.m
===================================================================
RCS file: intermod_pragma_import.m
diff -N intermod_pragma_import.m
--- /dev/null	Wed Feb  7 14:19:57 2001
+++ intermod_pragma_import.m	Wed Feb  7 12:25:25 2001
@@ -0,0 +1,13 @@
+:- module intermod_pragma_import.
+
+:- interface.
+
+:- pred q(T::in, int::out) is det.
+
+:- implementation.
+
+:- import_module intermod_pragma_import2.
+
+q(A, B) :-
+        implemented_as_pragma_import(A, B).
+
Index: tests/valid/intermod_pragma_import2.m
===================================================================
RCS file: intermod_pragma_import2.m
diff -N intermod_pragma_import2.m
--- /dev/null	Wed Feb  7 14:19:57 2001
+++ intermod_pragma_import2.m	Wed Feb  7 12:25:25 2001
@@ -0,0 +1,14 @@
+:- module intermod_pragma_import2.
+
+:- interface.
+
+:- pred implemented_as_pragma_import(T::in, int::out) is det.
+
+:- implementation.
+
+:- pred p(T::in, int::out) is det.
+
+p(_, 4).
+
+:- pragma import(implemented_as_pragma_import(in, out), "imported").
+:- pragma export(p(in, out), "imported").
--------------------------------------------------------------------------
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