[m-rev.] for review: support foreign code in Erlang backend
Peter Wang
wangp at students.csse.unimelb.edu.au
Fri May 18 12:57:03 AEST 2007
Estimated hours taken: 8
Branches: main
Add support for Erlang foreign_code, foreign_procs (det and semidet) and
foreign_exports.
compiler/elds.m:
Extend the ELDS to hold foreign code bodies and foreign_export function
definitions.
Allow pieces of foreign code to be embedded verbatim in ELDS expressions.
Add fixed name variables to the ELDS. These are necessary to
communicate with foreign code which expects variables with fixed names.
Move `elds_clause_arity' here from elds_to_erlang.m.
compiler/erl_call_gen.m:
Generate code for calls to foreign code.
Make erl_gen_simple_expr work for unary operators that are supported.
compiler/erl_code_gen.m:
Get Erlang foreign code bodies from the HLDS and hold them in the ELDS.
Generate code for calls to foreign code.
Generate forwarding functions for foreign_exported procedures.
compiler/elds_to_erlang.m:
Write out foreign code bodies and foreign export functions.
Conform to ELDS changes.
compiler/erl_code_util.m:
Conform to ELDS changes.
compiler/add_pragma.m:
Update a comment.
compiler/erl_unify_gen.m:
Remove an unnecessary import_module.
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.64
diff -u -r1.64 add_pragma.m
--- compiler/add_pragma.m 17 May 2007 03:52:38 -0000 1.64
+++ compiler/add_pragma.m 18 May 2007 02:39:02 -0000
@@ -401,12 +401,11 @@
;
% Emit a warning about using pragma foreign_export with
% a foreign language that is not supported.
- % XXX That's currently all of them except C and IL.
+ % XXX That's currently all of them except C, IL and Erlang.
(
( Lang = lang_java
; Lang = lang_csharp
; Lang = lang_managed_cplusplus
- ; Lang = lang_erlang
),
Pieces = [words("Warning:"),
fixed("`:- pragma foreign_export' declarations"),
@@ -419,6 +418,7 @@
;
( Lang = lang_c
; Lang = lang_il
+ ; Lang = lang_erlang
)
),
Index: compiler/elds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/elds.m,v
retrieving revision 1.2
diff -u -r1.2 elds.m
--- compiler/elds.m 17 May 2007 03:28:11 -0000 1.2
+++ compiler/elds.m 18 May 2007 02:39:02 -0000
@@ -26,6 +26,7 @@
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_foreign.
:- import_module char.
:- import_module list.
@@ -39,10 +40,16 @@
:- type elds
---> elds(
% The original Mercury module name.
- elds_name :: module_name,
+ elds_name :: module_name,
+
+ % Code defined in Erlang.
+ elds_foreign_bodies :: list(foreign_body_code),
% Definitions of functions in the module.
- elds_funcs :: list(elds_defn)
+ elds_funcs :: list(elds_defn),
+
+ % Definitions of foreign exported functions.
+ elds_fe_funcs :: list(elds_foreign_export_defn)
).
% Function definition.
@@ -54,6 +61,15 @@
defn_clause :: elds_clause
).
+ % Foreign exported function definition.
+ %
+:- type elds_foreign_export_defn
+ ---> elds_foreign_export_defn(
+ fe_defn_name :: string,
+ fe_defn_varset :: prog_varset,
+ fe_defn_clause :: elds_clause
+ ).
+
:- type elds_clause
---> elds_clause(
clause_pattern :: list(elds_term),
@@ -123,7 +139,10 @@
% throw(Expr)
%
- ; elds_throw(elds_expr).
+ ; elds_throw(elds_expr)
+
+ % A piece of code to be embedded directly in the generated code.
+ ; elds_foreign_code(string).
:- type elds_term
---> elds_char(char)
@@ -140,8 +159,18 @@
% generator.
; elds_tuple(list(elds_expr))
+
; elds_var(prog_var)
- ; elds_anon_var.
+
+ ; elds_anon_var
+ % elds_anon_var is a convenience for cases where we need a dummy
+ % variable to fill out a pattern.
+
+ ; elds_fixed_name_var(string).
+ % elds_fixed_name_var is used for communicating values to and from
+ % code written in a foreign language. In this case we have no
+ % choice but to use the variable names expected by the foreign code
+ % snippet.
% XXX we should use insts (or some other method) to restrict expressions in
% tuples to be terms, if the tuple is going to be used in a pattern.
@@ -204,9 +233,13 @@
:- func term_from_var(prog_var) = elds_term.
:- func terms_from_vars(prog_vars) = list(elds_term).
+
:- func expr_from_var(prog_var) = elds_expr.
:- func exprs_from_vars(prog_vars) = list(elds_expr).
+:- func terms_from_fixed_vars(list(string)) = list(elds_term).
+:- func exprs_from_fixed_vars(list(string)) = list(elds_expr).
+
% Convert an expression to a term, aborting on failure.
%
:- func expr_to_term(elds_expr) = elds_term.
@@ -237,6 +270,8 @@
%
:- func det_expr(maybe(elds_expr)) = elds_expr.
+:- func elds_clause_arity(elds_clause) = arity.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -260,6 +295,11 @@
expr_from_var(Var) = elds_term(elds_var(Var)).
exprs_from_vars(Vars) = list.map(expr_from_var, Vars).
+terms_from_fixed_vars(Names) =
+ list.map(func(X) = elds_fixed_name_var(X), Names).
+exprs_from_fixed_vars(Names) =
+ list.map(func(X) = elds_term(elds_fixed_name_var(X)), Names).
+
expr_to_term(Expr) = Term :-
( Expr = elds_term(Term0) ->
Term = Term0
@@ -295,6 +335,8 @@
det_expr(no) = _ :-
unexpected(this_file, "det_expr: no expression").
+elds_clause_arity(elds_clause(Args, _Expr)) = list.length(Args).
+
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/elds_to_erlang.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/elds_to_erlang.m,v
retrieving revision 1.2
diff -u -r1.2 elds_to_erlang.m
--- compiler/elds_to_erlang.m 17 May 2007 03:28:12 -0000 1.2
+++ compiler/elds_to_erlang.m 18 May 2007 02:39:02 -0000
@@ -50,6 +50,7 @@
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
@@ -67,7 +68,7 @@
%-----------------------------------------------------------------------------%
output_elds(ModuleInfo, ELDS, !IO) :-
- ELDS = elds(ModuleName, _),
+ ELDS = elds(ModuleName, _, _, _),
%
% The Erlang interactive shell doesn't like "." in filenames so we use "__"
% instead.
@@ -80,7 +81,9 @@
:- pred output_erl_file(module_info::in, elds::in, string::in,
io::di, io::uo) is det.
-output_erl_file(ModuleInfo, elds(ModuleName, Defns), SourceFileName, !IO) :-
+output_erl_file(ModuleInfo, ELDS, SourceFileName, !IO) :-
+ ELDS = elds(ModuleName, ForeignBodies, ProcDefns, ForeignExportDefns),
+
% Output intro.
library.version(Version),
io.write_strings([
@@ -99,21 +102,28 @@
io.write_string(").\n", !IO),
io.write_string("-export([", !IO),
- output_exports(ModuleInfo, Defns, no, !IO),
+ list.foldl2(output_export_ann(ModuleInfo), ProcDefns, no, NeedComma, !IO),
+ list.foldl2(output_foreign_export_ann, ForeignExportDefns, NeedComma, _,
+ !IO),
io.write_string("]).\n", !IO),
% Useful for debugging.
io.write_string("% -compile(export_all).\n", !IO),
- list.foldl(output_defn(ModuleInfo), Defns, !IO).
+ % Output foreign code written in Erlang.
+ list.foldl(output_foreign_body_code, ForeignBodies, !IO),
+
+ % Output function definitions.
+ list.foldl(output_defn(ModuleInfo), ProcDefns, !IO),
+ list.foldl(output_foreign_export_defn(ModuleInfo), ForeignExportDefns,
+ !IO).
%-----------------------------------------------------------------------------%
-:- pred output_exports(module_info::in, list(elds_defn)::in, bool::in,
- io::di, io::uo) is det.
+:- pred output_export_ann(module_info::in, elds_defn::in,
+ bool::in, bool::out, io::di, io::uo) is det.
-output_exports(_ModuleInfo, [], _NeedComma, !IO).
-output_exports(ModuleInfo, [Defn | Defns], NeedComma, !IO) :-
+output_export_ann(ModuleInfo, Defn, !NeedComma, !IO) :-
Defn = elds_defn(PredProcId, _, Clause),
PredProcId = proc(PredId, _ProcId),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
@@ -121,25 +131,32 @@
IsExported = status_is_exported(ImportStatus),
(
IsExported = yes,
- (
- NeedComma = yes,
- io.write_char(',', !IO)
- ;
- NeedComma = no
- ),
+ maybe_write_comma(!.NeedComma, !IO),
nl_indent_line(1, !IO),
output_pred_proc_id(ModuleInfo, PredProcId, !IO),
io.write_char('/', !IO),
io.write_int(elds_clause_arity(Clause), !IO),
- output_exports(ModuleInfo, Defns, yes, !IO)
+ !:NeedComma = yes
;
- IsExported = no,
- output_exports(ModuleInfo, Defns, NeedComma, !IO)
+ IsExported = no
).
-:- func elds_clause_arity(elds_clause) = arity.
+:- pred output_foreign_export_ann(elds_foreign_export_defn::in,
+ bool::in, bool::out, io::di, io::uo) is det.
+
+output_foreign_export_ann(ForeignExportDefn, NeedComma, yes, !IO) :-
+ ForeignExportDefn = elds_foreign_export_defn(ExportedName, _, Clause),
+ maybe_write_comma(NeedComma, !IO),
+ nl_indent_line(1, !IO),
+ output_atom(ExportedName, !IO),
+ io.write_char('/', !IO),
+ io.write_int(elds_clause_arity(Clause), !IO).
+
+:- pred output_foreign_body_code(foreign_body_code::in, io::di, io::uo) is det.
-elds_clause_arity(elds_clause(Args, _Expr)) = list.length(Args).
+output_foreign_body_code(foreign_body_code(_Lang, Code, _Context), !IO) :-
+ io.write_string(Code, !IO),
+ io.nl(!IO).
%-----------------------------------------------------------------------------%
@@ -147,6 +164,21 @@
Defn = elds_defn(PredProcId, VarSet, Clause),
io.nl(!IO),
output_pred_proc_id(ModuleInfo, PredProcId, !IO),
+ output_toplevel_clause(ModuleInfo, VarSet, Clause, !IO).
+
+:- pred output_foreign_export_defn(module_info::in,
+ elds_foreign_export_defn::in, io::di, io::uo) is det.
+
+output_foreign_export_defn(ModuleInfo, ForeignExportDefn, !IO) :-
+ ForeignExportDefn = elds_foreign_export_defn(Name, VarSet, Clause),
+ io.nl(!IO),
+ output_atom(Name, !IO),
+ output_toplevel_clause(ModuleInfo, VarSet, Clause, !IO).
+
+:- pred output_toplevel_clause(module_info::in, prog_varset::in,
+ elds_clause::in, io::di, io::uo) is det.
+
+output_toplevel_clause(ModuleInfo, VarSet, Clause, !IO) :-
Indent = 0,
output_clause(ModuleInfo, VarSet, Indent, Clause, !IO),
io.write_string(".\n", !IO).
@@ -284,6 +316,11 @@
io.write_string("throw(", !IO),
output_expr(ModuleInfo, VarSet, Indent, ExprA, !IO),
io.write_string(")", !IO)
+ ;
+ Expr = elds_foreign_code(Code),
+ nl(!IO),
+ io.write_string(Code, !IO),
+ nl_indent_line(Indent, !IO)
).
:- pred output_case(module_info::in, prog_varset::in, indent::in,
@@ -358,6 +395,9 @@
;
Term = elds_anon_var,
io.write_string("_ ", !IO)
+ ;
+ Term = elds_fixed_name_var(Name),
+ output_var_string(Name, !IO)
).
:- pred output_tuple(module_info::in, prog_varset::in, indent::in,
@@ -399,11 +439,14 @@
output_var(VarSet, Var, !IO) :-
varset.lookup_name(VarSet, Var, VarName),
term.var_to_int(Var, VarNumber),
+ output_var_string(VarName ++ "_" ++ string.from_int(VarNumber), !IO).
+
+:- pred output_var_string(string::in, io::di, io::uo) is det.
+
+output_var_string(String, !IO) :-
% XXX this assumes all Mercury variable names are a subset of Erlang
% variable names
- io.write_string(VarName, !IO),
- io.write_char('_', !IO),
- io.write_int(VarNumber, !IO),
+ io.write_string(String, !IO),
space(!IO).
:- pred output_pred_proc_id(module_info::in, pred_proc_id::in,
@@ -724,6 +767,12 @@
space(!IO) :-
io.write_char(' ', !IO).
+:- pred maybe_write_comma(bool::in, io::di, io::uo) is det.
+
+maybe_write_comma(no, !IO).
+maybe_write_comma(yes, !IO) :-
+ io.write_char(',', !IO).
+
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/erl_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_call_gen.m,v
retrieving revision 1.2
diff -u -r1.2 erl_call_gen.m
--- compiler/erl_call_gen.m 17 May 2007 03:28:12 -0000 1.2
+++ compiler/erl_call_gen.m 18 May 2007 02:39:02 -0000
@@ -60,6 +60,13 @@
:- pred erl_gen_cast(prog_context::in, prog_vars::in, maybe(elds_expr)::in,
elds_expr::out, erl_gen_info::in, erl_gen_info::out) is det.
+ % Generate ELDS code for a call to foreign code.
+ %
+:- pred erl_gen_foreign_code_call(list(foreign_arg)::in,
+ maybe(trace_expr(trace_runtime))::in, pragma_foreign_code_impl::in,
+ code_model::in, prog_context::in, maybe(elds_expr)::in,
+ elds_expr::out, erl_gen_info::in, erl_gen_info::out) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -70,7 +77,7 @@
:- import_module hlds.hlds_module.
:- import_module libs.compiler_util.
-:- import_module term.
+:- import_module pair.
%-----------------------------------------------------------------------------%
%
@@ -304,15 +311,20 @@
erl_gen_simple_expr(leaf(Var)) = elds.expr_from_var(Var).
erl_gen_simple_expr(int_const(Int)) = elds_term(elds_int(Int)).
erl_gen_simple_expr(float_const(Float)) = elds_term(elds_float(Float)).
-erl_gen_simple_expr(unary(_Op, _Expr)) = _ :-
- sorry(this_file, "erl_gen_simple_expr: unary op").
+erl_gen_simple_expr(unary(StdOp, Expr0)) = Expr :-
+ ( std_unop_to_elds(StdOp, Op) ->
+ SimpleExpr = erl_gen_simple_expr(Expr0),
+ Expr = elds_unop(Op, SimpleExpr)
+ ;
+ sorry(this_file, "unary builtin not supported on erlang target")
+ ).
erl_gen_simple_expr(binary(StdOp, Expr1, Expr2)) = Expr :-
( std_binop_to_elds(StdOp, Op) ->
SimpleExpr1 = erl_gen_simple_expr(Expr1),
SimpleExpr2 = erl_gen_simple_expr(Expr2),
Expr = elds_binop(Op, SimpleExpr1, SimpleExpr2)
;
- sorry(this_file, "builtin not supported on erlang target")
+ sorry(this_file, "binary builtin not supported on erlang target")
).
:- pred std_unop_to_elds(unary_op::in, elds_unop::out) is semidet.
@@ -368,6 +380,149 @@
std_binop_to_elds(float_ge, elds.(>=)).
%-----------------------------------------------------------------------------%
+%
+% Code for foreign code calls
+%
+
+% Currently dummy arguments do not exist at all. The writer of the foreign
+% proc must not reference dummy input variables and should not bind dummy
+% output variables (it causes unused variable warnings from the Erlang
+% compiler). To avoid warnings from the Mercury compiler about arguments not
+% appearing in the foreign proc, they must be named with an underscore.
+%
+% Materialising dummy input variables would not be a good idea unless
+% unused variable warnings were switched off in the Erlang compiler.
+
+erl_gen_foreign_code_call(ForeignArgs, MaybeTraceRuntimeCond,
+ PragmaImpl, CodeModel, _OuterContext, MaybeSuccessExpr, Statement,
+ !Info) :-
+ (
+ MaybeTraceRuntimeCond = yes(_),
+ sorry(this_file, "trace runtime conditions in Erlang backend")
+ ;
+ MaybeTraceRuntimeCond = no
+ ),
+ (
+ PragmaImpl = fc_impl_ordinary(ForeignCode, _Context),
+ %
+ % In the following, F<n> are input variables to the foreign code (with
+ % fixed names), and G<n> are output variables from the foreign code
+ % (also with fixed names). The variables V<n> are input variables and
+ % have arbitrary names. We introduce variables with fixed names using
+ % a lambda function rather than direct assignments in case a single
+ % procedure makes calls to two pieces of foreign code which use the
+ % same fixed names (this can happen due to inlining).
+ %
+ % We generate code for calls to model_det foreign code like this:
+ %
+ % (fun(F1, F2, ...) ->
+ % <foreign code>,
+ % {G1, G2, ...}
+ % )(V1, V2, ...).
+ %
+ % We generate code for calls to model_semi foreign code like this:
+ %
+ % (fun(F1, F2, ...) ->
+ % <foreign code>,
+ % case SUCCESS_INDICATOR of
+ % true ->
+ % {G1, G2, ...};
+ % false ->
+ % fail
+ % end
+ % )(V1, V2, ...)
+ %
+ % where `SUCCESS_INDICATOR' is a variable that should be set in the
+ % foreign code snippet to `true' or `false'.
+ %
+
+ % Separate the foreign call arguments into inputs and outputs.
+ erl_gen_info_get_module_info(!.Info, ModuleInfo),
+ list.map2(foreign_arg_type_mode, ForeignArgs, ArgTypes, ArgModes),
+ erl_gen_arg_list(ModuleInfo, ForeignArgs, ArgTypes, ArgModes,
+ InputForeignArgs, OutputForeignArgs),
+
+ % Get the variables involved in the call and their fixed names.
+ InputVars = list.map(foreign_arg_var, InputForeignArgs),
+ OutputVars = list.map(foreign_arg_var, OutputForeignArgs),
+ InputVarsNames = list.map(foreign_arg_name, InputForeignArgs),
+ OutputVarsNames = list.map(foreign_arg_name, OutputForeignArgs),
+
+ ForeignCodeExpr = elds_foreign_code(ForeignCode),
+ OutputTuple = elds_term(elds_tuple(
+ exprs_from_fixed_vars(OutputVarsNames))),
+
+ % Create the inner lambda function.
+ (
+ CodeModel = model_det,
+ %
+ % <ForeignCodeExpr>,
+ % {Outputs, ...}
+ %
+ InnerFunStatement = join_exprs(ForeignCodeExpr, OutputTuple)
+ ;
+ CodeModel = model_semi,
+ %
+ % <ForeignCodeExpr>,
+ % case SUCCESS_INDICATOR of
+ % true -> {Outputs, ...};
+ % false -> fail
+ % end
+ %
+ InnerFunStatement = join_exprs(ForeignCodeExpr, MaybePlaceOutputs),
+ MaybePlaceOutputs = elds_case_expr(SuccessInd, [OnTrue, OnFalse]),
+ SuccessInd = elds_term(elds_fixed_name_var("SUCCESS_INDICATOR")),
+ OnTrue = elds_case(elds_true, OutputTuple),
+ OnFalse = elds_case(elds_false, elds_term(elds_fail))
+ ;
+ CodeModel = model_non,
+ sorry(this_file, "model_non foreign_procs in Erlang backend")
+ ),
+ InnerFun = elds_fun(elds_clause(terms_from_fixed_vars(InputVarsNames),
+ InnerFunStatement)),
+
+ % Call the inner function with the input variables.
+ CallInner = elds_call_ho(InnerFun, exprs_from_vars(InputVars)),
+ (
+ CodeModel = model_det,
+ make_det_call(CallInner, OutputVars, MaybeSuccessExpr, Statement)
+ ;
+ CodeModel = model_semi,
+ SuccessExpr = det_expr(MaybeSuccessExpr),
+ make_semidet_call(CallInner, OutputVars, SuccessExpr, Statement)
+ )
+ ;
+ PragmaImpl = fc_impl_model_non(_, _, _, _, _, _, _, _, _),
+ sorry(this_file, "erl_gen_goal_expr: fc_impl_model_non")
+ ;
+ PragmaImpl = fc_impl_import(_, _, _, _),
+ sorry(this_file, "erl_gen_goal_expr: fc_impl_import")
+ ).
+
+:- pred foreign_arg_type_mode(foreign_arg::in, mer_type::out, mer_mode::out)
+ is det.
+
+foreign_arg_type_mode(foreign_arg(_, MaybeNameMode, Type, _), Type, Mode) :-
+ (
+ MaybeNameMode = yes(_Name - Mode)
+ ;
+ MaybeNameMode = no,
+ % This argument is unused.
+ Mode = (free -> free)
+ ).
+
+:- func foreign_arg_name(foreign_arg) = string.
+
+foreign_arg_name(foreign_arg(_, MaybeNameMode, _, _)) = Name :-
+ (
+ MaybeNameMode = yes(Name - _)
+ ;
+ MaybeNameMode = no,
+ % This argument is unused.
+ Name = "_"
+ ).
+
+%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/erl_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_gen.m,v
retrieving revision 1.2
diff -u -r1.2 erl_code_gen.m
--- compiler/erl_code_gen.m 17 May 2007 03:28:12 -0000 1.2
+++ compiler/erl_code_gen.m 18 May 2007 02:39:02 -0000
@@ -25,7 +25,8 @@
% - RTTI
% - type classes
% - many scope types not yet supported
-% - foreign code
+% - nondet foreign code
+% - trace runtime conditions
%
%-----------------------------------------------------------------------------%
@@ -49,6 +50,7 @@
:- implementation.
+:- import_module backend_libs.foreign.
:- import_module erl_backend.erl_call_gen.
:- import_module erl_backend.erl_code_util.
:- import_module erl_backend.erl_unify_gen.
@@ -60,14 +62,15 @@
:- import_module hlds.passes_aux.
:- import_module hlds.pred_table.
:- import_module libs.compiler_util.
+:- import_module libs.globals.
:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_foreign.
:- import_module bool.
:- import_module int.
:- import_module list.
:- import_module map.
:- import_module maybe.
-:- import_module require.
:- import_module set.
:- import_module varset.
@@ -76,8 +79,32 @@
erl_code_gen(ModuleInfo, ELDS, !IO) :-
module_info_get_name(ModuleInfo, ModuleName),
- erl_gen_preds(ModuleInfo, Defns, !IO),
- ELDS = elds(ModuleName, Defns).
+ erl_gen_preds(ModuleInfo, ProcDefns, !IO),
+ filter_erlang_foreigns(ModuleInfo, ForeignBodies, PragmaExports, !IO),
+ erl_gen_foreign_exports(ProcDefns, PragmaExports, ForeignExportDefns),
+ ELDS = elds(ModuleName, ForeignBodies, ProcDefns, ForeignExportDefns).
+
+:- pred filter_erlang_foreigns(module_info::in, list(foreign_body_code)::out,
+ list(pragma_exported_proc)::out, io::di, io::uo) is det.
+
+filter_erlang_foreigns(ModuleInfo, ForeignBodies, PragmaExports, !IO) :-
+ globals.io_get_backend_foreign_languages(BackendForeignLanguages, !IO),
+ ( BackendForeignLanguages = [lang_erlang] ->
+ true
+ ;
+ unexpected(this_file,
+ "erl_gen_foreign_code: foreign language other than Erlang")
+ ),
+ module_info_get_foreign_body_code(ModuleInfo, AllForeignBodys),
+ module_info_get_pragma_exported_procs(ModuleInfo, AllPragmaExports),
+ foreign.filter_bodys(lang_erlang, AllForeignBodys, RevForeignBodies,
+ _OtherForeignBodys),
+ foreign.filter_exports(lang_erlang, AllPragmaExports, RevPragmaExports,
+ _OtherForeignExports),
+ ForeignBodies = list.reverse(RevForeignBodies),
+ PragmaExports = list.reverse(RevPragmaExports).
+
+%-----------------------------------------------------------------------------%
:- pred erl_gen_preds(module_info::in, list(elds_defn)::out, io::di, io::uo)
is det.
@@ -399,13 +426,20 @@
erl_gen_goal_expr(scope(ScopeReason, Goal), CodeModel, InstMap, Context,
MaybeSuccessExpr, Statement, !Info) :-
(
- ( ScopeReason = exist_quant(_)
- ; ScopeReason = promise_solutions(_, _)
- ; ScopeReason = promise_purity(_, _)
- ; ScopeReason = barrier(_)
- ; ScopeReason = trace_goal(_, _, _, _, _)
- ),
- sorry(this_file, "exotic scope type in erlang code generator")
+ ScopeReason = exist_quant(_),
+ sorry(this_file, "exist_quant scope in erlang code generator")
+ ;
+ ScopeReason = promise_solutions(_, _),
+ sorry(this_file, "promise_solutions scope in erlang code generator")
+ ;
+ ScopeReason = promise_purity(_, _),
+ sorry(this_file, "promise_purity scope in erlang code generator")
+ ;
+ ScopeReason = barrier(_),
+ sorry(this_file, "barrier scope in erlang code generator")
+ ;
+ ScopeReason = trace_goal(_, _, _, _, _),
+ sorry(this_file, "trace_goal scope in erlang code generator")
;
ScopeReason = commit(_),
erl_gen_commit(Goal, CodeModel, InstMap, Context,
@@ -481,10 +515,11 @@
Statement, !Info).
erl_gen_goal_expr(
- call_foreign_proc(_Attributes, _PredId, _ProcId, _Args, _ExtraArgs,
- _MaybeTraceRuntimeCond, _PragmaImpl), _CodeModel, _InstMap,
- _OuterContext, _MaybeSuccessExpr, _Statement, !_Info) :-
- sorry(this_file, "call_foreign_proc in erlang backend").
+ call_foreign_proc(_Attributes, _PredId, _ProcId, Args, _ExtraArgs,
+ MaybeTraceRuntimeCond, PragmaImpl), CodeModel, _InstMap,
+ OuterContext, MaybeSuccessExpr, Statement, !Info) :-
+ erl_gen_foreign_code_call(Args, MaybeTraceRuntimeCond, PragmaImpl,
+ CodeModel, OuterContext, MaybeSuccessExpr, Statement, !Info).
erl_gen_goal_expr(shorthand(_), _, _, _, _, _, !Info) :-
% these should have been expanded out by now
@@ -708,7 +743,8 @@
% model_non cond:
% <(Cond -> Then ; Else)>
% ===>
- % let PutAndThen = ``put(Ref, true), <Then>''
+ %
+ % let PutAndThen = ``put(Ref, true), <Then && SUCCEED()>''
%
% Ref = make_ref(), /* defaults to `undefined' */
% <Cond && PutAndThen>
@@ -718,6 +754,9 @@
% end,
% erase(Ref)
%
+ % XXX need to ensure the erase(Ref) is done even if an exception is
+ % thrown (e.g. by commit) by wrapping this with `try'
+ %
erl_gen_info_new_named_var("Ref", Ref, !Info),
RefExpr = expr_from_var(Ref),
@@ -1047,6 +1086,51 @@
).
%-----------------------------------------------------------------------------%
+%
+% Code for generating foreign exported procedures
+%
+
+:- pred erl_gen_foreign_exports(list(elds_defn)::in,
+ list(pragma_exported_proc)::in, list(elds_foreign_export_defn)::out)
+ is det.
+
+erl_gen_foreign_exports(ProcDefns, PragmaExports, ForeignExportDefns) :-
+ list.map(erl_gen_foreign_export_defn(ProcDefns), PragmaExports,
+ ForeignExportDefns).
+
+:- pred erl_gen_foreign_export_defn(list(elds_defn)::in,
+ pragma_exported_proc::in, elds_foreign_export_defn::out) is det.
+
+erl_gen_foreign_export_defn(ProcDefns, PragmaExport, ForeignExportDefn) :-
+ PragmaExport = pragma_exported_proc(_Lang, PredId, ProcId, Name, _Context),
+ PredProcId = proc(PredId, ProcId),
+ (
+ search_elds_defn(ProcDefns, PredProcId, TargetProc)
+ ->
+ TargetProc = elds_defn(_TargetPPId, _TargetVarSet, TargetClause),
+ Arity = elds_clause_arity(TargetClause),
+
+ % ``Name(Vars, ...) -> PredProcId(Vars, ...)''
+ varset.new_vars(varset.init, Arity, Vars, VarSet),
+ Clause = elds_clause(terms_from_vars(Vars),
+ elds_call(PredProcId, exprs_from_vars(Vars))),
+ ForeignExportDefn = elds_foreign_export_defn(Name, VarSet, Clause)
+ ;
+ unexpected(this_file,
+ "missing definition of foreign exported procedure")
+ ).
+
+:- pred search_elds_defn(list(elds_defn)::in, pred_proc_id::in,
+ elds_defn::out) is semidet.
+
+search_elds_defn([Defn0 | Defns], PredProcId, Defn) :-
+ ( Defn0 = elds_defn(PredProcId, _, _) ->
+ Defn = Defn0
+ ;
+ search_elds_defn(Defns, PredProcId, Defn)
+ ).
+
+%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/erl_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_util.m,v
retrieving revision 1.2
diff -u -r1.2 erl_code_util.m
--- compiler/erl_code_util.m 17 May 2007 03:28:12 -0000 1.2
+++ compiler/erl_code_util.m 18 May 2007 02:39:02 -0000
@@ -369,6 +369,9 @@
Expr0 = elds_throw(ExprA0),
erl_rename_vars_in_expr(Subn, ExprA0, ExprA),
Expr = elds_throw(ExprA)
+ ;
+ Expr0 = elds_foreign_code(_),
+ Expr = Expr0
).
:- pred erl_rename_vars_in_terms(prog_var_renaming::in,
@@ -389,6 +392,7 @@
; Term0 = elds_atom_raw(_)
; Term0 = elds_atom(_)
; Term0 = elds_anon_var
+ ; Term0 = elds_fixed_name_var(_)
),
Term = Term0
;
@@ -481,6 +485,10 @@
;
Expr = elds_throw(ExprA),
Size = 1 + erl_expr_size(ExprA)
+ ;
+ Expr = elds_foreign_code(_),
+ % Arbitrary number.
+ Size = 10000
).
:- func erl_terms_size(list(elds_term)) = int.
@@ -499,6 +507,7 @@
; Term = elds_atom(_)
; Term = elds_var(_)
; Term = elds_anon_var
+ ; Term = elds_fixed_name_var(_)
),
Size = 1
;
Index: compiler/erl_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_unify_gen.m,v
retrieving revision 1.2
diff -u -r1.2 erl_unify_gen.m
--- compiler/erl_unify_gen.m 17 May 2007 03:28:12 -0000 1.2
+++ compiler/erl_unify_gen.m 18 May 2007 02:39:02 -0000
@@ -59,7 +59,6 @@
:- implementation.
:- import_module check_hlds.type_util.
-:- import_module erl_backend.erl_code_gen.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module libs.compiler_util.
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list