[m-dev.] for review: pragma foreign_code for MC++ (part 1/2)
Tyson Dowd
trd at cs.mu.OZ.AU
Fri Nov 10 19:49:21 AEDT 2000
Hi,
I'm about to go away for a week, so no rush on the review since I
probably won't be able to address the comments for a while.
My motivation for getting the change to this point is that I need this
functionality to implement the IL backend library changes in a way that
can be committed to CVS.
With this level of support for foreign languages, I can write
a side-by-side re-implementation of library procedures in Managed C++.
Previously I've had to do it by using a lot of #ifdefs.
===================================================================
Estimated hours taken: 50
Implement pragma foreign_code for Managed C++.
Currently you can only write MC++ code if your backend is capable of
generating use MC++ as its "native" foreign language. The IL backend is
the only backend that does this at the moment (the other backends have C
as their "native" foreign language).
Most of the machinery is in place to call from C to (normal) C++
but there is little work done on actually spitting out the C++ code into
a separate file. The IL backend does this step already with managed C++.
The intention is to turn foreign_code for C++ into a pragma import
(which imports the C++ function from a separate file) and
foreign_code for C (which calls the imported function). The C++ code
will be inserted into a separate file that is compiled using C linkage.
The important improvement this change gives is that you can write a
module with a C and a MC++ implementations side-by-side. The target
backend will select the most appropriate foreign language to use.
You can override its choice using --use-foreign-language. Later on
we will probably want more flexibility than just a single language
selection option).
This change also implements :- pragma foreign_decl, which allows header
file style declarations to be written in languages other than C.
compiler/code_gen.m:
Reject code that is not C when generating LLDS.
compiler/export.m:
Start renaming C as foreign.
Reject code that is not C when generating exports.
compiler/foreign.m:
A new module to handle foreign language interfacing.
The bulk of the code for pragma import has been moved here from
make_hlds.
compiler/globals.m:
Convert foreign language names to foreign_language.
This code has been moved closer to the similar conversion we do
for target language names.
Add globals__io_lookup_foreign_language_option to make it easier
to deterministically lookup the options relating to foreign
languages.
compiler/hlds_module.m:
Move module_add_foreign_decl and module_add_foreign_body_code
from make_hlds.m (where they were called module_add_c_header and
module_add_c_code).
compiler/hlds_out.m:
Write the foreign language out in HLDS dumps.
compiler/llds.m:
Change foreign_header_info to foreign_decl_info.
Change definitions of foreign_decl_code and foreign_body_code to
include the language.
compiler/llds_out.m:
Reject code that is not C when writing out LLDS.
compiler/make_hlds.m:
Add foriegn language information to the bodys and decls when
creating them.
Update error messages to refer to foreign code instead of C
code.
Use foreign.m to generate interfaces from the backend language
to the foreign language.
Hardcode C as the language for fact tables.
compiler/mercury_compile.m:
Collect the appropriate foreign language code together for
output to the backend.
compiler/intermod.m:
compiler/mercury_to_mercury.m:
Output the foreign language string.
Change a few names to foreign_code instead of c_code.
compiler/ml_code_gen.m:
Filter the foreign language bodys and decls so that we only get
the ones we are in (given by the use-foreign-language option).
compiler/mlds_to_c.m:
Abort if we are given non C foreign language code to output
(we might handle it here in future, or we might handle it
elsewhere).
compiler/mlds_to_ilasm.m:
Abort if we are given non MC++ foreign language code to output
(we might handle it here in future, or we might handle it
elsewhere).
compiler/options.m:
compiler/handle_options.m:
Add --use-foreign-language as a user option to control the
preferred foreign language to use as the implementation of this
module.
Add backend_foreign_language as an internal option which stores
the foreign language that the compiler will use as a default
(e.g. the natural foreign language for the backend to use).
Set the preferred backend foreign language depending on the
target.
compiler/prog_data.m:
Add managedcplusplus as a new alternative for the
foreign_language type.
Make c_header_code into foreign_decl.
Give the foreign language for foreign_code as an attribute of
the code.
Write code to turn attributes into a list of strings (suitable
for writing out by mercury_to_mercury). This fixes what appears
to be a bug in tabled_for_io -- the tabled_for_io attribute was not
being written out. Structure the code so this bug is
difficult to repeat in future.
compiler/prog_io_pragma.m:
Parse foreign_decl.
Turn c_header_code into a special case of foreign_decl.
compiler/*.m:
Remove the language field from pragma_foreign_code, it is now an
attribute of the code.
Various type and variable renamings.
tests/invalid/pragma_c_code_and_clauses1.err_exp:
tests/invalid/pragma_c_code_dup_var.err_exp:
tests/warnings/singleton_test.exp:
Update the tests to reflect the new error messages talking
about :- pragma foreign_code rather than :- pragma c_code.
Index: compiler/assertion.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/assertion.m,v
retrieving revision 1.8
diff -u -r1.8 assertion.m
--- compiler/assertion.m 2000/08/09 07:46:16 1.8
+++ compiler/assertion.m 2000/10/16 00:18:34
@@ -548,8 +548,8 @@
equal_goals(IfA, IfB, Subst1, Subst2),
equal_goals(ThenA, ThenB, Subst2, Subst3),
equal_goals(ElseA, ElseB, Subst3, Subst).
-equal_goals(pragma_foreign_code(Lang, Attribs, PredId, _, VarsA, _, _, _) - _,
- pragma_foreign_code(Lang, Attribs, PredId, _, VarsB, _, _, _) -
+equal_goals(pragma_foreign_code(Attribs, PredId, _, VarsA, _, _, _) - _,
+ pragma_foreign_code(Attribs, PredId, _, VarsB, _, _, _) -
_, Subst0, Subst) :-
equal_vars(VarsA, VarsB, Subst0, Subst).
equal_goals(par_conj(GoalAs, _) - _, par_conj(GoalBs, _) - _, Subst0, Subst) :-
@@ -652,8 +652,8 @@
assertion__normalise_goal(call(A,B,C,D,E,F) - GI, call(A,B,C,D,E,F) - GI).
assertion__normalise_goal(generic_call(A,B,C,D) - GI, generic_call(A,B,C,D)-GI).
assertion__normalise_goal(unify(A,B,C,D,E) - GI, unify(A,B,C,D,E) - GI).
-assertion__normalise_goal(pragma_foreign_code(A,B,C,D,E,F,G,H) - GI,
- pragma_foreign_code(A,B,C,D,E,F,G,H) - GI).
+assertion__normalise_goal(pragma_foreign_code(A,B,C,D,E,F,G) - GI,
+ pragma_foreign_code(A,B,C,D,E,F,G) - GI).
assertion__normalise_goal(conj(Goals0) - GI, conj(Goals) - GI) :-
assertion__normalise_conj(Goals0, Goals).
assertion__normalise_goal(switch(A,B,Case0s,D) - GI, switch(A,B,Cases,D)-GI) :-
@@ -728,7 +728,7 @@
{ goal_info_get_context(GoalInfo, Context) },
assertion__in_interface_check_unify_rhs(RHS, Var, Context,
PredInfo, Module0, Module).
-assertion__in_interface_check(pragma_foreign_code(_,_,PredId,_,_,_,_,_) -
+assertion__in_interface_check(pragma_foreign_code(_,PredId,_,_,_,_,_) -
GoalInfo, _PredInfo, Module0, Module) -->
{ module_info_pred_info(Module0, PredId, PragmaPredInfo) },
{ pred_info_import_status(PragmaPredInfo, ImportStatus) },
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.51
diff -u -r1.51 bytecode_gen.m
--- compiler/bytecode_gen.m 2000/10/06 10:18:11 1.51
+++ compiler/bytecode_gen.m 2000/10/16 00:20:30
@@ -266,7 +266,7 @@
tree(ElseCode,
EndofIfCode))))))
;
- GoalExpr = pragma_foreign_code(_, _, _, _, _, _, _, _),
+ GoalExpr = pragma_foreign_code(_, _, _, _, _, _, _),
Code = node([not_supported]),
ByteInfo = ByteInfo0
;
Index: compiler/code_aux.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_aux.m,v
retrieving revision 1.59
diff -u -r1.59 code_aux.m
--- compiler/code_aux.m 2000/10/06 10:18:12 1.59
+++ compiler/code_aux.m 2000/10/16 01:33:34
@@ -199,7 +199,7 @@
code_aux__goal_is_flat_2(generic_call(_, _, _, _)).
code_aux__goal_is_flat_2(call(_, _, _, _, _, _)).
code_aux__goal_is_flat_2(unify(_, _, _, _, _)).
-code_aux__goal_is_flat_2(pragma_foreign_code(_, _, _, _, _, _, _, _)).
+code_aux__goal_is_flat_2(pragma_foreign_code(_, _, _, _, _, _, _)).
%-----------------------------------------------------------------------------%
Index: compiler/code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_gen.m,v
retrieving revision 1.87
diff -u -r1.87 code_gen.m
--- compiler/code_gen.m 2000/10/13 13:55:15 1.87
+++ compiler/code_gen.m 2000/11/05 23:12:17
@@ -678,7 +678,7 @@
{ code_info__resume_point_stack_addr(OutsideResumePoint,
OutsideResumeAddress) },
(
- { Goal = pragma_foreign_code(_, _, _, _, _, _, _,
+ { Goal = pragma_foreign_code(_, _, _, _, _, _,
PragmaCode) - _},
{ PragmaCode = nondet(Fields, FieldsContext,
_,_,_,_,_,_,_) }
@@ -1042,12 +1042,18 @@
call_gen__generate_builtin(CodeModel, PredId, ProcId, Args,
Code)
).
-code_gen__generate_goal_2(pragma_foreign_code(c, Attributes,
+code_gen__generate_goal_2(pragma_foreign_code(Attributes,
PredId, ModeId, Args, ArgNames, OrigArgTypes, PragmaCode),
GoalInfo, CodeModel, Instr) -->
- pragma_c_gen__generate_pragma_c_code(CodeModel, Attributes,
- PredId, ModeId, Args, ArgNames, OrigArgTypes, GoalInfo,
- PragmaCode, Instr).
+ (
+ { foreign_language(Attributes, c) }
+ ->
+ pragma_c_gen__generate_pragma_c_code(CodeModel, Attributes,
+ PredId, ModeId, Args, ArgNames, OrigArgTypes,
+ GoalInfo, PragmaCode, Instr)
+ ;
+ { error("code_gen__generate_goal_2: foreign code other than C unexpected") }
+ ).
code_gen__generate_goal_2(bi_implication(_, _), _, _, _) -->
% these should have been expanded out by now
{ error("code_gen__generate_goal_2: unexpected bi_implication") }.
Index: compiler/code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_util.m,v
retrieving revision 1.127
diff -u -r1.127 code_util.m
--- compiler/code_util.m 2000/10/31 02:15:41 1.127
+++ compiler/code_util.m 2000/11/01 07:59:34
@@ -478,7 +478,9 @@
% We cannot safely say that a C code fragment does not allocate memory
% without knowing all the #defined macros that expand to incr_hp and
% variants thereof.
-code_util__goal_may_allocate_heap_2(pragma_foreign_code(_,_,_,_,_,_,_,_), yes).
+ % XXX although you could make it an attribute of the C code and
+ % trust the programmer
+code_util__goal_may_allocate_heap_2(pragma_foreign_code(_,_,_,_,_,_,_), yes).
code_util__goal_may_allocate_heap_2(some(_Vars, _, Goal), May) :-
code_util__goal_may_allocate_heap(Goal, May).
code_util__goal_may_allocate_heap_2(not(Goal), May) :-
@@ -546,7 +548,7 @@
% temporary nondet frames without knowing all the #defined macros
% that expand to mktempframe and variants thereof. The performance
% impact of being too conservative is probably not too bad.
-code_util__goal_may_alloc_temp_frame_2(pragma_foreign_code(_,_,_,_,_,_,_,_),
+code_util__goal_may_alloc_temp_frame_2(pragma_foreign_code(_,_,_,_,_,_,_),
yes).
code_util__goal_may_alloc_temp_frame_2(some(_Vars, _, Goal), May) :-
Goal = _ - GoalInfo,
@@ -809,7 +811,7 @@
code_util__count_recursive_calls_2(unify(_, _, _, _, _), _, _, 0, 0).
code_util__count_recursive_calls_2(generic_call(_, _, _, _), _, _,
0, 0).
-code_util__count_recursive_calls_2(pragma_foreign_code(_, _, _, _, _, _, _, _),
+code_util__count_recursive_calls_2(pragma_foreign_code(_, _, _, _, _, _, _),
_, _, 0, 0).
code_util__count_recursive_calls_2(call(CallPredId, CallProcId, _, _, _, _),
PredId, ProcId, Count, Count) :-
Index: compiler/cse_detection.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/cse_detection.m,v
retrieving revision 1.64
diff -u -r1.64 cse_detection.m
--- compiler/cse_detection.m 2000/10/06 10:18:13 1.64
+++ compiler/cse_detection.m 2000/10/16 00:19:24
@@ -203,8 +203,8 @@
cse_info, cse_info, bool, hlds_goal_expr).
:- mode detect_cse_in_goal_2(in, in, in, in, out, out, out) is det.
-detect_cse_in_goal_2(pragma_foreign_code(A,B,C,D,E,F,G,H), _, _, CseInfo,
- CseInfo, no, pragma_foreign_code(A,B,C,D,E,F,G,H)).
+detect_cse_in_goal_2(pragma_foreign_code(A,B,C,D,E,F,G), _, _, CseInfo,
+ CseInfo, no, pragma_foreign_code(A,B,C,D,E,F,G)).
detect_cse_in_goal_2(generic_call(A,B,C,D), _, _, CseInfo, CseInfo,
no, generic_call(A,B,C,D)).
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.62
diff -u -r1.62 dead_proc_elim.m
--- compiler/dead_proc_elim.m 2000/11/01 05:11:49 1.62
+++ compiler/dead_proc_elim.m 2000/11/01 07:59:34
@@ -485,7 +485,7 @@
NewNotation = yes(1),
map__set(Needed0, proc(PredId, ProcId), NewNotation, Needed)
).
-dead_proc_elim__examine_expr(pragma_foreign_code(_, _, PredId, ProcId, _,
+dead_proc_elim__examine_expr(pragma_foreign_code(_, PredId, ProcId, _,
_, _, _), _CurrProc, Queue0, Queue, Needed0, Needed) :-
queue__put(Queue0, proc(PredId, ProcId), Queue),
map__set(Needed0, proc(PredId, ProcId), no, Needed).
@@ -881,7 +881,7 @@
pre_modecheck_examine_goal(Goal).
pre_modecheck_examine_goal(call(_, _, _, _, _, PredName) - _) -->
dead_pred_info_add_pred_name(PredName).
-pre_modecheck_examine_goal(pragma_foreign_code(_, _, _, _, _, _, _, _) - _) -->
+pre_modecheck_examine_goal(pragma_foreign_code(_, _, _, _, _, _, _) - _) -->
[].
pre_modecheck_examine_goal(unify(_, Rhs, _, _, _) - _) -->
pre_modecheck_examine_unify_rhs(Rhs).
Index: compiler/deforest.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/deforest.m,v
retrieving revision 1.17
diff -u -r1.17 deforest.m
--- compiler/deforest.m 2000/10/13 13:55:18 1.17
+++ compiler/deforest.m 2000/10/22 11:54:26
@@ -201,7 +201,7 @@
deforest__cases(Var, Cases0, Cases).
deforest__goal(Goal, Goal) -->
- { Goal = pragma_foreign_code(_, _, _, _, _, _, _, _) - _ }.
+ { Goal = pragma_foreign_code(_, _, _, _, _, _, _) - _ }.
deforest__goal(Goal, Goal) -->
{ Goal = generic_call(_, _, _, _) - _ }.
Index: compiler/dependency_graph.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dependency_graph.m,v
retrieving revision 1.49
diff -u -r1.49 dependency_graph.m
--- compiler/dependency_graph.m 2000/10/06 10:18:14 1.49
+++ compiler/dependency_graph.m 2000/10/16 01:37:31
@@ -276,7 +276,7 @@
% There can be no dependencies within a pragma_foreign_code
dependency_graph__add_arcs_in_goal_2(
- pragma_foreign_code(_, _, _, _, _, _, _, _), _, DepGraph, DepGraph).
+ pragma_foreign_code(_, _, _, _, _, _, _), _, DepGraph, DepGraph).
dependency_graph__add_arcs_in_goal_2(bi_implication(LHS, RHS), Caller,
DepGraph0, DepGraph) :-
@@ -704,7 +704,7 @@
).
process_aditi_goal(_IsNeg, generic_call(_, _, _, _) - _,
Map, Map) --> [].
-process_aditi_goal(_IsNeg, pragma_foreign_code(_, _, _, _, _, _, _, _) - _,
+process_aditi_goal(_IsNeg, pragma_foreign_code(_, _, _, _, _, _, _) - _,
Map, Map) --> [].
process_aditi_goal(_, bi_implication(_, _) - _, _, _) -->
% these should have been expanded out by now
Index: compiler/det_analysis.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_analysis.m,v
retrieving revision 1.147
diff -u -r1.147 det_analysis.m
--- compiler/det_analysis.m 2000/10/13 13:55:18 1.147
+++ compiler/det_analysis.m 2000/10/22 11:54:26
@@ -642,10 +642,10 @@
Goal, Det, Msgs).
% pragma foregin_codes are handled in the same way as predicate calls
-det_infer_goal_2(pragma_foreign_code(Language, Attributes, PredId, ProcId,
+det_infer_goal_2(pragma_foreign_code(Attributes, PredId, ProcId,
Args, ArgNameMap, OrigArgTypes, PragmaCode),
GoalInfo, _, SolnContext, DetInfo, _, _,
- pragma_foreign_code(Language, Attributes, PredId, ProcId, Args,
+ pragma_foreign_code(Attributes, PredId, ProcId, Args,
ArgNameMap, OrigArgTypes, PragmaCode),
Detism, Msgs) :-
det_info_get_module_info(DetInfo, ModuleInfo),
Index: compiler/det_report.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_report.m,v
retrieving revision 1.62
diff -u -r1.62 det_report.m
--- compiler/det_report.m 2000/11/04 12:40:01 1.62
+++ compiler/det_report.m 2000/11/05 03:55:49
@@ -614,7 +614,7 @@
det_diagnose_goal(Goal, InternalDesired, SwitchContext, DetInfo,
Diagnosed).
-det_diagnose_goal_2(pragma_foreign_code(_, _, _, _, _, _, _, _), GoalInfo,
+det_diagnose_goal_2(pragma_foreign_code(_, _, _, _, _, _, _), GoalInfo,
Desired, _, _, _, yes) -->
{ goal_info_get_context(GoalInfo, Context) },
prog_out__write_context(Context),
Index: compiler/dnf.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dnf.m,v
retrieving revision 1.41
diff -u -r1.41 dnf.m
--- compiler/dnf.m 2000/10/13 13:55:20 1.41
+++ compiler/dnf.m 2000/10/22 11:54:27
@@ -238,7 +238,7 @@
NewPredIds = NewPredIds0,
Goal = Goal0
;
- GoalExpr0 = pragma_foreign_code(_, _, _, _, _, _, _, _),
+ GoalExpr0 = pragma_foreign_code(_, _, _, _, _, _, _),
ModuleInfo = ModuleInfo0,
NewPredIds = NewPredIds0,
Goal = Goal0
@@ -473,7 +473,7 @@
IsAtomic = no
).
dnf__is_atomic_expr(_, _, _, if_then_else(_, _, _, _, _), no).
-dnf__is_atomic_expr(_, _, _, pragma_foreign_code(_, _, _, _, _, _, _, _), yes).
+dnf__is_atomic_expr(_, _, _, pragma_foreign_code(_, _, _, _, _, _, _), yes).
dnf__is_atomic_expr(_, _, _, bi_implication(_, _), no).
:- pred dnf__free_of_nonatomic(hlds_goal::in,
@@ -512,7 +512,7 @@
dnf__free_of_nonatomic(Cond, NonAtomic),
dnf__free_of_nonatomic(Then, NonAtomic),
dnf__free_of_nonatomic(Else, NonAtomic).
-dnf__free_of_nonatomic(pragma_foreign_code(_, _, _, _, _, _, _, _) - _,
+dnf__free_of_nonatomic(pragma_foreign_code(_, _, _, _, _, _, _) - _,
_NonAtomic).
:- pred dnf__goals_free_of_nonatomic(list(hlds_goal)::in,
Index: compiler/excess.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/excess.m,v
retrieving revision 1.34
diff -u -r1.34 excess.m
--- compiler/excess.m 2000/08/09 07:46:28 1.34
+++ compiler/excess.m 2000/10/16 01:32:38
@@ -134,7 +134,7 @@
Goal = GoalExpr0 - GoalInfo0,
ElimVars = ElimVars0
;
- GoalExpr0 = pragma_foreign_code(_, _, _, _, _, _, _, _),
+ GoalExpr0 = pragma_foreign_code(_, _, _, _, _, _, _),
Goal = GoalExpr0 - GoalInfo0,
ElimVars = ElimVars0
;
Index: compiler/export.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.38
diff -u -r1.38 export.m
--- compiler/export.m 2000/11/05 12:03:04 1.38
+++ compiler/export.m 2000/11/07 11:34:46
@@ -5,7 +5,7 @@
%-----------------------------------------------------------------------------%
% This module defines predicates to produce the functions which are
-% exported to C via a `pragma export' declaration.
+% exported to a foreign language via a `pragma export' declaration.
% Note: any changes here might also require similar changes to the handling
% of `pragma import' declarations, which are handled in make_hlds.m.
@@ -21,27 +21,34 @@
:- import_module hlds_module, prog_data, llds.
:- import_module io.
- % From the module_info, get a list of c_export_decls,
+ % From the module_info, get a list of foreign_export_decls,
% each of which holds information about the declaration
- % of a C function named in a `pragma export' declaration,
+ % of a foreign function named in a `pragma export' declaration,
% which is used to allow a call to be made to a Mercury
- % procedure from C.
-:- pred export__get_c_export_decls(module_info, foreign_export_decls).
-:- mode export__get_c_export_decls(in, out) is det.
-
- % From the module_info, get a list of c_export_defns,
- % each of which is a string containing the C code
- % for defining a C function named in a `pragma export' decl.
-:- pred export__get_c_export_defns(module_info, foreign_export_defns).
-:- mode export__get_c_export_defns(in, out) is det.
-
- % Produce a header file containing prototypes for the exported C
- % functions
+ % procedure from the foreign language.
+:- pred export__get_foreign_export_decls(module_info, foreign_export_decls).
+:- mode export__get_foreign_export_decls(in, out) is det.
+
+ % From the module_info, get a list of foreign_export_defns,
+ % each of which is a string containing the foreign code
+ % for defining a foreign function named in a `pragma export' decl.
+:- pred export__get_foreign_export_defns(module_info, foreign_export_defns).
+:- mode export__get_foreign_export_defns(in, out) is det.
+
+ % Produce an interface file containing declarations for the
+ % exported foreign functions (if required in this foreign
+ % language).
:- pred export__produce_header_file(foreign_export_decls, module_name,
io__state, io__state).
:- mode export__produce_header_file(in, in, di, uo) is det.
+
+
+%-----------------------------------------------------------------------------%
+
+% Utilities for generating C code which interfaces with Mercury.
+% The MLDS->C backend and fact tables use this code.
- % Convert the type, to a string corresponding to its C type.
+ % Convert the type to a string corresponding to its C type.
% (Defaults to MR_Word).
:- pred export__type_to_type_string(type, string).
:- mode export__type_to_type_string(in, out) is det.
@@ -72,30 +79,31 @@
%-----------------------------------------------------------------------------%
-export__get_c_export_decls(HLDS, C_ExportDecls) :-
+export__get_foreign_export_decls(HLDS, C_ExportDecls) :-
module_info_get_predicate_table(HLDS, PredicateTable),
predicate_table_get_preds(PredicateTable, Preds),
module_info_get_pragma_exported_procs(HLDS, ExportedProcs),
- export__get_c_export_decls_2(Preds, ExportedProcs, C_ExportDecls).
+ export__get_foreign_export_decls_2(Preds, ExportedProcs, C_ExportDecls).
-:- pred export__get_c_export_decls_2(pred_table, list(pragma_exported_proc),
- list(foreign_export_decl)).
-:- mode export__get_c_export_decls_2(in, in, out) is det.
+:- pred export__get_foreign_export_decls_2(pred_table,
+ list(pragma_exported_proc), list(foreign_export_decl)).
+:- mode export__get_foreign_export_decls_2(in, in, out) is det.
-export__get_c_export_decls_2(_Preds, [], []).
-export__get_c_export_decls_2(Preds, [E|ExportedProcs], C_ExportDecls) :-
+export__get_foreign_export_decls_2(_Preds, [], []).
+export__get_foreign_export_decls_2(Preds, [E|ExportedProcs], C_ExportDecls) :-
E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
get_export_info(Preds, PredId, ProcId, _Exported, C_RetType,
_DeclareReturnVal, _FailureAction, _SuccessAction,
HeadArgInfoTypes),
get_argument_declarations(HeadArgInfoTypes, no, ArgDecls),
C_ExportDecl = foreign_export_decl(c, C_RetType, C_Function, ArgDecls),
- export__get_c_export_decls_2(Preds, ExportedProcs, C_ExportDecls0),
+ export__get_foreign_export_decls_2(Preds, ExportedProcs,
+ C_ExportDecls0),
C_ExportDecls = [C_ExportDecl | C_ExportDecls0].
%-----------------------------------------------------------------------------%
-export__get_c_export_defns(Module, ExportedProcsCode) :-
+export__get_foreign_export_defns(Module, ExportedProcsCode) :-
module_info_get_pragma_exported_procs(Module, ExportedProcs),
module_info_get_predicate_table(Module, PredicateTable),
predicate_table_get_preds(PredicateTable, Preds),
@@ -555,16 +563,19 @@
:- mode export__produce_header_file_2(in, di, uo) is det.
export__produce_header_file_2([]) --> [].
export__produce_header_file_2([E|ExportedProcs]) -->
- { E = foreign_export_decl(c, C_RetType, C_Function, ArgDecls) },
-
- % output the function header
- io__write_string(C_RetType),
- io__write_string(" "),
- io__write_string(C_Function),
- io__write_string("("),
- io__write_string(ArgDecls),
- io__write_string(");\n"),
-
+ (
+ { E = foreign_export_decl(c, C_RetType, C_Function, ArgDecls) }
+ ->
+ % output the function header
+ io__write_string(C_RetType),
+ io__write_string(" "),
+ io__write_string(C_Function),
+ io__write_string("("),
+ io__write_string(ArgDecls),
+ io__write_string(");\n")
+ ;
+ { error("export__produce_header_file_2: foreign languages other than C unimplemented") }
+ ),
export__produce_header_file_2(ExportedProcs).
% Convert a term representation of a variable type to a string which
Index: compiler/follow_code.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/follow_code.m,v
retrieving revision 1.59
diff -u -r1.59 follow_code.m
--- compiler/follow_code.m 2000/10/13 13:55:21 1.59
+++ compiler/follow_code.m 2000/10/22 11:54:27
@@ -122,8 +122,8 @@
move_follow_code_in_goal_2(unify(A,B,C,D,E), unify(A,B,C,D,E), _, R, R).
-move_follow_code_in_goal_2(pragma_foreign_code(A,B,C,D,E,F,G,H),
- pragma_foreign_code(A,B,C,D,E,F,G,H), _, R, R).
+move_follow_code_in_goal_2(pragma_foreign_code(A,B,C,D,E,F,G),
+ pragma_foreign_code(A,B,C,D,E,F,G), _, R, R).
move_follow_code_in_goal_2(bi_implication(_, _), _, _, _, _) :-
% these should have been expanded out by now
Index: compiler/follow_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/follow_vars.m,v
retrieving revision 1.58
diff -u -r1.58 follow_vars.m
--- compiler/follow_vars.m 2000/09/20 00:21:48 1.58
+++ compiler/follow_vars.m 2000/10/16 01:32:25
@@ -198,9 +198,9 @@
FollowVarsMap = FollowVarsMap0
).
-find_follow_vars_in_goal_expr(pragma_foreign_code(A,B,C,D,E,F,G,H),
+find_follow_vars_in_goal_expr(pragma_foreign_code(A,B,C,D,E,F,G),
_, _ModuleInfo, FollowVarsMap, NextNonReserved,
- pragma_foreign_code(A,B,C,D,E,F,G,H),
+ pragma_foreign_code(A,B,C,D,E,F,G),
FollowVarsMap, NextNonReserved).
find_follow_vars_in_goal_expr(bi_implication(_,_), _, _, _, _, _, _, _) :-
Index: compiler/foreign.m
===================================================================
RCS file: foreign.m
diff -N foreign.m
--- /dev/null Tue May 16 14:50:59 2000
+++ foreign.m Fri Nov 10 19:35:21 2000
@@ -0,0 +1,307 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+
+% This module defines predicates for interfacing with foreign languages.
+% In particular, this module supports interfacing with with languages
+% other than the target of compilation.
+
+% Main authors: trd, dgj.
+% Parts of this code were originally written by dgj, and have since been
+% moved here.
+
+%-----------------------------------------------------------------------------%
+
+:- module foreign.
+
+:- interface.
+
+:- import_module prog_data, llds.
+:- import_module hlds_module, hlds_pred.
+
+:- import_module list.
+
+ % Filter the decls for the given foreign language.
+:- pred foreign__filter_decls(foreign_language, foreign_decl_info,
+ foreign_decl_info, foreign_decl_info).
+:- mode foreign__filter_decls(in, in, out, out) is det.
+
+ % Filter the bodys for the given foreign language.
+:- pred foreign__filter_bodys(foreign_language, foreign_body_info,
+ foreign_body_info, foreign_body_info).
+:- mode foreign__filter_bodys(in, in, out, out) is det.
+
+ % Given some foreign code, generate some suitable proxy code for
+ % calling the code via the given language.
+ % This might mean, for example, generating a call to a
+ % forwarding function in C.
+:- pred foreign__extrude_pragma_implementation(foreign_language,
+ list(pragma_var), sym_name, pred_or_func, prog_context,
+ module_info, pragma_foreign_code_attributes,
+ pragma_foreign_code_impl,
+ module_info, pragma_foreign_code_attributes,
+ pragma_foreign_code_impl).
+:- mode foreign__extrude_pragma_implementation(in, in, in, in, in,
+ in, in, in, out, out, out) is det.
+
+:- pred foreign__make_pragma_import(pred_info, proc_info, string, prog_context,
+ module_info, pragma_foreign_code_impl, prog_varset,
+ list(pragma_var), list(type), arity, pred_or_func).
+:- mode foreign__make_pragma_import(in, in, in, in, in,
+ out, out, out, out, out, out) is det.
+
+:- implementation.
+
+:- import_module list, map, assoc_list, std_util, string, varset, int.
+:- import_module require.
+
+:- import_module hlds_pred, hlds_module, type_util, mode_util.
+
+foreign__filter_decls(WantedLang, Decls0, LangDecls, NotLangDecls) :-
+ list__filter((pred(foreign_decl_code(Lang, _, _)::in) is semidet :-
+ WantedLang = Lang),
+ Decls0, LangDecls, NotLangDecls).
+
+foreign__filter_bodys(WantedLang, Bodys0, LangBodys, NotLangBodys) :-
+ list__filter((pred(foreign_body_code(Lang, _, _)::in) is semidet :-
+ WantedLang = Lang),
+ Bodys0, LangBodys, NotLangBodys).
+
+foreign__extrude_pragma_implementation(TargetLang, _PragmaVars,
+ _PredName, _PredOrFunc, _Context,
+ ModuleInfo0, Attributes, Impl0,
+ ModuleInfo, NewAttributes, Impl) :-
+ foreign_language(Attributes, ForeignLanguage),
+ set_foreign_language(Attributes, TargetLang, NewAttributes),
+ ( TargetLang = c ->
+ ( ForeignLanguage = managedcplusplus,
+ % This isn't finished yet, and we probably won't
+ % implement it for C calling MC++.
+ % For C calling normal C++ we would generate a proxy
+ % function in C++ (implemented in a piece of C++
+ % body code) with C linkage, and import that
+ % function.
+ % The backend would spit the C++ body code into
+ % a separate file.
+ % The code would look a little like this:
+ /*
+ NewName = make_pred_name(ForeignLanguage, PredName),
+ ( PredOrFunc = predicate ->
+ ReturnCode = ""
+ ;
+ ReturnCode = "ReturnVal = "
+ ),
+ C_ExtraCode = "Some Extra Code To Run",
+ create_pragma_import_c_code(PragmaVars, ModuleInfo0,
+ "", VarString),
+ module_add_foreign_body_code(cplusplus,
+ C_ExtraCode, Context, ModuleInfo0, ModuleInfo),
+ Impl = import(NewName, ReturnCode, VarString, no)
+ */
+ error("unimplemented: calling MC++ foreign code from C backend")
+ ; ForeignLanguage = c,
+ Impl = Impl0,
+ ModuleInfo = ModuleInfo0
+ )
+ ; TargetLang = managedcplusplus ->
+ % Don't do anything - C and MC++ are embedded
+ % inside MC++ without any changes.
+ ( ForeignLanguage = managedcplusplus,
+ Impl = Impl0,
+ ModuleInfo = ModuleInfo0
+ ; ForeignLanguage = c,
+ Impl = Impl0,
+ ModuleInfo = ModuleInfo0
+ )
+ ;
+ error("extrude_pragma_implementation: unsupported foreign language")
+ ).
+
+:- func make_pred_name(foreign_language, sym_name) = string.
+make_pred_name(c, SymName) =
+ "mercury_c__" ++ make_pred_name_rest(c, SymName).
+make_pred_name(managedcplusplus, SymName) =
+ "mercury_cpp__" ++ make_pred_name_rest(managedcplusplus, SymName).
+
+:- func make_pred_name_rest(foreign_language, sym_name) = string.
+make_pred_name_rest(c, _SymName) = "some_c_name".
+make_pred_name_rest(managedcplusplus, qualified(ModuleSpec, Name)) =
+ make_pred_name_rest(managedcplusplus, ModuleSpec) ++ "__" ++ Name.
+make_pred_name_rest(managedcplusplus, unqualified(Name)) = Name.
+
+
+make_pragma_import(PredInfo, ProcInfo, C_Function, Context,
+ ModuleInfo, PragmaImpl, VarSet, PragmaVars, ArgTypes,
+ Arity, PredOrFunc) :-
+ %
+ % lookup some information we need from the pred_info and proc_info
+ %
+ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
+ pred_info_arg_types(PredInfo, ArgTypes),
+ proc_info_argmodes(ProcInfo, Modes),
+ proc_info_interface_code_model(ProcInfo, CodeModel),
+
+ %
+ % Build a list of argument variables, together with their
+ % names, modes, and types.
+ %
+ varset__init(VarSet0),
+ list__length(Modes, Arity),
+ varset__new_vars(VarSet0, Arity, Vars, VarSet),
+ create_pragma_vars(Vars, Modes, 0, PragmaVars),
+ assoc_list__from_corresponding_lists(PragmaVars, ArgTypes,
+ PragmaVarsAndTypes),
+
+ %
+ % Construct parts of the C_Code string for calling C_Function.
+ % This C code fragment invokes the specified C function
+ % with the appropriate arguments from the list constructed
+ % above, passed in the appropriate manner (by value, or by
+ % passing the address to simulate pass-by-reference), and
+ % assigns the return value (if any) to the appropriate place.
+ % As this phase occurs before polymorphism, we don't know about
+ % the type-infos yet. polymorphism.m is responsible for adding
+ % the type-info arguments to the list of variables.
+ %
+ handle_return_value(CodeModel, PredOrFunc, PragmaVarsAndTypes,
+ ModuleInfo, ArgPragmaVarsAndTypes, Return),
+ assoc_list__keys(ArgPragmaVarsAndTypes, ArgPragmaVars),
+ create_pragma_import_c_code(ArgPragmaVars, ModuleInfo,
+ "", Variables),
+
+ %
+ % Add the C_Code for this `pragma import' to the clauses_info
+ %
+ PragmaImpl = import(C_Function, Return, Variables, yes(Context)).
+
+%
+% handle_return_value(CodeModel, PredOrFunc, Args0, M, Args, C_Code0):
+% Figures out what to do with the C function's return value,
+% based on Mercury procedure's code model, whether it is a predicate
+% or a function, and (if it is a function) the type and mode of the
+% function result. Constructs a C code fragment `C_Code0' which
+% is a string of the form "<Something> =" that assigns the return
+% value to the appropriate place, if there is a return value,
+% or is an empty string, if there is no return value.
+% Returns in Args all of Args0 that must be passed as arguments
+% (i.e. all of them, or all of them except the return value).
+%
+:- pred handle_return_value(code_model, pred_or_func,
+ assoc_list(pragma_var, type), module_info,
+ assoc_list(pragma_var, type), string).
+:- mode handle_return_value(in, in, in, in, out, out) is det.
+
+handle_return_value(CodeModel, PredOrFunc, Args0, ModuleInfo, Args, C_Code0) :-
+ ( CodeModel = model_det,
+ (
+ PredOrFunc = function,
+ pred_args_to_func_args(Args0, Args1, RetArg),
+ RetArg = pragma_var(_, RetArgName, RetMode) - RetType,
+ mode_to_arg_mode(ModuleInfo, RetMode, RetType,
+ RetArgMode),
+ RetArgMode = top_out,
+ \+ type_util__is_dummy_argument_type(RetType)
+ ->
+ string__append(RetArgName, " = ", C_Code0),
+ Args2 = Args1
+ ;
+ C_Code0 = "",
+ Args2 = Args0
+ )
+ ; CodeModel = model_semi,
+ % we treat semidet functions the same as semidet predicates,
+ % which means that for Mercury functions the Mercury return
+ % value becomes the last argument, and the C return value
+ % is a bool that is used to indicate success or failure.
+ C_Code0 = "SUCCESS_INDICATOR = ",
+ Args2 = Args0
+ ; CodeModel = model_non,
+ % XXX we should report an error here, rather than generating
+ % C code with `#error'...
+ C_Code0 = "\n#error ""cannot import nondet procedure""\n",
+ Args2 = Args0
+ ),
+ list__filter(include_import_arg(ModuleInfo), Args2, Args).
+
+%
+% include_import_arg(M, Arg):
+% Succeeds iff Arg should be included in the arguments of the C
+% function. Fails if `Arg' has a type such as `io__state' that
+% is just a dummy argument that should not be passed to C.
+%
+:- pred include_import_arg(module_info, pair(pragma_var, type)).
+:- mode include_import_arg(in, in) is semidet.
+
+include_import_arg(ModuleInfo, pragma_var(_Var, _Name, Mode) - Type) :-
+ mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
+ ArgMode \= top_unused,
+ \+ type_util__is_dummy_argument_type(Type).
+
+%
+% create_pragma_vars(Vars, Modes, ArgNum0, PragmaVars):
+% given list of vars and modes, and an initial argument number,
+% allocate names to all the variables, and
+% construct a single list containing the variables, names, and modes.
+%
+:- pred create_pragma_vars(list(prog_var), list(mode), int, list(pragma_var)).
+:- mode create_pragma_vars(in, in, in, out) is det.
+
+create_pragma_vars([], [], _Num, []).
+
+create_pragma_vars([Var|Vars], [Mode|Modes], ArgNum0,
+ [PragmaVar | PragmaVars]) :-
+ %
+ % Figure out a name for the C variable which will hold this argument
+ %
+ ArgNum is ArgNum0 + 1,
+ string__int_to_string(ArgNum, ArgNumString),
+ string__append("Arg", ArgNumString, ArgName),
+
+ PragmaVar = pragma_var(Var, ArgName, Mode),
+
+ create_pragma_vars(Vars, Modes, ArgNum, PragmaVars).
+
+create_pragma_vars([_|_], [], _, _) :-
+ error("create_pragma_vars: length mis-match").
+create_pragma_vars([], [_|_], _, _) :-
+ error("create_pragma_vars: length mis-match").
+
+%
+% create_pragma_import_c_code(PragmaVars, M, C_Code0, C_Code):
+% This predicate creates the C code fragments for each argument
+% in PragmaVars, and appends them to C_Code0, returning C_Code.
+%
+:- pred create_pragma_import_c_code(list(pragma_var), module_info,
+ string, string).
+:- mode create_pragma_import_c_code(in, in, in, out) is det.
+
+create_pragma_import_c_code([], _ModuleInfo, C_Code, C_Code).
+
+create_pragma_import_c_code([PragmaVar | PragmaVars], ModuleInfo,
+ C_Code0, C_Code) :-
+ PragmaVar = pragma_var(_Var, ArgName, Mode),
+
+ %
+ % Construct the C code fragment for passing this argument,
+ % and append it to C_Code0.
+ % Note that C handles output arguments by passing the variable'
+ % address, so if the mode is output, we need to put an `&' before
+ % the variable name.
+ %
+ ( mode_is_output(ModuleInfo, Mode) ->
+ string__append(C_Code0, "&", C_Code1)
+ ;
+ C_Code1 = C_Code0
+ ),
+ string__append(C_Code1, ArgName, C_Code2),
+ ( PragmaVars \= [] ->
+ string__append(C_Code2, ", ", C_Code3)
+ ;
+ C_Code3 = C_Code2
+ ),
+
+ create_pragma_import_c_code(PragmaVars, ModuleInfo, C_Code3, C_Code).
+
+
Index: compiler/globals.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/globals.m,v
retrieving revision 1.37
diff -u -r1.37 globals.m
--- compiler/globals.m 2000/10/03 00:34:07 1.37
+++ compiler/globals.m 2000/11/09 05:59:16
@@ -16,7 +16,7 @@
%-----------------------------------------------------------------------------%
:- interface.
-:- import_module options, trace_params.
+:- import_module options, trace_params, prog_data.
:- import_module bool, getopt, list.
:- type globals.
@@ -50,11 +50,14 @@
; size_data_elems.
:- pred convert_target(string::in, compilation_target::out) is semidet.
+:- pred convert_foreign_language(string::in, foreign_language::out) is semidet.
:- pred convert_gc_method(string::in, gc_method::out) is semidet.
:- pred convert_tags_method(string::in, tags_method::out) is semidet.
:- pred convert_prolog_dialect(string::in, prolog_dialect::out) is semidet.
:- pred convert_termination_norm(string::in, termination_norm::out) is semidet.
+:- func foreign_language_string(foreign_language) = string.
+
%-----------------------------------------------------------------------------%
% Access predicates for the `globals' structure.
@@ -119,6 +122,9 @@
:- pred globals__io_get_target(compilation_target::out,
io__state::di, io__state::uo) is det.
+
+:- pred globals__io_lookup_foreign_language_option(option::in,
+ foreign_language::out, io__state::di, io__state::uo) is det.
:- pred globals__io_get_gc_method(gc_method::out,
io__state::di, io__state::uo) is det.
@@ -176,9 +182,7 @@
:- import_module exprn_aux.
:- import_module map, std_util, io, require.
- % XXX this should use the same language specification
- % strings as parse_foreign_language.
- % Also, we should probably just convert to lower case and then
+ % XXX we should probably just convert to lower case and then
% test against known strings.
convert_target("java", java).
convert_target("Java", java).
@@ -187,6 +191,16 @@
convert_target("c", c).
convert_target("C", c).
+ % XXX we should probably just convert to lower case and then
+ % test against known strings.
+convert_foreign_language("C", c).
+convert_foreign_language("c", c).
+convert_foreign_language("MC++", managedcplusplus).
+convert_foreign_language("mc++", managedcplusplus).
+
+foreign_language_string(c) = "C".
+foreign_language_string(managedcplusplus) = "MC++".
+
convert_gc_method("none", none).
convert_gc_method("conservative", conservative).
convert_gc_method("accurate", accurate).
@@ -411,6 +425,14 @@
globals__io_set_trace_level(trace_level_none).
%-----------------------------------------------------------------------------%
+
+globals__io_lookup_foreign_language_option(Option, ForeignLang) -->
+ globals__io_lookup_string_option(Option, String),
+ { convert_foreign_language(String, ForeignLang0) ->
+ ForeignLang = ForeignLang0
+ ;
+ error("globals__io_lookup_foreign_language_option: invalid foreign_language option")
+ }.
globals__io_lookup_bool_option(Option, Value) -->
globals__io_get_globals(Globals),
Index: compiler/goal_path.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_path.m,v
retrieving revision 1.10
diff -u -r1.10 goal_path.m
--- compiler/goal_path.m 2000/10/13 04:04:27 1.10
+++ compiler/goal_path.m 2000/10/23 01:10:44
@@ -88,8 +88,8 @@
fill_expr_slots(call(A,B,C,D,E,F), _, _, _, call(A,B,C,D,E,F)).
fill_expr_slots(generic_call(A,B,C,D), _, _, _, generic_call(A,B,C,D)).
fill_expr_slots(unify(A,B,C,D,E), _, _, _, unify(A,B,C,D,E)).
-fill_expr_slots(pragma_foreign_code(A,B,C,D,E,F,G,H), _, _, _,
- pragma_foreign_code(A,B,C,D,E,F,G,H)).
+fill_expr_slots(pragma_foreign_code(A,B,C,D,E,F,G), _, _, _,
+ pragma_foreign_code(A,B,C,D,E,F,G)).
fill_expr_slots(bi_implication(_, _), _, _, _, _) :-
% these should have been expanded out by now
error("fill_expr_slots: unexpected bi_implication").
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.66
diff -u -r1.66 goal_util.m
--- compiler/goal_util.m 2000/10/13 13:55:22 1.66
+++ compiler/goal_util.m 2000/10/22 11:54:28
@@ -373,8 +373,8 @@
goal_util__rename_unify_rhs(TermR0, Must, Subn, TermR),
goal_util__rename_unify(Unify0, Must, Subn, Unify).
-goal_util__name_apart_2(pragma_foreign_code(A,B,C,D,Vars0,F,G,H), Must, Subn,
- pragma_foreign_code(A,B,C,D,Vars,F,G,H)) :-
+goal_util__name_apart_2(pragma_foreign_code(A,B,C,Vars0,E,F,G), Must, Subn,
+ pragma_foreign_code(A,B,C,Vars,E,F,G)) :-
goal_util__rename_var_list(Vars0, Must, Subn, Vars).
goal_util__name_apart_2(bi_implication(LHS0, RHS0), Must, Subn,
@@ -610,7 +610,7 @@
goal_util__goal_vars_2(B, Set2, Set3),
goal_util__goal_vars_2(C, Set3, Set).
-goal_util__goal_vars_2(pragma_foreign_code(_, _, _, _, ArgVars, _, _, _),
+goal_util__goal_vars_2(pragma_foreign_code(_, _, _, ArgVars, _, _, _),
Set0, Set) :-
set__insert_list(Set0, ArgVars, Set).
@@ -754,7 +754,7 @@
goal_expr_size(call(_, _, _, _, _, _), 1).
goal_expr_size(generic_call(_, _, _, _), 1).
goal_expr_size(unify(_, _, _, _, _), 1).
-goal_expr_size(pragma_foreign_code(_, _, _, _, _, _, _, _), 1).
+goal_expr_size(pragma_foreign_code(_, _, _, _, _, _, _), 1).
goal_expr_size(bi_implication(LHS, RHS), Size) :-
goal_size(LHS, Size1),
goal_size(RHS, Size2),
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.96
diff -u -r1.96 handle_options.m
--- compiler/handle_options.m 2000/11/06 08:28:31 1.96
+++ compiler/handle_options.m 2000/11/09 05:35:17
@@ -568,6 +568,32 @@
% we are expecting some to be missing.
option_implies(use_opt_files, warn_missing_opt_files, bool(no)),
+
+ % The preferred backend foreign language depends on the target.
+ (
+ { Target = c },
+ { BackendForeignLanguage = "c" }
+ ;
+ { Target = il },
+ { BackendForeignLanguage = "mc++" }
+ ;
+ % we don't generate java or handle it as a foreign
+ % language just yet, but if we did...
+ { Target = java },
+ { BackendForeignLanguage = "java" }
+ ),
+ globals__io_set_option(backend_foreign_language,
+ string(BackendForeignLanguage)),
+ % The default foreign language we use is the same as the backend.
+ globals__io_lookup_string_option(use_foreign_language,
+ UseForeignLanguage),
+ ( { UseForeignLanguage = "" } ->
+ globals__io_set_option(use_foreign_language,
+ string(BackendForeignLanguage))
+ ;
+ []
+ ),
+
globals__io_lookup_bool_option(highlevel_code, HighLevel),
( { HighLevel = no } ->
postprocess_options_lowlevel
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.81
diff -u -r1.81 higher_order.m
--- compiler/higher_order.m 2000/11/01 05:11:50 1.81
+++ compiler/higher_order.m 2000/11/01 07:59:36
@@ -500,7 +500,7 @@
traverse_goal_2(Goal0, Goal).
traverse_goal_2(Goal, Goal) -->
- { Goal = pragma_foreign_code(_, _, _, _, _, _, _, _) - _ }.
+ { Goal = pragma_foreign_code(_, _, _, _, _, _, _) - _ }.
traverse_goal_2(Goal, Goal) -->
{ Goal = unify(_, _, _, Unify, _) - _ },
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.80
diff -u -r1.80 hlds_goal.m
--- compiler/hlds_goal.m 2000/11/05 04:49:59 1.80
+++ compiler/hlds_goal.m 2000/11/07 11:34:48
@@ -163,7 +163,6 @@
% Foreign code from a pragma foreign_code(...) decl.
; pragma_foreign_code(
- foreign_language, % the language we are using
pragma_foreign_code_attributes,
pred_id, % The called predicate
proc_id, % The mode of the predicate
@@ -1481,7 +1480,7 @@
goal_is_atomic(generic_call(_,_,_,_)).
goal_is_atomic(call(_,_,_,_,_,_)).
goal_is_atomic(unify(_,_,_,_,_)).
-goal_is_atomic(pragma_foreign_code(_,_,_,_,_,_,_,_)).
+goal_is_atomic(pragma_foreign_code(_,_,_,_,_,_,_)).
%-----------------------------------------------------------------------------%
@@ -1576,7 +1575,7 @@
set_goal_contexts_2(_, Goal, Goal) :-
Goal = unify(_, _, _, _, _).
set_goal_contexts_2(_, Goal, Goal) :-
- Goal = pragma_foreign_code(_, _, _, _, _, _, _, _).
+ Goal = pragma_foreign_code(_, _, _, _, _, _, _).
set_goal_contexts_2(Context, bi_implication(LHS0, RHS0),
bi_implication(LHS, RHS)) :-
set_goal_contexts(Context, LHS0, LHS),
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.62
diff -u -r1.62 hlds_module.m
--- compiler/hlds_module.m 2000/10/26 06:05:33 1.62
+++ compiler/hlds_module.m 2000/11/08 01:27:26
@@ -40,7 +40,7 @@
:- type foreign_code_info
---> foreign_code_info(
- foreign_header_info,
+ foreign_decl_info,
foreign_body_info
).
@@ -245,12 +245,12 @@
:- pred module_info_set_globals(module_info, globals, module_info).
:- mode module_info_set_globals(in, in, out) is det.
-:- pred module_info_get_foreign_header(module_info, foreign_header_info).
-:- mode module_info_get_foreign_header(in, out) is det.
+:- pred module_info_get_foreign_decl(module_info, foreign_decl_info).
+:- mode module_info_get_foreign_decl(in, out) is det.
-:- pred module_info_set_foreign_header(module_info,
- foreign_header_info, module_info).
-:- mode module_info_set_foreign_header(in, in, out) is det.
+:- pred module_info_set_foreign_decl(module_info,
+ foreign_decl_info, module_info).
+:- mode module_info_set_foreign_decl(in, in, out) is det.
:- pred module_info_get_foreign_body_code(module_info, foreign_body_info).
:- mode module_info_get_foreign_body_code(in, out) is det.
@@ -258,6 +258,14 @@
:- pred module_info_set_foreign_body_code(module_info, foreign_body_info, module_info).
:- mode module_info_set_foreign_body_code(in, in, out) is det.
+:- pred module_add_foreign_decl(foreign_language, string, prog_context,
+ module_info, module_info).
+:- mode module_add_foreign_decl(in, in, in, in, out) is det.
+
+:- pred module_add_foreign_body_code(foreign_language, string, prog_context,
+ module_info, module_info).
+:- mode module_add_foreign_body_code(in, in, in, in, out) is det.
+
:- pred module_info_get_maybe_dependency_info(module_info,
maybe(dependency_info)).
:- mode module_info_get_maybe_dependency_info(in, out) is det.
@@ -475,7 +483,7 @@
module_sub(
module_name :: module_name,
globals :: globals,
- foreign_header_info :: foreign_header_info,
+ foreign_decl_info :: foreign_decl_info,
foreign_body_info :: foreign_body_info,
maybe_dependency_info :: maybe(dependency_info),
num_errors :: int,
@@ -604,7 +612,7 @@
module_info_name(MI, MI ^ sub_info ^ module_name).
module_info_globals(MI, MI ^ sub_info ^ globals).
-module_info_get_foreign_header(MI, MI ^ sub_info ^ foreign_header_info).
+module_info_get_foreign_decl(MI, MI ^ sub_info ^ foreign_decl_info).
module_info_get_foreign_body_code(MI, MI ^ sub_info ^ foreign_body_info).
module_info_get_maybe_dependency_info(MI,
MI ^ sub_info ^ maybe_dependency_info).
@@ -633,8 +641,8 @@
module_info_set_globals(MI, NewVal,
MI ^ sub_info ^ globals := NewVal).
-module_info_set_foreign_header(MI, NewVal,
- MI ^ sub_info ^ foreign_header_info := NewVal).
+module_info_set_foreign_decl(MI, NewVal,
+ MI ^ sub_info ^ foreign_decl_info := NewVal).
module_info_set_foreign_body_code(MI, NewVal,
MI ^ sub_info ^ foreign_body_info := NewVal).
module_info_set_maybe_dependency_info(MI, NewVal,
@@ -830,6 +838,24 @@
IndirectImports),
AllImports = (IndirectImports `set__union` DirectImports)
`set__union` set__list_to_set(Parents).
+
+module_add_foreign_decl(Lang, ForeignDecl, Context, Module0, Module) :-
+ module_info_get_foreign_decl(Module0, ForeignDeclIndex0),
+ % store the decls in reverse order and reverse them later
+ % for efficiency
+ ForeignDeclIndex1 = [foreign_decl_code(Lang, ForeignDecl, Context) |
+ ForeignDeclIndex0],
+ module_info_set_foreign_decl(Module0, ForeignDeclIndex1, Module).
+
+module_add_foreign_body_code(Lang, Foreign_Body_Code, Context,
+ Module0, Module) :-
+ module_info_get_foreign_body_code(Module0, Foreign_Body_List0),
+ % store the decls in reverse order and reverse them later
+ % for efficiency
+ Foreign_Body_List =
+ [foreign_body_code(Lang, Foreign_Body_Code, Context) |
+ Foreign_Body_List0],
+ module_info_set_foreign_body_code(Module0, Foreign_Body_List, Module).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.249
diff -u -r1.249 hlds_out.m
--- compiler/hlds_out.m 2000/11/03 03:11:45 1.249
+++ compiler/hlds_out.m 2000/11/09 06:00:29
@@ -1551,12 +1551,12 @@
[]
).
-hlds_out__write_goal_2(pragma_foreign_code(Language, _, _, _, ArgVars,
+hlds_out__write_goal_2(pragma_foreign_code(Attributes, _, _, ArgVars,
ArgNames, _, PragmaCode), _, _, _, Indent, Follow, _) -->
- % XXX handle other languages
+ { foreign_language(Attributes, ForeignLang) },
hlds_out__write_indent(Indent),
io__write_string("$pragma_foreign_code( /* "),
- io__write(Language),
+ io__write_string(foreign_language_string(ForeignLang)),
io__write_string(" */ ["),
hlds_out__write_varnum_list(ArgVars),
io__write_string("], ["),
Index: compiler/inlining.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inlining.m,v
retrieving revision 1.91
diff -u -r1.91 inlining.m
--- compiler/inlining.m 2000/10/13 13:55:27 1.91
+++ compiler/inlining.m 2000/10/22 11:54:31
@@ -591,8 +591,8 @@
unify(A, B, C, D, E) - GoalInfo) --> [].
inlining__inlining_in_goal(
- pragma_foreign_code(A, B, C, D, E, F, G, H) - GoalInfo,
- pragma_foreign_code(A, B, C, D, E, F, G, H) - GoalInfo) --> [].
+ pragma_foreign_code(A, B, C, D, E, F, G) - GoalInfo,
+ pragma_foreign_code(A, B, C, D, E, F, G) - GoalInfo) --> [].
inlining__inlining_in_goal(bi_implication(_, _) - _, _) -->
% these should have been expanded out by now
@@ -823,7 +823,7 @@
proc_info_goal(ProcInfo, CalledGoal),
\+ (
HighLevelCode = no,
- CalledGoal = pragma_foreign_code(_,_,_,_,_,_,_,_) - _,
+ CalledGoal = pragma_foreign_code(_,_,_,_,_,_,_) - _,
proc_info_interface_code_model(ProcInfo, model_non)
),
@@ -837,7 +837,7 @@
% goals, which can result from inlining.
\+ (
HighLevelCode = yes,
- CalledGoal = pragma_foreign_code(_,_,_,_,_,_,_,_) - _
+ CalledGoal = pragma_foreign_code(_,_,_,_,_,_,_) - _
),
% Don't inline memoed Aditi predicates.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.87
diff -u -r1.87 intermod.m
--- compiler/intermod.m 2000/11/03 03:11:50 1.87
+++ compiler/intermod.m 2000/11/10 06:44:17
@@ -16,7 +16,8 @@
% - Non-exported types, insts and modes used by the above.
% - :- import_module declarations to import stuff used by the above.
% - pragma declarations for the exported preds.
-% - pragma c_header declarations if any pragma_c_code preds are written.
+% - pragma foreign_header declarations if any pragma_foreign_code
+% preds are written.
% All these items should be module qualified.
%
% This module also contains predicates to read in the .opt files and
@@ -160,7 +161,7 @@
module_info,
bool, % do the c_header_codes for
% the module need writing, yes if there
- % are pragma_c_code procs being exported
+ % are pragma_foreign_code procs being exported
map(prog_var, type), % Vartypes and tvarset for the
tvarset % current pred
).
@@ -217,7 +218,7 @@
intermod_info_get_preds(Preds0),
( { pred_info_get_goal_type(PredInfo, pragmas) } ->
% The header code must be written since
- % it could be used by the pragma_c_code.
+ % it could be used by the pragma_foreign_code.
intermod_info_set_write_header
;
[]
@@ -458,10 +459,10 @@
intermod__traverse_goal(Else0, Else, DoWrite3),
{ bool__and_list([DoWrite1, DoWrite2, DoWrite3], DoWrite) }.
- % Inlineable exported pragma_c_code goals can't use any
+ % Inlineable exported pragma_foreign_code goals can't use any
% non-exported types, so we just write out the clauses.
-intermod__traverse_goal(pragma_foreign_code(A,B,C,D,E,F,G,H) - Info,
- pragma_foreign_code(A,B,C,D,E,F,G,H) - Info, yes) --> [].
+intermod__traverse_goal(pragma_foreign_code(A,B,C,D,E,F,G) - Info,
+ pragma_foreign_code(A,B,C,D,E,F,G) - Info, yes) --> [].
intermod__traverse_goal(bi_implication(_, _) - _, _, _) -->
% these should have been expanded out by now
@@ -1097,8 +1098,8 @@
globals__io_lookup_string_option(dump_hlds_options, VerboseDump),
globals__io_set_option(dump_hlds_options, string("")),
( { WriteHeader = yes } ->
- { module_info_get_foreign_header(ModuleInfo, CHeader) },
- intermod__write_c_header(CHeader)
+ { module_info_get_foreign_decl(ModuleInfo, ForeignDecl) },
+ intermod__write_foreign_decl(ForeignDecl)
;
[]
),
@@ -1121,13 +1122,14 @@
intermod__write_modules(Rest)
).
-:- pred intermod__write_c_header(list(foreign_header_code)::in,
+:- pred intermod__write_foreign_decl(list(foreign_decl_code)::in,
io__state::di, io__state::uo) is det.
-intermod__write_c_header([]) --> [].
-intermod__write_c_header([Header - _ | Headers]) -->
- intermod__write_c_header(Headers),
- mercury_output_pragma_c_header(Header).
+intermod__write_foreign_decl([]) --> [].
+intermod__write_foreign_decl(
+ [foreign_decl_code(Language, Header, _) | Headers]) -->
+ intermod__write_foreign_decl(Headers),
+ mercury_output_pragma_foreign_decl(Language, Header).
:- pred intermod__write_types(assoc_list(type_id, hlds_type_defn)::in,
io__state::di, io__state::uo) is det.
@@ -1372,11 +1374,11 @@
{ clauses_info_headvars(ClausesInfo, HeadVars) },
{ clauses_info_clauses(ClausesInfo, Clauses) },
- % handle pragma c_code(...) separately
+ % handle pragma foreign_code(...) separately
( { pred_info_get_goal_type(PredInfo, pragmas) } ->
{ pred_info_procedures(PredInfo, Procs) },
- intermod__write_c_code(SymName, PredOrFunc, HeadVars, VarSet,
- Clauses, Procs)
+ intermod__write_foreign_code(SymName, PredOrFunc, HeadVars,
+ VarSet, Clauses, Procs)
;
{ pred_info_get_goal_type(PredInfo, assertion) }
->
@@ -1592,13 +1594,13 @@
% This marker should only occur after the magic sets transformation.
error("intermod__should_output_marker: generate_inline").
- % Some pretty kludgy stuff to get c code written correctly.
-:- pred intermod__write_c_code(sym_name::in, pred_or_func::in,
+ % Some pretty kludgy stuff to get foreign code written correctly.
+:- pred intermod__write_foreign_code(sym_name::in, pred_or_func::in,
list(prog_var)::in, prog_varset::in,
list(clause)::in, proc_table::in, io__state::di, io__state::uo) is det.
-intermod__write_c_code(_, _, _, _, [], _) --> [].
-intermod__write_c_code(SymName, PredOrFunc, HeadVars, Varset,
+intermod__write_foreign_code(_, _, _, _, [], _) --> [].
+intermod__write_foreign_code(SymName, PredOrFunc, HeadVars, Varset,
[Clause | Clauses], Procs) -->
{ Clause = clause(ProcIds, Goal, _) },
(
@@ -1607,53 +1609,54 @@
{ Goal = conj(Goals) - _ },
{ list__filter(
lambda([X::in] is semidet, (
- X = pragma_foreign_code(_,_,_,_,_,_,_,_) - _
+ X = pragma_foreign_code(_,_,_,_,_,_,_) - _
)),
- Goals, [CCodeGoal]) },
- { CCodeGoal = pragma_foreign_code(c, Attributes,
+ Goals, [ForeignCodeGoal]) },
+ { ForeignCodeGoal = pragma_foreign_code(Attributes,
_, _, Vars, Names, _, PragmaCode) - _ }
;
- { Goal = pragma_foreign_code(c, Attributes,
+ { Goal = pragma_foreign_code(Attributes,
_, _, Vars, Names, _, PragmaCode) - _ }
)
->
- intermod__write_c_clauses(Procs, ProcIds, PredOrFunc,
+ intermod__write_foreign_clauses(Procs, ProcIds, PredOrFunc,
PragmaCode, Attributes, Vars, Varset, Names,
SymName)
;
- { error("intermod__write_c_code called with non c_code goal") }
+ { error("intermod__write_foreign_code called with non foreign_code goal") }
),
- intermod__write_c_code(SymName, PredOrFunc, HeadVars, Varset,
+ intermod__write_foreign_code(SymName, PredOrFunc, HeadVars, Varset,
Clauses, Procs).
-:- pred intermod__write_c_clauses(proc_table::in, list(proc_id)::in,
+:- pred intermod__write_foreign_clauses(proc_table::in, list(proc_id)::in,
pred_or_func::in, pragma_foreign_code_impl::in,
pragma_foreign_code_attributes::in, list(prog_var)::in,
prog_varset::in, list(maybe(pair(string, mode)))::in,
sym_name::in, io__state::di, io__state::uo) is det.
-intermod__write_c_clauses(_, [], _, _, _, _, _, _, _) --> [].
-intermod__write_c_clauses(Procs, [ProcId | ProcIds], PredOrFunc,
+intermod__write_foreign_clauses(_, [], _, _, _, _, _, _, _) --> [].
+intermod__write_foreign_clauses(Procs, [ProcId | ProcIds], PredOrFunc,
PragmaImpl, Attributes, Vars, Varset0, Names, SymName) -->
{ map__lookup(Procs, ProcId, ProcInfo) },
{ proc_info_maybe_declared_argmodes(ProcInfo, MaybeArgModes) },
( { MaybeArgModes = yes(ArgModes) } ->
- { get_pragma_c_code_vars(Vars, Names, Varset0, ArgModes,
+ { get_pragma_foreign_code_vars(Vars, Names, Varset0, ArgModes,
Varset, PragmaVars) },
- mercury_output_pragma_c_code(Attributes, SymName,
+ mercury_output_pragma_foreign_code(Attributes, SymName,
PredOrFunc, PragmaVars, Varset, PragmaImpl),
- intermod__write_c_clauses(Procs, ProcIds, PredOrFunc,
+ intermod__write_foreign_clauses(Procs, ProcIds, PredOrFunc,
PragmaImpl, Attributes, Vars, Varset, Names,
SymName)
;
- { error("intermod__write_c_clauses: no mode declaration") }
+ { error(
+ "intermod__write_foreign_clauses: no mode declaration") }
).
-:- pred get_pragma_c_code_vars(list(prog_var)::in,
+:- pred get_pragma_foreign_code_vars(list(prog_var)::in,
list(maybe(pair(string, mode)))::in, prog_varset::in,
list(mode)::in, prog_varset::out, list(pragma_var)::out) is det.
-get_pragma_c_code_vars(HeadVars, VarNames, VarSet0, ArgModes,
+get_pragma_foreign_code_vars(HeadVars, VarNames, VarSet0, ArgModes,
VarSet, PragmaVars) :-
(
HeadVars = [Var | Vars],
@@ -1668,7 +1671,7 @@
),
PragmaVar = pragma_var(Var, Name, Mode),
varset__name_var(VarSet0, Var, Name, VarSet1),
- get_pragma_c_code_vars(Vars, Names, VarSet1, Modes,
+ get_pragma_foreign_code_vars(Vars, Names, VarSet1, Modes,
VarSet, PragmaVars1),
PragmaVars = [PragmaVar | PragmaVars1]
;
@@ -1679,7 +1682,7 @@
PragmaVars = [],
VarSet = VarSet0
;
- error("intermod:get_pragma_c_code_vars")
+ error("intermod:get_pragma_foreign_code_vars")
).
%-----------------------------------------------------------------------------%
@@ -1700,7 +1703,7 @@
% intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_get_module_info(module_info::out,
intermod_info::in, intermod_info::out) is det.
-:- pred intermod_info_get_write_c_header(bool::out,
+:- pred intermod_info_get_write_foreign_header(bool::out,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_get_var_types(map(prog_var, type)::out,
intermod_info::in, intermod_info::out) is det.
@@ -1717,7 +1720,8 @@
%intermod_info_get_modes(Modes) --> =(info(_,_,_,_,Modes,_,_,_,_,_)).
%intermod_info_get_insts(Insts) --> =(info(_,_,_,_,_,Insts,_,_,_,_)).
intermod_info_get_module_info(Module) --> =(info(_,_,_,_,_,_,Module,_,_,_)).
-intermod_info_get_write_c_header(Write) --> =(info(_,_,_,_,_,_,_,Write,_,_)).
+intermod_info_get_write_foreign_header(Write) -->
+ =(info(_,_,_,_,_,_,_,Write,_,_)).
intermod_info_get_var_types(VarTypes) --> =(info(_,_,_,_,_,_,_,_,VarTypes,_)).
intermod_info_get_tvarset(TVarSet) --> =(info(_,_,_,_,_,_,_,_,_,TVarSet)).
Index: compiler/lambda.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lambda.m,v
retrieving revision 1.68
diff -u -r1.68 lambda.m
--- compiler/lambda.m 2000/10/30 07:08:59 1.68
+++ compiler/lambda.m 2000/10/30 12:41:07
@@ -269,8 +269,8 @@
lambda__process_goal_2(call(A,B,C,D,E,F), GoalInfo,
call(A,B,C,D,E,F) - GoalInfo) -->
[].
-lambda__process_goal_2(pragma_foreign_code(A,B,C,D,E,F,G,H), GoalInfo,
- pragma_foreign_code(A,B,C,D,E,F,G,H) - GoalInfo) -->
+lambda__process_goal_2(pragma_foreign_code(A,B,C,D,E,F,G), GoalInfo,
+ pragma_foreign_code(A,B,C,D,E,F,G) - GoalInfo) -->
[].
lambda__process_goal_2(bi_implication(_, _), _, _) -->
% these should have been expanded out by now
Index: compiler/lco.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/lco.m,v
retrieving revision 1.14
diff -u -r1.14 lco.m
--- compiler/lco.m 2000/08/09 07:46:49 1.14
+++ compiler/lco.m 2000/10/16 01:19:43
@@ -91,8 +91,8 @@
lco_in_goal_2(unify(A,B,C,D,E), _ModuleInfo, unify(A,B,C,D,E)).
-lco_in_goal_2(pragma_foreign_code(A,B,C,D,E,F,G,H), _,
- pragma_foreign_code(A,B,C,D,E,F,G,H)).
+lco_in_goal_2(pragma_foreign_code(A,B,C,D,E,F,G), _,
+ pragma_foreign_code(A,B,C,D,E,F,G)).
lco_in_goal_2(bi_implication(_, _), _, _) :-
% these should have been expanded out by now
Index: compiler/live_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/live_vars.m,v
retrieving revision 1.93
diff -u -r1.93 live_vars.m
--- compiler/live_vars.m 2000/10/13 04:04:47 1.93
+++ compiler/live_vars.m 2000/10/22 11:54:33
@@ -334,7 +334,7 @@
true
).
-build_live_sets_in_goal_2(pragma_foreign_code(_Language, Attributes,
+build_live_sets_in_goal_2(pragma_foreign_code(Attributes,
PredId, ProcId, Args, _, _, _),
Liveness, NondetLiveness0, ResumeVars0, LiveSets0,
GoalInfo, AllocData,
Index: compiler/liveness.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/liveness.m,v
retrieving revision 1.112
diff -u -r1.112 liveness.m
--- compiler/liveness.m 2000/10/03 00:34:13 1.112
+++ compiler/liveness.m 2000/10/16 01:53:49
@@ -334,7 +334,7 @@
detect_liveness_in_goal_2(unify(_,_,_,_,_), _, _, _, _, _) :-
error("unify in detect_liveness_in_goal_2").
-detect_liveness_in_goal_2(pragma_foreign_code(_,_,_,_,_,_,_,_),
+detect_liveness_in_goal_2(pragma_foreign_code(_,_,_,_,_,_,_),
_, _, _, _, _) :-
error("pragma_foreign_code in detect_liveness_in_goal_2").
@@ -544,7 +544,7 @@
detect_deadness_in_goal_2(unify(_,_,_,_,_), _, _, _, _, _) :-
error("unify in detect_deadness_in_goal_2").
-detect_deadness_in_goal_2(pragma_foreign_code(_, _, _, _, _, _, _, _),
+detect_deadness_in_goal_2(pragma_foreign_code(_, _, _, _, _, _, _),
_, _, _, _, _) :-
error("pragma_foreign_code in detect_deadness_in_goal_2").
@@ -774,8 +774,8 @@
detect_resume_points_in_goal_2(unify(A,B,C,D,E), _, Liveness, _, _,
unify(A,B,C,D,E), Liveness).
-detect_resume_points_in_goal_2(pragma_foreign_code(A,B,C,D,E,F,G,H), _,
- Liveness, _, _, pragma_foreign_code(A,B,C,D,E,F,G,H), Liveness).
+detect_resume_points_in_goal_2(pragma_foreign_code(A,B,C,D,E,F,G), _,
+ Liveness, _, _, pragma_foreign_code(A,B,C,D,E,F,G), Liveness).
detect_resume_points_in_goal_2(bi_implication(_, _), _, _, _, _, _, _) :-
% these should have been expanded out by now
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.268
diff -u -r1.268 llds.m
--- compiler/llds.m 2000/10/31 02:15:43 1.268
+++ compiler/llds.m 2000/11/08 02:07:03
@@ -36,20 +36,22 @@
---> foreign_interface_info(
module_name,
% info about stuff imported from C:
- foreign_header_info,
+ foreign_decl_info,
foreign_body_info,
% info about stuff exported to C:
foreign_export_decls,
foreign_export_defns
).
-:- type foreign_header_info == list(foreign_header_code).
+:- type foreign_decl_info == list(foreign_decl_code).
% in reverse order
:- type foreign_body_info == list(foreign_body_code).
% in reverse order
-:- type foreign_header_code == pair(string, prog_context).
-:- type foreign_body_code == pair(string, prog_context).
+:- type foreign_decl_code --->
+ foreign_decl_code(foreign_language, string, prog_context).
+:- type foreign_body_code --->
+ foreign_body_code(foreign_language, string, prog_context).
:- type foreign_export_defns == list(foreign_export).
:- type foreign_export_decls == list(foreign_export_decl).
@@ -109,7 +111,7 @@
:- type c_file
---> c_file(
module_name,
- foreign_header_info,
+ foreign_decl_info,
list(user_foreign_code),
list(foreign_export),
list(comp_gen_c_var),
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.163
diff -u -r1.163 llds_out.m
--- compiler/llds_out.m 2000/11/09 10:41:50 1.163
+++ compiler/llds_out.m 2000/11/10 07:14:54
@@ -312,7 +312,7 @@
).
:- pred output_split_user_foreign_codes(list(user_foreign_code)::in,
- module_name::in, list(foreign_header_code)::in, set_bbbtree(label)::in,
+ module_name::in, list(foreign_decl_code)::in, set_bbbtree(label)::in,
int::in, int::out, io__state::di, io__state::uo) is det.
output_split_user_foreign_codes([], _, _, _, Num, Num) --> [].
@@ -326,7 +326,7 @@
C_HeaderLines, StackLayoutLabels, Num1, Num).
:- pred output_split_c_exports(list(foreign_export)::in,
- module_name::in, list(foreign_header_code)::in, set_bbbtree(label)::in,
+ module_name::in, list(foreign_decl_code)::in, set_bbbtree(label)::in,
int::in, int::out, io__state::di, io__state::uo) is det.
output_split_c_exports([], _, _, _, Num, Num) --> [].
@@ -340,7 +340,7 @@
StackLayoutLabels, Num1, Num).
:- pred output_split_comp_gen_c_vars(list(comp_gen_c_var)::in,
- module_name::in, list(foreign_header_code)::in, set_bbbtree(label)::in,
+ module_name::in, list(foreign_decl_code)::in, set_bbbtree(label)::in,
int::in, int::out, io__state::di, io__state::uo) is det.
output_split_comp_gen_c_vars([], _, _, _, Num, Num) --> [].
@@ -353,7 +353,7 @@
StackLayoutLabels, Num1, Num).
:- pred output_split_comp_gen_c_datas(list(comp_gen_c_data)::in,
- module_name::in, list(foreign_header_code)::in, set_bbbtree(label)::in,
+ module_name::in, list(foreign_decl_code)::in, set_bbbtree(label)::in,
int::in, int::out, io__state::di, io__state::uo) is det.
output_split_comp_gen_c_datas([], _, _, _, Num, Num) --> [].
@@ -366,7 +366,7 @@
StackLayoutLabels, Num1, Num).
:- pred output_split_comp_gen_c_modules(list(comp_gen_c_module)::in,
- module_name::in, list(foreign_header_code)::in, set_bbbtree(label)::in,
+ module_name::in, list(foreign_decl_code)::in, set_bbbtree(label)::in,
int::in, int::out, io__state::di, io__state::uo) is det.
output_split_comp_gen_c_modules([], _, _, _, Num, Num) --> [].
@@ -999,48 +999,59 @@
:- pred output_user_foreign_code(user_foreign_code::in,
io__state::di, io__state::uo) is det.
-output_user_foreign_code(user_foreign_code(c, Foreign_Code, Context)) -->
- globals__io_lookup_bool_option(auto_comments, PrintComments),
- ( { PrintComments = yes } ->
- io__write_string("/* "),
- prog_out__write_context(Context),
- io__write_string(" pragma foreign_code */\n")
+output_user_foreign_code(user_foreign_code(Lang, Foreign_Code, Context)) -->
+ ( { Lang = c } ->
+ globals__io_lookup_bool_option(auto_comments, PrintComments),
+ ( { PrintComments = yes } ->
+ io__write_string("/* "),
+ prog_out__write_context(Context),
+ io__write_string(" pragma foreign_code */\n")
+ ;
+ []
+ ),
+ output_set_line_num(Context),
+ io__write_string(Foreign_Code),
+ io__write_string("\n"),
+ output_reset_line_num
;
- []
- ),
- output_set_line_num(Context),
- io__write_string(Foreign_Code),
- io__write_string("\n"),
- output_reset_line_num.
+ { error("llds_out__output_user_foreign_code: unimplemented: foreign code other than C") }
+ ).
% output_foreign_header_include_lines reverses the list of c
% header lines and passes them to
% output_c_header_include_lines_2 which outputs them. The list
% must be reversed since they are inserted in reverse order.
-:- pred output_foreign_header_include_lines(list(foreign_header_code)::in,
+:- pred output_foreign_header_include_lines(list(foreign_decl_code)::in,
io__state::di, io__state::uo) is det.
output_foreign_header_include_lines(Headers) -->
{ list__reverse(Headers, RevHeaders) },
output_foreign_header_include_lines_2(RevHeaders).
-:- pred output_foreign_header_include_lines_2(list(foreign_header_code)::in,
+:- pred output_foreign_header_include_lines_2(list(foreign_decl_code)::in,
io__state::di, io__state::uo) is det.
output_foreign_header_include_lines_2([]) --> [].
-output_foreign_header_include_lines_2([Code - Context | Hs]) -->
- globals__io_lookup_bool_option(auto_comments, PrintComments),
- ( { PrintComments = yes } ->
- io__write_string("/* "),
- prog_out__write_context(Context),
- io__write_string(" pragma(foreign_header_code) */\n")
+output_foreign_header_include_lines_2(
+ [foreign_decl_code(Lang, Code, Context) | Hs]) -->
+ ( { Lang = c } ->
+ globals__io_lookup_bool_option(auto_comments, PrintComments),
+ ( { PrintComments = yes } ->
+ io__write_string("/* "),
+ prog_out__write_context(Context),
+ io__write_string(" pragma foreign_decl_code( "),
+ io__write(Lang),
+ io__write_string(" */\n")
+ ;
+ []
+ ),
+ output_set_line_num(Context),
+ io__write_string(Code),
+ io__write_string("\n"),
+ output_reset_line_num
;
- []
+ { error("llds_out__output_user_foreign_code: unexpected: foreign code other than C") }
),
- output_set_line_num(Context),
- io__write_string(Code),
- io__write_string("\n"),
- output_reset_line_num,
output_foreign_header_include_lines_2(Hs).
:- pred output_exported_c_functions(list(string), io__state, io__state).
Index: compiler/magic.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic.m,v
retrieving revision 1.24
diff -u -r1.24 magic.m
--- compiler/magic.m 2000/10/13 13:55:32 1.24
+++ compiler/magic.m 2000/10/22 11:54:35
@@ -1510,7 +1510,7 @@
{ error("Sorry, not yet implemented: parallel conjunction in Aditi procedures") }.
magic__preprocess_goal_2(generic_call(_, _, _, _) - _, _, _, _) -->
{ error("Sorry, not yet implemented: higher-order or class-method calls in Aditi procedures") }.
-magic__preprocess_goal_2(pragma_foreign_code(_, _, _, _, _, _, _, _) -
+magic__preprocess_goal_2(pragma_foreign_code(_, _, _, _, _, _, _) -
_, _, _, _) -->
{ error("Sorry, not yet implemented: pragma foreign_code calls in Aditi procedures") }.
magic__preprocess_goal_2(conj(Goals0) - GoalInfo, [conj(Goals) - GoalInfo],
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.358
diff -u -r1.358 make_hlds.m
--- compiler/make_hlds.m 2000/11/06 08:28:33 1.358
+++ compiler/make_hlds.m 2000/11/08 06:39:31
@@ -97,7 +97,7 @@
:- import_module code_util, unify_proc, type_util, mode_util.
:- import_module mercury_to_mercury, passes_aux, clause_to_proc, inst_match.
:- import_module fact_table, purity, goal_util, term_util, export, llds.
-:- import_module error_util.
+:- import_module error_util, foreign.
:- import_module string, char, int, set, bintree, map, multi_map, require.
:- import_module bag, term, varset, getopt, assoc_list, term_io.
@@ -400,16 +400,17 @@
{ Pragma = source_file(_) },
{ Module = Module0 }
;
- { Pragma = foreign(_Lang, Body_Code) },
- { module_add_c_body_code(Body_Code, Context,
+ { Pragma = foreign(Lang, Body_Code) },
+ { module_add_foreign_body_code(Lang, Body_Code, Context,
Module0, Module) }
;
- { Pragma = c_header_code(C_Header) },
- { module_add_c_header(C_Header, Context, Module0, Module) }
+ { Pragma = foreign_decl(Lang, C_Header) },
+ { module_add_foreign_decl(Lang, C_Header, Context,
+ Module0, Module) }
;
% Handle pragma c_code decls later on (when we process
% clauses).
- { Pragma = foreign(_, _, _, _, _, _, _) },
+ { Pragma = foreign(_, _, _, _, _, _) },
{ Module = Module0 }
;
% Handle pragma tabled decls later on (when we process
@@ -688,13 +689,12 @@
add_item_clause(pragma(Pragma), Status, Status, Context,
Module0, Module, Info0, Info) -->
(
- { Pragma = foreign(Language, Attributes, Pred, PredOrFunc,
+ { Pragma = foreign(Attributes, Pred, PredOrFunc,
Vars, VarSet, PragmaImpl) }
->
- { Language = c },
- module_add_pragma_c_code(Attributes, Pred, PredOrFunc,
- Vars, VarSet, PragmaImpl, Status, Context,
- Module0, Module, Info0, Info)
+ module_add_pragma_foreign_code(Attributes,
+ Pred, PredOrFunc, Vars, VarSet, PragmaImpl,
+ Status, Context, Module0, Module, Info0, Info)
;
{ Pragma = import(Name, PredOrFunc, Modes, Attributes,
C_Function) }
@@ -3760,28 +3760,6 @@
).
%-----------------------------------------------------------------------------%
-
-:- pred module_add_c_header(string, prog_context, module_info, module_info).
-:- mode module_add_c_header(in, in, in, out) is det.
-
-module_add_c_header(C_Header, Context, Module0, Module) :-
- module_info_get_foreign_header(Module0, C_HeaderIndex0),
- % store the c headers in reverse order and reverse them later
- % for efficiency
- C_HeaderIndex1 = [C_Header - Context|C_HeaderIndex0],
- module_info_set_foreign_header(Module0, C_HeaderIndex1, Module).
-
-:- pred module_add_c_body_code(string, prog_context, module_info, module_info).
-:- mode module_add_c_body_code(in, in, in, out) is det.
-
-module_add_c_body_code(C_Body_Code, Context, Module0, Module) :-
- module_info_get_foreign_body_code(Module0, C_Body_List0),
- % store the c headers in reverse order and reverse them later
- % for efficiency
- C_Body_List = [C_Body_Code - Context | C_Body_List0],
- module_info_set_foreign_body_code(Module0, C_Body_List, Module).
-
-%-----------------------------------------------------------------------------%
%
% module_add_pragma_import:
% Handles `pragma import' declarations, by figuring out which predicate
@@ -3922,53 +3900,24 @@
di, uo) is det.
pred_add_pragma_import(PredInfo0, PredId, ProcId, Attributes, C_Function,
Context, PredInfo, ModuleInfo0, ModuleInfo, Info0, Info) -->
+ { pred_info_procedures(PredInfo0, Procs) },
+ { map__lookup(Procs, ProcId, ProcInfo) },
+ { foreign__make_pragma_import(PredInfo0, ProcInfo, C_Function, Context,
+ ModuleInfo0, PragmaImpl, VarSet, PragmaVars, ArgTypes,
+ Arity, PredOrFunc) },
+
%
% lookup some information we need from the pred_info and proc_info
%
- { pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc) },
- { pred_info_module(PredInfo0, PredModule) },
{ pred_info_name(PredInfo0, PredName) },
+ { pred_info_module(PredInfo0, PredModule) },
{ pred_info_clauses_info(PredInfo0, Clauses0) },
- { pred_info_arg_types(PredInfo0, ArgTypes) },
{ pred_info_get_purity(PredInfo0, Purity) },
- { pred_info_procedures(PredInfo0, Procs) },
- { map__lookup(Procs, ProcId, ProcInfo) },
- { proc_info_argmodes(ProcInfo, Modes) },
- { proc_info_interface_code_model(ProcInfo, CodeModel) },
%
- % Build a list of argument variables, together with their
- % names, modes, and types.
+ % Add the code for this `pragma import' to the clauses_info
%
- { varset__init(VarSet0) },
- { list__length(Modes, Arity) },
- { varset__new_vars(VarSet0, Arity, Vars, VarSet) },
- { create_pragma_vars(Vars, Modes, 0, PragmaVars) },
- { assoc_list__from_corresponding_lists(PragmaVars, ArgTypes,
- PragmaVarsAndTypes) },
-
- %
- % Construct parts of the C_Code string for calling C_Function.
- % This C code fragment invokes the specified C function
- % with the appropriate arguments from the list constructed
- % above, passed in the appropriate manner (by value, or by
- % passing the address to simulate pass-by-reference), and
- % assigns the return value (if any) to the appropriate place.
- % As this phase occurs before polymorphism, we don't know about
- % the type-infos yet. polymorphism.m is responsible for adding
- % the type-info arguments to the list of variables.
- %
- { handle_return_value(CodeModel, PredOrFunc, PragmaVarsAndTypes,
- ModuleInfo0, ArgPragmaVarsAndTypes, Return) },
- { assoc_list__keys(ArgPragmaVarsAndTypes, ArgPragmaVars) },
- { create_pragma_import_c_code(ArgPragmaVars, ModuleInfo0,
- "", Variables) },
-
- %
- % Add the C_Code for this `pragma import' to the clauses_info
- %
- { PragmaImpl = import(C_Function, Return, Variables, yes(Context)) },
- clauses_info_add_pragma_c_code(Clauses0, Purity, Attributes,
+ clauses_info_add_pragma_foreign_code(Clauses0, Purity, Attributes,
PredId, ProcId, VarSet, PragmaVars, ArgTypes, PragmaImpl,
Context, PredOrFunc, qualified(PredModule, PredName),
Arity, Clauses, ModuleInfo0, ModuleInfo, Info0, Info),
@@ -3978,146 +3927,19 @@
%
{ pred_info_set_clauses_info(PredInfo0, Clauses, PredInfo) }.
-%
-% handle_return_value(CodeModel, PredOrFunc, Args0, M, Args, C_Code0):
-% Figures out what to do with the C function's return value,
-% based on Mercury procedure's code model, whether it is a predicate
-% or a function, and (if it is a function) the type and mode of the
-% function result. Constructs a C code fragment `C_Code0' which
-% is a string of the form "<Something> =" that assigns the return
-% value to the appropriate place, if there is a return value,
-% or is an empty string, if there is no return value.
-% Returns in Args all of Args0 that must be passed as arguments
-% (i.e. all of them, or all of them except the return value).
-%
-:- pred handle_return_value(code_model, pred_or_func,
- assoc_list(pragma_var, type), module_info,
- assoc_list(pragma_var, type), string).
-:- mode handle_return_value(in, in, in, in, out, out) is det.
-
-handle_return_value(CodeModel, PredOrFunc, Args0, ModuleInfo, Args, C_Code0) :-
- ( CodeModel = model_det,
- (
- PredOrFunc = function,
- pred_args_to_func_args(Args0, Args1, RetArg),
- RetArg = pragma_var(_, RetArgName, RetMode) - RetType,
- mode_to_arg_mode(ModuleInfo, RetMode, RetType,
- RetArgMode),
- RetArgMode = top_out,
- \+ type_util__is_dummy_argument_type(RetType)
- ->
- string__append(RetArgName, " = ", C_Code0),
- Args2 = Args1
- ;
- C_Code0 = "",
- Args2 = Args0
- )
- ; CodeModel = model_semi,
- % we treat semidet functions the same as semidet predicates,
- % which means that for Mercury functions the Mercury return
- % value becomes the last argument, and the C return value
- % is a bool that is used to indicate success or failure.
- C_Code0 = "SUCCESS_INDICATOR = ",
- Args2 = Args0
- ; CodeModel = model_non,
- % XXX we should report an error here, rather than generating
- % C code with `#error'...
- C_Code0 = "\n#error ""cannot import nondet procedure""\n",
- Args2 = Args0
- ),
- list__filter(include_import_arg(ModuleInfo), Args2, Args).
-
-%
-% include_import_arg(M, Arg):
-% Succeeds iff Arg should be included in the arguments of the C
-% function. Fails if `Arg' has a type such as `io__state' that
-% is just a dummy argument that should not be passed to C.
-%
-:- pred include_import_arg(module_info, pair(pragma_var, type)).
-:- mode include_import_arg(in, in) is semidet.
-
-include_import_arg(ModuleInfo, pragma_var(_Var, _Name, Mode) - Type) :-
- mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
- ArgMode \= top_unused,
- \+ type_util__is_dummy_argument_type(Type).
-
-%
-% create_pragma_vars(Vars, Modes, ArgNum0, PragmaVars):
-% given list of vars and modes, and an initial argument number,
-% allocate names to all the variables, and
-% construct a single list containing the variables, names, and modes.
-%
-:- pred create_pragma_vars(list(prog_var), list(mode), int, list(pragma_var)).
-:- mode create_pragma_vars(in, in, in, out) is det.
-
-create_pragma_vars([], [], _Num, []).
-
-create_pragma_vars([Var|Vars], [Mode|Modes], ArgNum0,
- [PragmaVar | PragmaVars]) :-
- %
- % Figure out a name for the C variable which will hold this argument
- %
- ArgNum is ArgNum0 + 1,
- string__int_to_string(ArgNum, ArgNumString),
- string__append("Arg", ArgNumString, ArgName),
-
- PragmaVar = pragma_var(Var, ArgName, Mode),
-
- create_pragma_vars(Vars, Modes, ArgNum, PragmaVars).
-
-create_pragma_vars([_|_], [], _, _) :-
- error("create_pragma_vars: length mis-match").
-create_pragma_vars([], [_|_], _, _) :-
- error("create_pragma_vars: length mis-match").
-
-%
-% create_pragma_import_c_code(PragmaVars, M, C_Code0, C_Code):
-% This predicate creates the C code fragments for each argument
-% in PragmaVars, and appends them to C_Code0, returning C_Code.
-%
-:- pred create_pragma_import_c_code(list(pragma_var), module_info,
- string, string).
-:- mode create_pragma_import_c_code(in, in, in, out) is det.
-
-create_pragma_import_c_code([], _ModuleInfo, C_Code, C_Code).
-
-create_pragma_import_c_code([PragmaVar | PragmaVars], ModuleInfo,
- C_Code0, C_Code) :-
- PragmaVar = pragma_var(_Var, ArgName, Mode),
-
- %
- % Construct the C code fragment for passing this argument,
- % and append it to C_Code0.
- % Note that C handles output arguments by passing the variable'
- % address, so if the mode is output, we need to put an `&' before
- % the variable name.
- %
- ( mode_is_output(ModuleInfo, Mode) ->
- string__append(C_Code0, "&", C_Code1)
- ;
- C_Code1 = C_Code0
- ),
- string__append(C_Code1, ArgName, C_Code2),
- ( PragmaVars \= [] ->
- string__append(C_Code2, ", ", C_Code3)
- ;
- C_Code3 = C_Code2
- ),
-
- create_pragma_import_c_code(PragmaVars, ModuleInfo, C_Code3, C_Code).
-
%-----------------------------------------------------------------------------%
-
-:- pred module_add_pragma_c_code(pragma_foreign_code_attributes, sym_name,
- pred_or_func, list(pragma_var), prog_varset, pragma_foreign_code_impl,
- import_status, prog_context, module_info, module_info,
- qual_info, qual_info, io__state, io__state).
-:- mode module_add_pragma_c_code(in, in, in, in, in, in, in, in, in, out,
- in, out, di, uo) is det.
-module_add_pragma_c_code(Attributes, PredName, PredOrFunc, PVars, VarSet,
- PragmaImpl, Status, Context, ModuleInfo0, ModuleInfo,
- Info0, Info) -->
+:- pred module_add_pragma_foreign_code(pragma_foreign_code_attributes,
+ sym_name, pred_or_func, list(pragma_var), prog_varset,
+ pragma_foreign_code_impl, import_status, prog_context,
+ module_info, module_info, qual_info, qual_info, io__state,
+ io__state).
+:- mode module_add_pragma_foreign_code(in, in, in, in, in, in, in, in,
+ in, out, in, out, di, uo) is det.
+
+module_add_pragma_foreign_code(Attributes, PredName, PredOrFunc,
+ PVars, VarSet, PragmaImpl, Status, Context,
+ ModuleInfo0, ModuleInfo, Info0, Info) -->
{ module_info_name(ModuleInfo0, ModuleName) },
{ list__length(PVars, Arity) },
% print out a progress message
@@ -4125,13 +3947,16 @@
(
{ VeryVerbose = yes }
->
- io__write_string("% Processing `:- pragma c_code' for "),
+ io__write_string("% Processing `:- pragma foreign_code' for "),
hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity),
io__write_string("...\n")
;
[]
),
+ globals__io_lookup_foreign_language_option(use_foreign_language,
+ UseForeignLang),
+
% Lookup the pred declaration in the predicate table.
% (If it's not there, print an error message and insert
% a dummy declaration for the predicate.)
@@ -4145,7 +3970,7 @@
;
preds_add_implicit_report_error(ModuleName,
PredOrFunc, PredName, Arity, Status, no, Context,
- "`:- pragma c_code' declaration",
+ "`:- pragma foreign_code' declaration",
PredId, ModuleInfo0, ModuleInfo1)
),
% Lookup the pred_info for this pred,
@@ -4167,7 +3992,7 @@
->
{ module_info_incr_errors(ModuleInfo1, ModuleInfo) },
prog_out__write_context(Context),
- io__write_string("Error: `:- pragma c_code' "),
+ io__write_string("Error: `:- pragma foreign_code' "),
io__write_string("declaration for imported "),
hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity),
io__write_string(".\n"),
@@ -4177,14 +4002,22 @@
->
{ module_info_incr_errors(ModuleInfo1, ModuleInfo) },
prog_out__write_context(Context),
- io__write_string("Error: `:- pragma c_code' declaration "),
- io__write_string("for "),
+ io__write_string(
+ "Error: `:- pragma foreign_code' declaration for "),
hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity),
io__write_string("\n"),
prog_out__write_context(Context),
io__write_string(" with preceding clauses.\n"),
{ Info = Info0 }
;
+ % Don't add clauses for foreign languages other
+ % than the one we are using.
+ { foreign_language(Attributes, PragmaForeignLanguage) },
+ { UseForeignLang \= PragmaForeignLanguage }
+ ->
+ { ModuleInfo = ModuleInfo1 },
+ { Info = Info0 }
+ ;
% add the pragma declaration to the proc_info for this procedure
{ pred_info_procedures(PredInfo1, Procs) },
{ map__to_assoc_list(Procs, ExistingProcs) },
@@ -4196,11 +4029,12 @@
{ pred_info_clauses_info(PredInfo1, Clauses0) },
{ pred_info_arg_types(PredInfo1, ArgTypes) },
{ pred_info_get_purity(PredInfo1, Purity) },
- clauses_info_add_pragma_c_code(Clauses0, Purity,
- Attributes, PredId, ProcId, VarSet,
- PVars, ArgTypes, PragmaImpl, Context,
- PredOrFunc, PredName, Arity,
- Clauses, ModuleInfo1, ModuleInfo2, Info0, Info),
+ clauses_info_add_pragma_foreign_code(
+ Clauses0, Purity, Attributes, PredId,
+ ProcId, VarSet, PVars, ArgTypes,
+ PragmaImpl, Context, PredOrFunc,
+ PredName, Arity, Clauses, ModuleInfo1,
+ ModuleInfo2, Info0, Info),
{ pred_info_set_clauses_info(PredInfo1, Clauses,
PredInfo2) },
{ pred_info_set_goal_type(PredInfo2, pragmas,
@@ -4219,7 +4053,7 @@
io__stderr_stream(StdErr),
io__set_output_stream(StdErr, OldStream),
prog_out__write_context(Context),
- io__write_string("Error: `:- pragma c_code' "),
+ io__write_string("Error: `:- pragma foreign_code' "),
io__write_string("declaration for undeclared mode "),
io__write_string("of "),
hlds_out__write_simple_call_id(PredOrFunc,
@@ -4731,11 +4565,11 @@
warn_singletons_in_unify(Var, RHS, GoalInfo, QuantVars, VarSet,
PredCallId, MI).
-warn_singletons_in_goal_2(pragma_foreign_code(_, _, _, _, _, ArgInfo, _,
+warn_singletons_in_goal_2(pragma_foreign_code(_, _, _, _, ArgInfo, _,
PragmaImpl), GoalInfo, _QuantVars, _VarSet, PredCallId, MI) -->
{ goal_info_get_context(GoalInfo, Context) },
% XXX not just C code
- warn_singletons_in_pragma_c_code(PragmaImpl, ArgInfo, Context,
+ warn_singletons_in_pragma_foreign_code(PragmaImpl, ArgInfo, Context,
PredCallId, MI).
warn_singletons_in_goal_2(bi_implication(LHS, RHS), _GoalInfo, QuantVars,
@@ -4818,21 +4652,27 @@
maybe_warn_pragma_singletons(PragmaImpl, ArgInfo, Context, CallId, MI) -->
globals__io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars),
( { WarnSingletonVars = yes } ->
- warn_singletons_in_pragma_c_code(PragmaImpl, ArgInfo,
+ warn_singletons_in_pragma_foreign_code(PragmaImpl, ArgInfo,
Context, CallId, MI)
;
[]
).
- % warn_singletons_in_pragma_c_code checks to see if each variable is
- % mentioned at least once in the c code fragments that ought to
- % mention it. If not, it gives a warning.
-:- pred warn_singletons_in_pragma_c_code(pragma_foreign_code_impl,
+ % warn_singletons_in_pragma_foreign_code checks to see if each
+ % variable is mentioned at least once in the foreign code
+ % fragments that ought to mention it. If not, it gives a
+ % warning.
+ % (note that for some foreign languages it might not be
+ % appropriate to do this check, or you may been to add a
+ % transformation to map Mercury variable names into identifiers
+ % for that foreign language).
+:- pred warn_singletons_in_pragma_foreign_code(pragma_foreign_code_impl,
list(maybe(pair(string, mode))), prog_context, simple_call_id,
module_info, io__state, io__state).
-:- mode warn_singletons_in_pragma_c_code(in, in, in, in, in, di, uo) is det.
+:- mode warn_singletons_in_pragma_foreign_code(in, in, in, in, in,
+ di, uo) is det.
-warn_singletons_in_pragma_c_code(PragmaImpl, ArgInfo,
+warn_singletons_in_pragma_foreign_code(PragmaImpl, ArgInfo,
Context, PredOrFuncCallId, ModuleInfo) -->
(
{ PragmaImpl = ordinary(C_Code, _) },
@@ -4848,18 +4688,18 @@
io__stderr_stream(StdErr1),
io__set_output_stream(StdErr1, OldStream1),
prog_out__write_context(Context),
- io__write_string("In `:- pragma c_code' for "),
+ io__write_string("In `:- pragma foreign_code' for "),
hlds_out__write_simple_call_id(PredOrFuncCallId),
io__write_string(":\n"),
prog_out__write_context(Context),
( { UnmentionedVars = [_] } ->
io__write_string(" warning: variable `"),
write_string_list(UnmentionedVars),
- io__write_string("' does not occur in the C code.\n")
+ io__write_string("' does not occur in the foreign code.\n")
;
io__write_string(" warning: variables `"),
write_string_list(UnmentionedVars),
- io__write_string("' do not occur in the C code.\n")
+ io__write_string("' do not occur in the foreign code.\n")
),
io__set_output_stream(OldStream1, _)
)
@@ -4881,7 +4721,7 @@
io__stderr_stream(StdErr2),
io__set_output_stream(StdErr2, OldStream2),
prog_out__write_context(Context),
- io__write_string("In `:- pragma c_code' for "),
+ io__write_string("In `:- pragma foreign_code' for "),
hlds_out__write_simple_call_id(PredOrFuncCallId),
io__write_string(":\n"),
prog_out__write_context(Context),
@@ -4909,7 +4749,7 @@
io__stderr_stream(StdErr3),
io__set_output_stream(StdErr3, OldStream3),
prog_out__write_context(Context),
- io__write_string("In `:- pragma c_code' for "),
+ io__write_string("In `:- pragma foreign_code' for "),
hlds_out__write_simple_call_id(PredOrFuncCallId),
io__write_string(":\n"),
prog_out__write_context(Context),
@@ -4937,7 +4777,7 @@
io__stderr_stream(StdErr4),
io__set_output_stream(StdErr4, OldStream4),
prog_out__write_context(Context),
- io__write_string("In `:- pragma c_code' for "),
+ io__write_string("In `:- pragma foreign_code' for "),
hlds_out__write_simple_call_id(PredOrFuncCallId),
io__write_string(":\n"),
prog_out__write_context(Context),
@@ -5208,23 +5048,26 @@
%-----------------------------------------------------------------------------
-% Add the pragma_c_code goal to the clauses_info for this procedure.
+% Add the pragma_foreign_code goal to the clauses_info for this procedure.
% To do so, we must also insert unifications between the variables in the
-% pragma c_code declaration and the head vars of the pred. Also return the
-% hlds_goal.
+% pragma foreign_code declaration and the head vars of the pred. Also
+% return the hlds_goal.
-:- pred clauses_info_add_pragma_c_code(clauses_info, purity,
- pragma_foreign_code_attributes, pred_id, proc_id, prog_varset,
- list(pragma_var), list(type), pragma_foreign_code_impl, prog_context,
- pred_or_func, sym_name, arity, clauses_info, module_info,
- module_info, qual_info, qual_info, io__state, io__state) is det.
-:- mode clauses_info_add_pragma_c_code(in, in, in, in, in, in, in, in, in, in,
- in, in, in, out, in, out, in, out, di, uo) is det.
+:- pred clauses_info_add_pragma_foreign_code(
+ clauses_info, purity, pragma_foreign_code_attributes, pred_id,
+ proc_id, prog_varset, list(pragma_var), list(type),
+ pragma_foreign_code_impl, prog_context, pred_or_func, sym_name,
+ arity, clauses_info, module_info, module_info, qual_info,
+ qual_info, io__state, io__state) is det.
+:- mode clauses_info_add_pragma_foreign_code(in, in, in, in, in, in, in,
+ in, in, in, in, in, in, out, in, out, in, out, di, uo) is det.
-clauses_info_add_pragma_c_code(ClausesInfo0, Purity, Attributes, PredId,
- ModeId, PVarSet, PVars, OrigArgTypes, PragmaImpl, Context,
+clauses_info_add_pragma_foreign_code(ClausesInfo0, Purity, Attributes0, PredId,
+ ModeId, PVarSet, PVars, OrigArgTypes, PragmaImpl0, Context,
PredOrFunc, PredName, Arity, ClausesInfo, ModuleInfo0,
ModuleInfo, Info0, Info) -->
+ globals__io_lookup_foreign_language_option(backend_foreign_language,
+ BackendForeignLanguage),
{
ClausesInfo0 = clauses_info(VarSet0, VarTypes, TVarNameMap, VarTypes1,
HeadVars, ClauseList, TI_VarMap, TCI_VarMap),
@@ -5232,6 +5075,16 @@
pragma_get_var_infos(PVars, ArgInfo),
%
+ % If the foreign language is different to the backend
+ % language, we will have to generate an interface to it in the
+ % backend language.
+ %
+ foreign__extrude_pragma_implementation(BackendForeignLanguage,
+ PVars, PredName, PredOrFunc, Context,
+ ModuleInfo0, Attributes0, PragmaImpl0,
+ ModuleInfo1, Attributes, PragmaImpl),
+
+ %
% Check for arguments occurring multiple times.
%
bag__init(ArgBag0),
@@ -5247,10 +5100,11 @@
( { MultipleArgs = [_ | _] } ->
{ ClausesInfo = ClausesInfo0 },
- { ModuleInfo = ModuleInfo0 },
+ { ModuleInfo = ModuleInfo1 },
{ Info = Info0 },
prog_out__write_context(Context),
- io__write_string("In `:- pragma c_code' declaration for "),
+ io__write_string(
+ "In `:- pragma foreign_code' declaration for "),
{ adjust_func_arity(PredOrFunc, OrigArity, Arity) },
hlds_out__write_simple_call_id(
PredOrFunc - PredName/OrigArity),
@@ -5285,8 +5139,7 @@
% Put the purity in the goal_info in case
% this c code is inlined
add_goal_info_purity_feature(GoalInfo1, Purity, GoalInfo),
- % XXX we assume C code
- HldsGoal0 = pragma_foreign_code(c, Attributes, PredId,
+ HldsGoal0 = pragma_foreign_code(Attributes, PredId,
ModeId, Args, ArgInfo, OrigArgTypes, PragmaImpl)
- GoalInfo
},
@@ -5296,7 +5149,7 @@
% implemented as substitutions, and they will be.
insert_arg_unifications(HeadVars, TermArgs, Context,
head(PredOrFunc, Arity), yes, HldsGoal0, VarSet1,
- HldsGoal1, VarSet2, transform_info(ModuleInfo0, Info0),
+ HldsGoal1, VarSet2, transform_info(ModuleInfo1, Info0),
transform_info(ModuleInfo, Info)),
{
map__init(EmptyVarTypes),
@@ -7788,7 +7641,8 @@
{ adjust_func_arity(PredOrFunc, Arity, NumArgs) },
% create pragma c_header_code to declare extern variables
- { module_add_c_header(C_HeaderCode, Context, Module1, Module2)},
+ { module_add_foreign_decl(c, C_HeaderCode, Context,
+ Module1, Module2) },
io__get_exit_status(ExitStatus),
(
@@ -7864,10 +7718,10 @@
ProcInfo, ArgTypes, Module0, C_ProcCode, C_ExtraCode),
% XXX this should be modified to use nondet pragma c_code.
- { default_attributes(Attrs0) },
+ { default_attributes(c, Attrs0) },
{ set_may_call_mercury(Attrs0, will_not_call_mercury, Attrs1) },
{ set_thread_safe(Attrs1, thread_safe, Attrs) },
- module_add_pragma_c_code(Attrs, SymName, PredOrFunc,
+ module_add_pragma_foreign_code(Attrs, SymName, PredOrFunc,
PragmaVars, VarSet, ordinary(C_ProcCode, no),
Status, Context, Module0, Module1, Info0, Info),
{
@@ -7875,7 +7729,8 @@
->
Module2 = Module1
;
- module_add_c_body_code(C_ExtraCode, Context, Module1, Module2)
+ module_add_foreign_body_code(c, C_ExtraCode, Context,
+ Module1, Module2)
},
%
% The C code for fact tables includes C labels;
Index: compiler/mark_static_terms.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mark_static_terms.m,v
retrieving revision 1.4
diff -u -r1.4 mark_static_terms.m
--- compiler/mark_static_terms.m 2000/10/22 13:57:36 1.4
+++ compiler/mark_static_terms.m 2000/10/30 12:41:09
@@ -103,8 +103,8 @@
unification_mark_static_terms(Unification0, Unification,
SI0, SI).
-goal_expr_mark_static_terms(pragma_foreign_code(A,B,C,D,E,F,G,H),
- pragma_foreign_code(A,B,C,D,E,F,G,H), SI, SI).
+goal_expr_mark_static_terms(pragma_foreign_code(A,B,C,D,E,F,G),
+ pragma_foreign_code(A,B,C,D,E,F,G), SI, SI).
goal_expr_mark_static_terms(bi_implication(_, _), _, _, _) :-
% these should have been expanded out by now
Continued in next posting.
--
Tyson Dowd #
# Surreal humour isn't everyone's cup of fur.
trd at cs.mu.oz.au #
http://www.cs.mu.oz.au/~trd #
--------------------------------------------------------------------------
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