mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-20 16:31:04 +00:00
f9fe8dcf61
Estimated hours taken: 8
Branches: main
Improve the error messages generated for determinism errors involving committed
choice contexts. Previously, we printed a message to the effect that e.g.
a cc pred is called in context that requires all solutions, but we didn't say
*why* the context requires all solutions. We now keep track of all the goals
to the right that could fail, since it is these goals that may reject the first
solution of a committed choice goal.
The motivation for this diff was the fact that I found that locating the
failing goal can be very difficult if the conjunction to the right is
a couple of hundred lines long. This would have been a nontrivial problem,
since (a) unifications involving values of user-defined types are committed
choice goals, and (b) we can expect uses of user-defined types to increase.
compiler/det_analysis.m:
Keep track of goals to the right of the current goal that could fail,
and include them in the error representation if required.
compiler/det_report.m:
Include the list of failing goals to the right in the representations
of determinism errors involving committed committed choice goals.
Convert the last part of this module that wasn't using error_util
to use error_util. Make most parts of this module just construct
error message specifications; print those specifications (using
error_util) in only a few places.
compiler/hlds_out.m:
Add a function for use by the new code in det_report.m.
compiler/error_util.m:
Add a function for use by the new code in det_report.m.
compiler/error_util.m:
compiler/compiler_util.m:
Error_util is still changing reasonably often, and yet it is
included in lots of modules, most of which need only a few simple
non-parse-tree-related predicates from it (e.g. unexpected).
Move those predicates to a new module, compiler_util.m. This also
eliminates some undesirable dependencies from libs to parse_tree.
compiler/libs.m:
Include compiler_util.m.
compiler/notes/compiler_design.html:
Document compiler_util.m, and fix the documentation of some other
modules.
compiler/*.m:
Import compiler_util instead of or in addition to error_util.
To make this easier, consistently use . instead of __ for module
qualifying module names.
tests/invalid/det_errors_cc.{m,err_exp}:
Add this new test case to test the error messages for cc contexts.
tests/invalid/det_errors_deet.{m,err_exp}:
Add this new test case to test the error messages for unifications
inside function symbols.
tests/invalid/Mmakefile:
Add the new test cases.
tests/invalid/det_errors.err_exp:
tests/invalid/magicbox.err_exp:
Change the expected output to conform to the change in det_report.m,
which is now more consistent.
744 lines
27 KiB
Mathematica
744 lines
27 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1996-2005 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 to produce the functions which are
|
|
% 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.
|
|
|
|
% Main authors: dgj.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module backend_libs__export.
|
|
|
|
:- interface.
|
|
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_foreign.
|
|
|
|
:- import_module io.
|
|
|
|
% From the module_info, get a list of foreign_export_decls,
|
|
% each of which holds information about the 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 the foreign language.
|
|
%
|
|
:- pred get_foreign_export_decls(module_info::in, foreign_export_decls::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 get_foreign_export_defns(module_info::in, foreign_export_defns::out)
|
|
is det.
|
|
|
|
% Produce an interface file containing declarations for the
|
|
% exported foreign functions (if required in this foreign language).
|
|
%
|
|
:- pred produce_header_file(foreign_export_decls::in, module_name::in,
|
|
io::di, io::uo) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Utilities for generating C code which interfaces with Mercury.
|
|
% The {MLDS,LLDS}->C backends and fact tables use this code.
|
|
|
|
% Generate C code to convert an rval (represented as a string), from
|
|
% a C type to a mercury C type (ie. convert strings and floats to
|
|
% words) and return the resulting C code as a string.
|
|
%
|
|
:- pred convert_type_to_mercury(string::in, mer_type::in, string::out) is det.
|
|
|
|
% Generate C code to convert an rval (represented as a string), from
|
|
% a mercury C type to a C type. (ie. convert words to strings and
|
|
% floats if required) and return the resulting C code as a string.
|
|
%
|
|
:- pred convert_type_from_mercury(string::in, mer_type::in, string::out)
|
|
is det.
|
|
|
|
% Succeeds iff the given C type is known by the compiler to be
|
|
% an integer or pointer type the same size as MR_Word.
|
|
%
|
|
:- pred c_type_is_word_sized_int_or_ptr(string::in) is semidet.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module backend_libs.c_util.
|
|
:- import_module backend_libs.foreign.
|
|
:- import_module backend_libs.name_mangle.
|
|
:- import_module backend_libs.proc_label.
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module hlds.arg_info.
|
|
:- import_module hlds.code_model.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module libs.compiler_util.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module parse_tree.modules.
|
|
:- import_module parse_tree.prog_foreign.
|
|
:- import_module parse_tree.prog_util.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module bool.
|
|
:- import_module int.
|
|
:- import_module library.
|
|
:- import_module list.
|
|
:- import_module map.
|
|
:- import_module require.
|
|
:- import_module std_util.
|
|
:- import_module string.
|
|
:- import_module term.
|
|
:- import_module varset.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
get_foreign_export_decls(HLDS, ForeignExportDecls) :-
|
|
module_info_get_predicate_table(HLDS, PredicateTable),
|
|
predicate_table_get_preds(PredicateTable, Preds),
|
|
|
|
module_info_get_foreign_decl(HLDS, RevForeignDecls),
|
|
ForeignDecls = list__reverse(RevForeignDecls),
|
|
|
|
module_info_get_pragma_exported_procs(HLDS, ExportedProcs),
|
|
module_info_get_globals(HLDS, Globals),
|
|
get_foreign_export_decls_2(Preds, ExportedProcs, Globals, HLDS,
|
|
C_ExportDecls),
|
|
|
|
ForeignExportDecls = foreign_export_decls(ForeignDecls, C_ExportDecls).
|
|
|
|
:- pred get_foreign_export_decls_2(pred_table::in,
|
|
list(pragma_exported_proc)::in, globals::in, module_info::in,
|
|
list(foreign_export_decl)::out) is det.
|
|
|
|
get_foreign_export_decls_2(_Preds, [], _, _, []).
|
|
get_foreign_export_decls_2(Preds, [E | ExportedProcs], Globals,
|
|
ModuleInfo, C_ExportDecls) :-
|
|
E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
|
|
get_export_info(Preds, PredId, ProcId, Globals, ModuleInfo, _HowToDeclare,
|
|
C_RetType, _DeclareReturnVal, _FailureAction, _SuccessAction,
|
|
HeadArgInfoTypes),
|
|
get_argument_declarations(HeadArgInfoTypes, no, ModuleInfo, ArgDecls),
|
|
C_ExportDecl = foreign_export_decl(c, C_RetType, C_Function, ArgDecls),
|
|
get_foreign_export_decls_2(Preds, ExportedProcs, Globals,
|
|
ModuleInfo, C_ExportDecls0),
|
|
C_ExportDecls = [C_ExportDecl | C_ExportDecls0].
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
get_foreign_export_defns(ModuleInfo, ExportedProcsCode) :-
|
|
module_info_get_pragma_exported_procs(ModuleInfo, ExportedProcs),
|
|
module_info_get_predicate_table(ModuleInfo, PredicateTable),
|
|
predicate_table_get_preds(PredicateTable, Preds),
|
|
to_c(Preds, ExportedProcs, ModuleInfo, ExportedProcsCode).
|
|
|
|
% For each exported procedure, produce a C function.
|
|
% The code we generate is in the form
|
|
%
|
|
% MR_declare_entry(<label of called proc>); /* or MR_declare_static */
|
|
%
|
|
% /* Start with a declaration to avoid C compiler warnings. */
|
|
% #if SEMIDET
|
|
% MR_bool
|
|
% #elif FUNCTION
|
|
% MR_Word
|
|
% #else
|
|
% void
|
|
% #endif
|
|
% <function name>(MR_Word Mercury__Argument1,
|
|
% MR_Word *Mercury__Argument2...);
|
|
% /* Word for input, Word* for output */
|
|
%
|
|
% #if SEMIDET
|
|
% MR_bool
|
|
% #elif FUNCTION
|
|
% MR_Word
|
|
% #else
|
|
% void
|
|
% #endif
|
|
% <function name>(MR_Word Mercury__Argument1,
|
|
% MR_Word *Mercury__Argument2...)
|
|
% /* Word for input, Word* for output */
|
|
% {
|
|
% #if MR_NUM_REAL_REGS > 0
|
|
% MR_Word c_regs[MR_NUM_REAL_REGS];
|
|
% #endif
|
|
% #if FUNCTION
|
|
% MR_Word retval;
|
|
% #endif
|
|
% #if MR_THREAD_SAFE
|
|
% MR_bool must_finalize_engine;
|
|
% #endif
|
|
% #if MR_DEEP_PROFILING
|
|
% MR_CallSiteDynamic *saved_call_site_addr = MR_current_callback_site;
|
|
% MR_CallSiteDynamic *saved_csd;
|
|
% #endif
|
|
%
|
|
% /* save the registers that our C caller may be using */
|
|
% MR_save_regs_to_mem(c_regs);
|
|
%
|
|
% /*
|
|
% ** start a new Mercury engine inside this POSIX
|
|
% ** thread, if necessary (the C code may be
|
|
% ** multi-threaded itself).
|
|
% */
|
|
%
|
|
% #if MR_THREAD_SAFE
|
|
% must_finalize_engine = MR_init_thread(MR_use_now);
|
|
% #endif
|
|
%
|
|
% #if MR_DEEP_PROFILING
|
|
% saved_csd = MR_current_call_site_dynamic;
|
|
% MR_setup_callback(MR_ENTRY(<label of called proc>));
|
|
% #endif
|
|
% /*
|
|
% ** restore Mercury's registers that were saved as
|
|
% ** we entered C from Mercury. For single threaded
|
|
% ** programs the process must always start in Mercury
|
|
% ** so that we can MR_init_engine() etc. For
|
|
% ** multi-threaded MR_init_thread (above) takes care
|
|
% ** of making a new engine if required.
|
|
% */
|
|
% MR_restore_registers();
|
|
% <copy input arguments from Mercury__Arguments into registers>
|
|
% /* save the registers which may be clobbered */
|
|
% /* by the C function call MR_call_engine(). */
|
|
% MR_save_transient_registers();
|
|
%
|
|
% (void) MR_call_engine(MR_ENTRY(<label of called proc>),
|
|
% MR_FALSE);
|
|
%
|
|
% /* restore the registers which may have been */
|
|
% /* clobbered by the return from the C function */
|
|
% /* MR_call_engine() */
|
|
% MR_restore_transient_registers();
|
|
% #if MR_DEEP_PROFILING
|
|
% MR_current_call_site_dynamic = saved_csd;
|
|
% MR_current_callback_site = saved_call_site_addr;
|
|
% #endif
|
|
% #if SEMIDET
|
|
% if (!MR_r1) {
|
|
% MR_restore_regs_from_mem(c_regs);
|
|
% return MR_FALSE;
|
|
% }
|
|
% #elif FUNCTION
|
|
% <copy return value register into retval>
|
|
% #endif
|
|
% <copy output args from registers into *Mercury__Arguments>
|
|
% #if MR_THREAD_SAFE
|
|
% if (must_finalize_engine) {
|
|
% MR_finalize_thread_engine();
|
|
% }
|
|
% #endif
|
|
% MR_restore_regs_from_mem(c_regs);
|
|
% #if SEMIDET
|
|
% return MR_TRUE;
|
|
% #elif FUNCTION
|
|
% return retval;
|
|
% #endif
|
|
% }
|
|
:- pred to_c(pred_table::in, list(pragma_exported_proc)::in,
|
|
module_info::in, list(string)::out) is det.
|
|
|
|
to_c(_Preds, [], _ModuleInfo, []).
|
|
to_c(Preds, [E | ExportedProcs], ModuleInfo, ExportedProcsCode) :-
|
|
E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
get_export_info(Preds, PredId, ProcId, Globals, ModuleInfo, DeclareString,
|
|
C_RetType, MaybeDeclareRetval, MaybeFail, MaybeSucceed, ArgInfoTypes),
|
|
get_argument_declarations(ArgInfoTypes, yes, ModuleInfo, ArgDecls),
|
|
|
|
% work out which arguments are input, and which are output,
|
|
% and copy to/from the mercury registers.
|
|
get_input_args(ArgInfoTypes, 0, ModuleInfo, InputArgs),
|
|
copy_output_args(ArgInfoTypes, 0, ModuleInfo, OutputArgs),
|
|
|
|
ProcLabel = make_proc_label(ModuleInfo, PredId, ProcId),
|
|
ProcLabelString = proc_label_to_c_string(ProcLabel, yes),
|
|
|
|
string__append_list([
|
|
"\n",
|
|
DeclareString, "(", ProcLabelString, ");\n",
|
|
"\n",
|
|
C_RetType, "\n",
|
|
C_Function, "(", ArgDecls, ");\n",
|
|
"\n",
|
|
C_RetType, "\n",
|
|
C_Function, "(", ArgDecls, ")\n{\n",
|
|
"#if MR_NUM_REAL_REGS > 0\n",
|
|
"\tMR_Word c_regs[MR_NUM_REAL_REGS];\n",
|
|
"#endif\n",
|
|
"#if MR_THREAD_SAFE\n",
|
|
"\tMR_bool must_finalize_engine;\n",
|
|
"#endif\n",
|
|
"#if MR_DEEP_PROFILING\n",
|
|
"\tMR_CallSiteDynList **saved_cur_callback;\n",
|
|
"\tMR_CallSiteDynamic *saved_cur_csd;\n",
|
|
"#endif\n",
|
|
MaybeDeclareRetval,
|
|
"\n",
|
|
"\tMR_save_regs_to_mem(c_regs);\n",
|
|
"#if MR_THREAD_SAFE\n",
|
|
"\tmust_finalize_engine = MR_init_thread(MR_use_now);\n",
|
|
"#endif\n",
|
|
"#if MR_DEEP_PROFILING\n",
|
|
"\tsaved_cur_callback = MR_current_callback_site;\n",
|
|
"\tsaved_cur_csd = MR_current_call_site_dynamic;\n",
|
|
"\tMR_setup_callback(MR_ENTRY(", ProcLabelString, "));\n",
|
|
"#endif\n",
|
|
"\tMR_restore_registers();\n",
|
|
InputArgs,
|
|
"\tMR_save_transient_registers();\n",
|
|
"\t(void) MR_call_engine(MR_ENTRY(",
|
|
ProcLabelString, "), MR_FALSE);\n",
|
|
"\tMR_restore_transient_registers();\n",
|
|
"#if MR_DEEP_PROFILING\n",
|
|
"\tMR_current_call_site_dynamic = saved_cur_csd;\n",
|
|
"\tMR_current_callback_site = saved_cur_callback;\n",
|
|
"#endif\n",
|
|
MaybeFail,
|
|
OutputArgs,
|
|
"#if MR_THREAD_SAFE\n",
|
|
"\tif (must_finalize_engine) {\n",
|
|
"\t\t MR_finalize_thread_engine();\n",
|
|
"\t}\n",
|
|
"#endif\n",
|
|
"\tMR_restore_regs_from_mem(c_regs);\n",
|
|
MaybeSucceed,
|
|
"}\n\n"],
|
|
Code),
|
|
|
|
to_c(Preds, ExportedProcs, ModuleInfo, TheRest),
|
|
ExportedProcsCode = [Code | TheRest].
|
|
|
|
% get_export_info(Preds, PredId, ProcId, Globals, DeclareString, C_RetType,
|
|
% MaybeDeclareRetval, MaybeFail, MaybeSuccess, ArgInfoTypes):
|
|
%
|
|
% For a given procedure, figure out the information about that procedure
|
|
% that is needed to export it:
|
|
% - how to declare the procedure's entry label,
|
|
% - the C return type, and the C declaration for the variable
|
|
% holding the return value (if any),
|
|
% - the actions on success and failure, and
|
|
% - the argument locations/modes/types.
|
|
|
|
:- pred get_export_info(pred_table::in, pred_id::in, proc_id::in, globals::in,
|
|
module_info::in, string::out, string::out, string::out, string::out,
|
|
string::out, assoc_list(arg_info, mer_type)::out) is det.
|
|
|
|
get_export_info(Preds, PredId, ProcId, Globals, ModuleInfo, HowToDeclareLabel,
|
|
C_RetType, MaybeDeclareRetval, MaybeFail, MaybeSucceed,
|
|
ArgInfoTypes) :-
|
|
map__lookup(Preds, PredId, PredInfo),
|
|
pred_info_import_status(PredInfo, Status),
|
|
(
|
|
(
|
|
procedure_is_exported(ModuleInfo, PredInfo, ProcId)
|
|
;
|
|
status_defined_in_this_module(Status, no)
|
|
;
|
|
% for --split-c-files, we need to treat
|
|
% all procedures as if they were exported
|
|
globals__lookup_bool_option(Globals, split_c_files, yes)
|
|
)
|
|
->
|
|
HowToDeclareLabel = "MR_declare_entry"
|
|
;
|
|
HowToDeclareLabel = "MR_declare_static"
|
|
),
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
pred_info_procedures(PredInfo, ProcTable),
|
|
map__lookup(ProcTable, ProcId, ProcInfo),
|
|
proc_info_maybe_arg_info(ProcInfo, MaybeArgInfos),
|
|
pred_info_arg_types(PredInfo, ArgTypes),
|
|
(
|
|
MaybeArgInfos = yes(ArgInfos0),
|
|
ArgInfos = ArgInfos0
|
|
;
|
|
MaybeArgInfos = no,
|
|
generate_proc_arg_info(ArgTypes, ModuleInfo, ProcInfo, NewProcInfo),
|
|
proc_info_arg_info(NewProcInfo, ArgInfos)
|
|
),
|
|
proc_info_interface_code_model(ProcInfo, CodeModel),
|
|
assoc_list__from_corresponding_lists(ArgInfos, ArgTypes, ArgInfoTypes0),
|
|
|
|
% Figure out what the C return type should be, and build the `return'
|
|
% instructions (if any).
|
|
(
|
|
CodeModel = model_det,
|
|
(
|
|
PredOrFunc = function,
|
|
pred_args_to_func_args(ArgInfoTypes0, ArgInfoTypes1,
|
|
arg_info(RetArgLoc, RetArgMode) - RetType),
|
|
RetArgMode = top_out,
|
|
\+ is_dummy_argument_type(ModuleInfo, RetType)
|
|
->
|
|
Export_RetType = foreign__to_exported_type(ModuleInfo, RetType),
|
|
C_RetType = foreign__to_type_string(c, Export_RetType),
|
|
argloc_to_string(RetArgLoc, RetArgString0),
|
|
convert_type_from_mercury(RetArgString0, RetType, RetArgString),
|
|
MaybeDeclareRetval = "\t" ++ C_RetType ++ " return_value;\n",
|
|
% We need to unbox non-word-sized foreign types
|
|
% before returning them to C code
|
|
( foreign__is_foreign_type(Export_RetType) = yes(_) ->
|
|
SetReturnValue = "\tMR_MAYBE_UNBOX_FOREIGN_TYPE("
|
|
++ C_RetType ++ ", " ++ RetArgString
|
|
++ ", return_value);\n"
|
|
;
|
|
SetReturnValue = "\treturn_value = " ++ RetArgString ++ ";\n"
|
|
),
|
|
MaybeFail = SetReturnValue,
|
|
MaybeSucceed = "\treturn return_value;\n",
|
|
ArgInfoTypes2 = ArgInfoTypes1
|
|
;
|
|
C_RetType = "void",
|
|
MaybeDeclareRetval = "",
|
|
MaybeFail = "",
|
|
MaybeSucceed = "",
|
|
ArgInfoTypes2 = ArgInfoTypes0
|
|
)
|
|
;
|
|
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_RetType = "MR_bool",
|
|
MaybeDeclareRetval = "",
|
|
string__append_list([
|
|
"\tif (!MR_r1) {\n",
|
|
"\t\tMR_restore_regs_from_mem(c_regs);\n",
|
|
"\treturn MR_FALSE;\n",
|
|
"\t}\n"], MaybeFail),
|
|
MaybeSucceed = "\treturn MR_TRUE;\n",
|
|
ArgInfoTypes2 = ArgInfoTypes0
|
|
;
|
|
CodeModel = model_non,
|
|
unexpected(this_file, "Attempt to export model_non procedure.")
|
|
),
|
|
list__filter(include_arg(ModuleInfo), ArgInfoTypes2, ArgInfoTypes).
|
|
|
|
% include_arg(ArgInfoType):
|
|
%
|
|
% Succeeds iff the specified argument should be included in
|
|
% the arguments of the exported C function.
|
|
%
|
|
:- pred include_arg(module_info::in, pair(arg_info, mer_type)::in) is semidet.
|
|
|
|
include_arg(ModuleInfo, arg_info(_Loc, Mode) - Type) :-
|
|
Mode \= top_unused,
|
|
\+ is_dummy_argument_type(ModuleInfo, Type).
|
|
|
|
% get_argument_declarations(Args, NameThem, DeclString):
|
|
%
|
|
% Build a string to declare the argument types (and if NameThem = yes,
|
|
% the argument names) of a C function.
|
|
%
|
|
:- pred get_argument_declarations(assoc_list(arg_info, mer_type)::in, bool::in,
|
|
module_info::in, string::out) is det.
|
|
|
|
get_argument_declarations([], _, _, "void").
|
|
get_argument_declarations([X | Xs], NameThem, ModuleInfo, Result) :-
|
|
get_argument_declarations_2([X | Xs], 0, NameThem, ModuleInfo, Result).
|
|
|
|
:- pred get_argument_declarations_2(assoc_list(arg_info, mer_type)::in,
|
|
int::in, bool::in, module_info::in, string::out) is det.
|
|
|
|
get_argument_declarations_2([], _, _, _, "").
|
|
get_argument_declarations_2([AT | ATs], Num0, NameThem, ModuleInfo, Result) :-
|
|
AT = ArgInfo - Type,
|
|
Num = Num0 + 1,
|
|
get_argument_declaration(ArgInfo, Type, Num, NameThem, ModuleInfo,
|
|
TypeString, ArgName),
|
|
(
|
|
ATs = [],
|
|
Result = TypeString ++ ArgName
|
|
;
|
|
ATs = [_ | _],
|
|
get_argument_declarations_2(ATs, Num, NameThem, ModuleInfo, TheRest),
|
|
Result = TypeString ++ ArgName ++ ", " ++ TheRest
|
|
).
|
|
|
|
:- pred get_argument_declaration(arg_info::in, mer_type::in, int::in, bool::in,
|
|
module_info::in, string::out, string::out) is det.
|
|
|
|
get_argument_declaration(ArgInfo, Type, Num, NameThem, ModuleInfo,
|
|
TypeString, ArgName) :-
|
|
ArgInfo = arg_info(_Loc, Mode),
|
|
(
|
|
NameThem = yes,
|
|
string__int_to_string(Num, NumString),
|
|
string__append(" Mercury__argument", NumString, ArgName)
|
|
;
|
|
NameThem = no,
|
|
ArgName = ""
|
|
),
|
|
TypeString0 = foreign__to_type_string(c, ModuleInfo, Type),
|
|
( Mode = top_out ->
|
|
% output variables are passed as pointers
|
|
TypeString = TypeString0 ++ " *"
|
|
;
|
|
TypeString = TypeString0
|
|
).
|
|
|
|
:- pred get_input_args(assoc_list(arg_info, mer_type)::in, int::in,
|
|
module_info::in, string::out) is det.
|
|
|
|
get_input_args([], _, _, "").
|
|
get_input_args([AT | ATs], Num0, ModuleInfo, Result) :-
|
|
AT = ArgInfo - Type,
|
|
ArgInfo = arg_info(ArgLoc, Mode),
|
|
Num = Num0 + 1,
|
|
(
|
|
Mode = top_in,
|
|
string__int_to_string(Num, NumString),
|
|
ArgName0 = "Mercury__argument" ++ NumString,
|
|
convert_type_to_mercury(ArgName0, Type, ArgName),
|
|
argloc_to_string(ArgLoc, ArgLocString),
|
|
Export_Type = foreign__to_exported_type(ModuleInfo, Type),
|
|
% We need to box non-word-sized foreign types
|
|
% before passing them to Mercury code
|
|
( foreign__is_foreign_type(Export_Type) = yes(_) ->
|
|
C_Type = foreign__to_type_string(c, Export_Type),
|
|
string__append_list(["\tMR_MAYBE_BOX_FOREIGN_TYPE(",
|
|
C_Type, ", ", ArgName, ", ", ArgLocString, ");\n"], InputArg)
|
|
;
|
|
InputArg = "\t" ++ ArgLocString ++ " = " ++ ArgName ++ ";\n"
|
|
)
|
|
;
|
|
Mode = top_out,
|
|
InputArg = ""
|
|
;
|
|
Mode = top_unused,
|
|
InputArg = ""
|
|
),
|
|
get_input_args(ATs, Num, ModuleInfo, TheRest),
|
|
Result = InputArg ++ TheRest.
|
|
|
|
:- pred copy_output_args(assoc_list(arg_info, mer_type)::in, int::in,
|
|
module_info::in, string::out) is det.
|
|
|
|
copy_output_args([], _, _, "").
|
|
copy_output_args([AT | ATs], Num0, ModuleInfo, Result) :-
|
|
AT = ArgInfo - Type,
|
|
ArgInfo = arg_info(ArgLoc, Mode),
|
|
Num = Num0 + 1,
|
|
(
|
|
Mode = top_in,
|
|
OutputArg = ""
|
|
;
|
|
Mode = top_out,
|
|
string__int_to_string(Num, NumString),
|
|
string__append("Mercury__argument", NumString, ArgName),
|
|
argloc_to_string(ArgLoc, ArgLocString0),
|
|
convert_type_from_mercury(ArgLocString0, Type, ArgLocString),
|
|
Export_Type = foreign__to_exported_type(ModuleInfo, Type),
|
|
% We need to unbox non-word-sized foreign types
|
|
% before returning them to C code
|
|
( foreign__is_foreign_type(Export_Type) = yes(_) ->
|
|
C_Type = foreign__to_type_string(c, Export_Type),
|
|
string__append_list(["\tMR_MAYBE_UNBOX_FOREIGN_TYPE(", C_Type,
|
|
", ", ArgLocString, ", * ", ArgName, ");\n"], OutputArg)
|
|
;
|
|
OutputArg = "\t*" ++ ArgName ++ " = " ++ ArgLocString ++ ";\n"
|
|
)
|
|
;
|
|
Mode = top_unused,
|
|
OutputArg = ""
|
|
),
|
|
copy_output_args(ATs, Num, ModuleInfo, TheRest),
|
|
string__append(OutputArg, TheRest, Result).
|
|
|
|
% convert an argument location (currently just a register number)
|
|
% to a string representing a C code fragment that names it.
|
|
:- pred argloc_to_string(arg_loc::in, string::out) is det.
|
|
|
|
argloc_to_string(RegNum, RegName) :-
|
|
% XXX We should handle float registers.
|
|
% XXX This magic number can't be good.
|
|
( RegNum > 32 ->
|
|
RegName = "MR_r(" ++ int_to_string(RegNum) ++ ")"
|
|
;
|
|
RegName = "MR_r" ++ int_to_string(RegNum)
|
|
).
|
|
|
|
convert_type_to_mercury(Rval, Type, ConvertedRval) :-
|
|
( Type = builtin(BuiltinType) ->
|
|
(
|
|
BuiltinType = string,
|
|
ConvertedRval = "(MR_Word) " ++ Rval
|
|
;
|
|
BuiltinType = float,
|
|
ConvertedRval = "MR_float_to_word(" ++ Rval ++ ")"
|
|
;
|
|
BuiltinType = character,
|
|
% We need to explicitly cast to UnsignedChar
|
|
% to avoid problems with C compilers for which `char'
|
|
% is signed.
|
|
ConvertedRval = "(UnsignedChar) " ++ Rval
|
|
;
|
|
BuiltinType = int,
|
|
ConvertedRval = Rval
|
|
)
|
|
;
|
|
ConvertedRval = Rval
|
|
).
|
|
|
|
convert_type_from_mercury(Rval, Type, ConvertedRval) :-
|
|
( Type = builtin(string) ->
|
|
ConvertedRval = "(MR_String) " ++ Rval
|
|
; Type = builtin(float) ->
|
|
ConvertedRval = "MR_word_to_float(" ++ Rval ++ ")"
|
|
;
|
|
ConvertedRval = Rval
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% This procedure is used for both the MLDS and LLDS back-ends.
|
|
|
|
produce_header_file(ForeignExportDecls, ModuleName, !IO) :-
|
|
% We always produce a .mh file because with intermodule optimization
|
|
% enabled the .o file depends on all the .mh files of the imported modules
|
|
% so we always need to produce a .mh file even if it contains nothing.
|
|
ForeignExportDecls = foreign_export_decls(ForeignDecls, C_ExportDecls),
|
|
HeaderExt = ".mh",
|
|
module_name_to_file_name(ModuleName, HeaderExt, yes, FileName, !IO),
|
|
io__open_output(FileName ++ ".tmp", Result, !IO),
|
|
(
|
|
Result = ok(FileStream)
|
|
->
|
|
io__set_output_stream(FileStream, OutputStream, !IO),
|
|
module_name_to_file_name(ModuleName, ".m", no, SourceFileName, !IO),
|
|
library__version(Version),
|
|
io__write_strings([
|
|
"/*\n",
|
|
"** Automatically generated from `", SourceFileName, "'\n",
|
|
"** by the Mercury compiler,\n",
|
|
"** version ", Version, ".\n",
|
|
"** Do not edit.\n",
|
|
"*/\n"], !IO),
|
|
MangledModuleName = sym_name_mangle(ModuleName),
|
|
string__to_upper(MangledModuleName, UppercaseModuleName),
|
|
string__append(UppercaseModuleName, "_H", GuardMacroName),
|
|
io__write_strings([
|
|
"#ifndef ", GuardMacroName, "\n",
|
|
"#define ", GuardMacroName, "\n",
|
|
"\n",
|
|
"#ifdef __cplusplus\n",
|
|
"extern ""C"" {\n",
|
|
"#endif\n",
|
|
"\n",
|
|
"#ifdef MR_HIGHLEVEL_CODE\n",
|
|
"#include ""mercury.h""\n",
|
|
"#else\n",
|
|
" #ifndef MERCURY_HDR_EXCLUDE_IMP_H\n",
|
|
" #include ""mercury_imp.h""\n",
|
|
" #endif\n",
|
|
"#endif\n",
|
|
"#ifdef MR_DEEP_PROFILING\n",
|
|
"#include ""mercury_deep_profiling.h""\n",
|
|
"#endif\n",
|
|
"\n"], !IO),
|
|
|
|
io__write_strings([
|
|
"#ifndef ", decl_guard(ModuleName), "\n",
|
|
"#define ", decl_guard(ModuleName), "\n"], !IO),
|
|
list__foldl(output_foreign_decl(yes(foreign_decl_is_exported)),
|
|
ForeignDecls, !IO),
|
|
io__write_string("\n#endif\n", !IO),
|
|
|
|
produce_header_file_2(C_ExportDecls, !IO),
|
|
io__write_strings([
|
|
"\n",
|
|
"#ifdef __cplusplus\n",
|
|
"}\n",
|
|
"#endif\n",
|
|
"\n",
|
|
"#endif /* ", GuardMacroName, " */\n"], !IO),
|
|
io__set_output_stream(OutputStream, _, !IO),
|
|
io__close_output(FileStream, !IO),
|
|
% rename "<ModuleName>.mh.tmp" to "<ModuleName>.mh".
|
|
update_interface(FileName, !IO)
|
|
;
|
|
io__progname_base("export.m", ProgName, !IO),
|
|
io__write_string("\n", !IO),
|
|
io__write_string(ProgName, !IO),
|
|
io__write_string(": can't open `", !IO),
|
|
io__write_string(FileName ++ ".tmp", !IO),
|
|
io__write_string("' for output\n", !IO),
|
|
io__set_exit_status(1, !IO)
|
|
).
|
|
|
|
:- pred produce_header_file_2(list(foreign_export_decl)::in, io::di, io::uo)
|
|
is det.
|
|
|
|
produce_header_file_2([], !IO).
|
|
produce_header_file_2([E | ExportedProcs], !IO) :-
|
|
E = foreign_export_decl(Lang, C_RetType, C_Function, ArgDecls),
|
|
( Lang = c ->
|
|
% Output the function header.
|
|
io__write_string(C_RetType, !IO),
|
|
io__write_string(" ", !IO),
|
|
io__write_string(C_Function, !IO),
|
|
io__write_string("(", !IO),
|
|
io__write_string(ArgDecls, !IO),
|
|
io__write_string(");\n", !IO)
|
|
;
|
|
sorry(this_file, "foreign languages other than C unimplemented")
|
|
),
|
|
produce_header_file_2(ExportedProcs, !IO).
|
|
|
|
:- pred output_foreign_decl(maybe(foreign_decl_is_local)::in,
|
|
foreign_decl_code::in, io::di, io::uo) is det.
|
|
|
|
output_foreign_decl(MaybeDesiredIsLocal, DeclCode, !IO) :-
|
|
DeclCode = foreign_decl_code(Lang, IsLocal, Code, Context),
|
|
(
|
|
Lang = c,
|
|
(
|
|
MaybeDesiredIsLocal = no
|
|
;
|
|
MaybeDesiredIsLocal = yes(DesiredIsLocal),
|
|
DesiredIsLocal = IsLocal
|
|
)
|
|
->
|
|
term__context_file(Context, File),
|
|
term__context_line(Context, Line),
|
|
c_util__set_line_num(File, Line, !IO),
|
|
io__write_string(Code, !IO),
|
|
io__nl(!IO),
|
|
c_util__reset_line_num(!IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
c_type_is_word_sized_int_or_ptr("MR_Word").
|
|
c_type_is_word_sized_int_or_ptr("MR_TypeInfo").
|
|
c_type_is_word_sized_int_or_ptr("MR_TypeCtorInfo").
|
|
c_type_is_word_sized_int_or_ptr("MR_TypeClassInfo").
|
|
c_type_is_word_sized_int_or_ptr("MR_BaseTypeclassInfo").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "export.m".
|
|
|
|
%-----------------------------------------------------------------------------%
|