mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-16 06:14:59 +00:00
4ebe3d0d7e
Estimated hours taken: 60 Branches: main Stop storing globals in the I/O state, and divide mercury_compile.m into smaller, more cohesive modules. (This diff started out as doing only the latter, but it became clear that this was effectively impossible without the former, and the former ended up accounting for the bulk of the changes.) Taking the globals out of the I/O state required figuring out how globals data flowed between pieces of code that were often widely separated. Such flows were invisible when globals could be hidden in the I/O state, but now they are visible, because the affected code now passes around globals structures explicitly. In some cases, the old flow looked buggy, as when one job invoked by mmc --make could affect the globals value of its parent or the globals value passed to the next job. I tried to fix such problems when I saw them. I am not 100% sure I succeeded in every case (I may have replaced old bugs with new ones), but at least now the flow is out in the open, and any bugs should be much easier to track down and fix. In most cases, changes the globals after the initial setup are intended to be in effect only during the invocation of a few calls. This used to be done by remembering the initial values of the to-be-changed options, changing their values in the globals in the I/O state, making the calls, and restoring the old values of the options. We now simply create a new version of the globals structure, pass it to the calls to be affected, and then discard it. In two cases, when discovering reasons why (1) smart recompilation should not be done or (2) item version numbers should not be generated, the record of the discovery needs to survive this discarding. This is why in those cases, we record the discovery by setting a mutable attached to the I/O state. We use pure code (with I/O states) both to read and to write the mutables, so this is no worse semantically than storing the information in the globals structure inside the I/O state. (Also, we were already using such a mutable for recording whether -E could add more information.) In many modules, the globals information had to be threaded through several predicates in the module. In some places, this was made more difficult by predicates being defined by many clauses. In those cases, this diff converts those predicates to using explicit disjunctions. compiler/globals.m: Stop storing the globals structure in the I/O state, and remove the predicates that accessed it there. Move a mutable and its access predicate here from handle_options.m, since here is when the mutables treated the same way are. In a couple of cases, the value of an option is available in a mutable for speed of access from inside performance-critical code. Set the values of those mutables from the option when the processing of option values is finished, not when it is starting, since otherwise the copies of each option could end up inconsistent. Validate the reuse strategy option here, since doing it during ctgc analysis (a) is too late, and (b) would require an update to the globals to be done at an otherwise inconvenient place in the code. Put the reuse strategy into the globals structure. Two fields in the globals structure were unused. One (have_printed_usage) was made redundant when the one predicate that used it itself became unused; the other (source_file_map) was effectively replaced by a mutable some time ago. Delete these fields from the globals. Give the fields of the globals structure a distinguishing prefix. Put the type declarations, predicate declarations and predicate definitions in a consistent order. compiler/source_file_map.m: Record this module's results only in the mutable (it serves as a cache), not in globals structure. Use explicitly passed globals structure for other purposes. compiler/handle_options.m: Rename handle_options as handle_given_options, since it does not process THE options to the program, but the options it is given, and even during the processing of a single module, it can be invoked up the three times in a row, each time being given different options. (It was up to four times in a row before this diff.) Make handle_given_options explicitly return the globals structure it creates. Since it does not take an old global structure as input and globals are not stored in the I/O state, it is now clear that the globals structure it returns is affected only by the default values of the options and the options it processes. Before this diff, in the presence of errors in the options, handle_options *could* return (implicitly, in the I/O state) the globals structure that happened to be in the I/O state when it was invoked. Provide a separate predicate for generating a dummy globals based only on the default values of options. This allows by mercury_compile.m to stop abusing a more general-purpose predicate from handle_options.m, which we no longer export. Remove the mutable and access predicate moved to globals.m. compiler/options.m: Document the fact that two options, smart_recompilation and generate_item_version_numbers, should not be used without seeing whether the functionalities they call for have been disabled. compiler/mercury_compile_front_end.m: compiler/mercury_compile_middle_passes.m: compiler/mercury_compile_llds_back_end.m: compiler/mercury_compile_mlds_back_end.m: compiler/mercury_compile_erl_back_end.m: New modules carved out of the old mercury_compile.m. They each cover exactly the areas suggested by their names. Each of the modules is more cohesive than the old mercury_compile.m. Their code is also arranged in a more logical order, with predicates representing compiler passes being defined in the order of their invocation. Some of these modules export predicates for use by their siblings, showing the dependencies between the groups of passes. compiler/top_level.m: compiler/notes/compiler_design.html: Add the new modules. compiler/mark_static_terms.m: Move this module from the ml_backend package to the hlds package, since (a) it does not depend on the MLDS in any way, and (b) it is also needed by a compiler pass (loop invariants) in the middle passes. compiler/hlds.m: compiler/ml_backend.m: compiler/notes/compiler_design.html: Reflect mark_static_terms.m's change of package. compiler/passes_aux.m: Move the predicates for dumping out the hLDS here from mercury_compile.m, since the new modules also need them. Look up globals in the HLDS, not the I/O state. compiler/hlds_module.m: Store the prefix (common part) of HLDS dump file names in the HLDS itself, so that the code moved to passes_aux.m can figure out the file name for a HLDS dump without doing system calls. Give the field names of some structures prefixes to avoid ambiguity. compiler/mercury_compile.m: Remove the code moved to the other modules. This module now looks after only option handling (such as deciding whether to generate .int3 files, .int files, .opt files etc), and the compilation passes up to and including the creation of the first version of the HLDS. Everything after that is subcontracted to the new modules. Simplify and make explicit the flow of globals information. When invoking predicates that could disable smart recompilation, check whether they have done so, and if yes, update the globals accordingly. When compiling via gcc, we need to link into the executable the object files of any separate C files we generate for C code foreign_procs, which we cannot translate into gcc's internal structures without becoming a C compiler as well as a Mercury compiler. Instead of adding such files to the accumulating option for extra object files in the globals structure, we return their names using the already existing mechanism we have always used to link the object files of fact tables into the executable. Give several predicates more descriptive names. Put predicates in a more logical order. compiler/make.m: compiler/make.dependencies.m: compiler/make.module_target.m: compiler/make.module_dep_file.m: compiler/make.program_target.m: compiler/make.util.m: Require callers to supply globals structures explicitly, not via the I/O state. Afterward pass them around explicitly, passing modified versions to mercury_compile.m when invoking it with module- and/or task-specific options. Due the extensive use of partial application for higher order code in these modules, passing around the globals structures explicitly is quite tricky here. There may be cases where a predicate uses an old globals structure it got from a closure instead of the updated module- and/or task-specific globals it should be using, or vice versa. However, it is just as likely that, this diff fixes old problems by preventing the implicit flow of updated-only-for-one-invocation globals structures back to the original invoking context. Although I have tried to be careful about this, it is also possible that in some places, the code is using an updated-for-an-invocation globals structure in some but not all of the places where it SHOULD be used. compiler/c_util.m: compiler/compile_target_code.m: compiler/compiler_util.m: compiler/error_util.m: compiler/file_names.m: compiler/file_util.m: compiler/ilasm.m: compiler/ml_optimize.m: compiler/mlds_to_managed.m: compiler/module_cmds.m: compiler/modules.m: compiler/options_file.m: compiler/pd_debug.m: compiler/prog_io.m: compiler/transform_llds.m: compiler/write_deps_file.m: Require callers to supply globals structures explicitly, not via the I/O state. In some cases, the explicit globals structure argument allows a predicate to dispense with the I/O states previously passed to it. In some modules, rename some predicates, types and/or function symbols to avoid ambiguity. compiler/read_modules.m: Require callers to supply globals structures explicitly, not via the I/O state. Record when smart recompilation and the generation of item version numbers should be disabled. compiler/opt_debug.m: compiler/process_util.m: Require callers to supply the needed options explicitly, not via the globals in the I/O state. compiler/analysis.m: compiler/analysis.file.m: compiler/mmc_analysis.m: Make the analysis framework's methods take their global structures as explicit arguments, not as implicit data stored in the I/O state. Stop using `with_type` and `with_inst` declarations unnecessarily. Rename some predicates to avoid ambiguity. compiler/hlds_out.m: compiler/llds_out.m: compiler/mercury_to_mercury.m: compiler/mlds_to_c.m: compiler/mlds_to_java.m: compiler/optimize.m: Make these modules stop accessing the globals from the I/O state. Do this by requiring the callers of their top predicates to explicitly supply a globals structure. To compensate for the cost of having to pass around a representation of the options, look up the values of the options of interest just once, to make further access much faster. (In the case of mlds_to_c.m, the code already did much of this, but it still had a few accesses to globals in the I/O state that this diff eliminates.) If the module exports a predicate that needs these pre-looked-up options, then export the type of this data structure and its initialization function. compiler/frameopt.m: Since this module needs only one option from the globals, pass that option instead of the globals. compiler/accumulator.m: compiler/add_clause.m: compiler/closure_analysis.m: compiler/complexity.m: compiler/deforest.m: compiler/delay_construct.m: compiler/elds_to_erlang.m: compiler/exception_analysis.m: compiler/fact_table.m: compiler/intermod.m: compiler/mode_constraints.m: compiler/mode_errors.m: compiler/pd_util.m: compiler/post_term_analysis.m: compiler/recompilation.usage.m: compiler/size_prof.usage.m: compiler/structure_reuse.analysis.m: compiler/structure_reuse.direct.choose_reuse.m: compiler/structure_reuse.direct.m: compiler/structure_sharing.analysis.m: compiler/tabling_analysis.m: compiler/term_constr_errors.m: compiler/term_constr_fixpoint.m: compiler/term_constr_initial.m: compiler/term_constr_main.m: compiler/term_constr_util.m: compiler/trailing_analysis.m: compiler/trans_opt.m: compiler/typecheck_info.m: Look up globals information from the HLDS, not the I/O state. Conform to the changes above. compiler/gcc.m: compiler/maybe_mlds_to_gcc.pp: compiler/mlds_to_gcc.m: Look up globals information from the HLDS, not the I/O state. Conform to the changes above. Convert these modules to our current programming style. compiler/termination.m: Look up globals information from the HLDS, not the I/O state. Conform to the changes above. Report some warnings with error_specs, instead of immediately printing them out. compiler/export.m: compiler/il_peephole.m: compiler/layout_out.m: compiler/rtti_out.m: compiler/liveness.m: compiler/make_hlds.m: compiler/make_hlds_passes.m: compiler/mlds_to_il.m: compiler/mlds_to_ilasm.m: compiler/recompilation.check.m: compiler/stack_opt.m: compiler/superhomogeneous.m: compiler/tupling..m: compiler/unneeded_code.m: compiler/unused_args.m: compiler/unused_import.m: compiler/xml_documentation.m: Conform to the changes above. compiler/equiv_type_hlds.m: Give the field names of a structure prefixes to avoid ambiguity. Stop using `with_type` and `with_inst` declarations unnecessarily. compiler/loop_inv.m: compiler/pd_info.m: compiler/stack_layout.m: Give the field names of some structures prefixes to avoid ambiguity. compiler/add_pragma.m: Add notes. compiler/string.m: NEWS: Add a det version of remove_suffix, for use by new code above.
2549 lines
100 KiB
Mathematica
2549 lines
100 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1996-2009 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.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% File: intermod.m.
|
|
% Main author: stayl.
|
|
%
|
|
% This module writes out the interface for inter-module optimization.
|
|
% The .opt file includes:
|
|
% - The clauses for exported preds that can be inlined.
|
|
% - The clauses for exported preds that have higher-order pred arguments.
|
|
% - The pred/mode declarations for local predicates that the
|
|
% above clauses use.
|
|
% - Non-exported types, insts and modes used by the above
|
|
% - Pragma reserve_tag, foreign_enum, or foreign_type declarations for
|
|
% any types output due to the line above
|
|
% - :- import_module declarations to import stuff used by the above.
|
|
% - pragma declarations for the exported preds.
|
|
% - 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
|
|
% to adjust the import status of local predicates which are exported for
|
|
% intermodule optimization.
|
|
%
|
|
% Note that predicates which call predicates that do not have mode or
|
|
% determinism declarations do not have clauses exported, since this would
|
|
% require running mode analysis and determinism analysis before writing the
|
|
% .opt file, significantly increasing compile time for a very small gain.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module transform_hlds.intermod.
|
|
:- interface.
|
|
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module libs.globals.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.module_imports.
|
|
:- import_module parse_tree.prog_io.
|
|
|
|
:- import_module bool.
|
|
:- import_module io.
|
|
:- import_module list.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Open the file "<module-name>.opt.tmp", and write out the declarations
|
|
% and clauses for intermodule optimization. Note that update_interface
|
|
% and touch_interface_datestamp are called from mercury_compile.m since
|
|
% they must be called after unused_args.m appends its information
|
|
% to the .opt.tmp file.
|
|
%
|
|
:- pred write_opt_file(module_info::in, module_info::out, io::di, io::uo)
|
|
is det.
|
|
|
|
% Add the items from the .opt files of imported modules to
|
|
% the items for this module.
|
|
%
|
|
:- pred grab_opt_files(globals::in,
|
|
module_and_imports::in, module_and_imports::out, bool::out,
|
|
io::di, io::uo) is det.
|
|
|
|
% Make sure that local preds which have been exported in the .opt
|
|
% file get an exported(_) label.
|
|
%
|
|
:- pred adjust_pred_import_status(module_info::in, module_info::out) is det.
|
|
|
|
:- type opt_file_type
|
|
---> opt_file
|
|
; trans_opt_file.
|
|
|
|
% update_error_status(Globals, OptFileType, FileName,
|
|
% ModuleSpecs, !Specs, ModuleError, !Error):
|
|
%
|
|
% Work out whether any fatal errors have occurred while reading
|
|
% `.opt' files, updating !Error if there were fatal errors.
|
|
%
|
|
% A missing `.opt' file is only a fatal error if
|
|
% `--warn-missing-opt-files --halt-at-warn' was passed the compiler.
|
|
%
|
|
% Syntax errors in `.opt' files are always fatal.
|
|
%
|
|
% This is also used by trans_opt.m for reading `.trans_opt' files.
|
|
%
|
|
:- pred update_error_status(globals::in, opt_file_type::in, string::in,
|
|
list(error_spec)::in, list(error_spec)::in, list(error_spec)::out,
|
|
module_error::in, bool::in, bool::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module backend_libs.
|
|
:- import_module backend_libs.foreign.
|
|
:- import_module check_hlds.mode_util.
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module hlds.goal_util.
|
|
:- import_module hlds.hlds_clauses.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_out.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module hlds.special_pred.
|
|
:- import_module libs.compiler_util.
|
|
:- import_module libs.file_util.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module parse_tree.file_names.
|
|
:- import_module parse_tree.mercury_to_mercury.
|
|
:- import_module parse_tree.modules.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_io.
|
|
:- import_module parse_tree.prog_item.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_util.
|
|
:- import_module transform_hlds.inlining.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module cord.
|
|
:- import_module getopt_io.
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module multi_map.
|
|
:- import_module pair.
|
|
:- import_module set.
|
|
:- import_module solutions.
|
|
:- import_module string.
|
|
:- import_module term.
|
|
:- import_module term_io.
|
|
:- import_module varset.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
write_opt_file(!ModuleInfo, !IO) :-
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
module_info_get_name(!.ModuleInfo, ModuleName),
|
|
module_name_to_file_name(Globals, ModuleName, ".opt.tmp", do_create_dirs,
|
|
TmpName, !IO),
|
|
io.open_output(TmpName, Result, !IO),
|
|
(
|
|
Result = error(Err),
|
|
Msg = io.error_message(Err),
|
|
io.write_string(Msg, !IO),
|
|
io.set_exit_status(1, !IO)
|
|
;
|
|
Result = ok(FileStream),
|
|
io.set_output_stream(FileStream, OutputStream, !IO),
|
|
module_info_predids(RealPredIds, !ModuleInfo),
|
|
module_info_get_assertion_table(!.ModuleInfo, AssertionTable),
|
|
assertion_table_pred_ids(AssertionTable, AssertPredIds),
|
|
PredIds = AssertPredIds ++ RealPredIds,
|
|
globals.lookup_int_option(Globals, intermod_inline_simple_threshold,
|
|
Threshold),
|
|
globals.lookup_bool_option(Globals, deforestation, Deforestation),
|
|
globals.lookup_int_option(Globals, higher_order_size_limit,
|
|
HigherOrderSizeLimit),
|
|
some [!IntermodInfo] (
|
|
init_intermod_info(!.ModuleInfo, !:IntermodInfo),
|
|
gather_preds(PredIds, yes, Threshold, HigherOrderSizeLimit,
|
|
Deforestation, !IntermodInfo),
|
|
gather_instances(!IntermodInfo),
|
|
gather_types(!IntermodInfo),
|
|
write_intermod_info(!.IntermodInfo, !IO),
|
|
intermod_info_get_module_info(!.IntermodInfo, !:ModuleInfo),
|
|
io.set_output_stream(OutputStream, _, !IO),
|
|
io.close_output(FileStream, !IO),
|
|
do_adjust_pred_import_status(!.IntermodInfo, !ModuleInfo)
|
|
)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Predicates to gather items to output to .opt file
|
|
%
|
|
|
|
:- pred gather_preds(list(pred_id)::in, bool::in, int::in, int::in, bool::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
gather_preds(AllPredIds, CollectTypes, InlineThreshold, HigherOrderSizeLimit,
|
|
Deforestation, !Info) :-
|
|
% First gather exported preds.
|
|
ProcessLocalPreds = no,
|
|
gather_pred_list(AllPredIds, ProcessLocalPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info),
|
|
|
|
% Then gather preds used by exported preds (recursively).
|
|
set.init(ExtraExportedPreds0),
|
|
gather_preds_fixpoint(ExtraExportedPreds0, CollectTypes, InlineThreshold,
|
|
HigherOrderSizeLimit, Deforestation, !Info).
|
|
|
|
:- pred gather_preds_fixpoint(set(pred_id)::in, bool::in, int::in, int::in,
|
|
bool::in, intermod_info::in, intermod_info::out) is det.
|
|
|
|
gather_preds_fixpoint(ExtraExportedPreds0, CollectTypes, InlineThreshold,
|
|
HigherOrderSizeLimit, Deforestation, !Info) :-
|
|
intermod_info_get_pred_decls(!.Info, ExtraExportedPreds),
|
|
NewlyExportedPreds = set.to_sorted_list(
|
|
ExtraExportedPreds `set.difference` ExtraExportedPreds0),
|
|
(
|
|
NewlyExportedPreds = []
|
|
;
|
|
NewlyExportedPreds = [_ | _],
|
|
ProcessLocalPreds = yes,
|
|
gather_pred_list(NewlyExportedPreds, ProcessLocalPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info),
|
|
gather_preds_fixpoint(ExtraExportedPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info)
|
|
).
|
|
|
|
:- pred gather_pred_list(list(pred_id)::in, bool::in, bool::in,
|
|
int::in, int::in, bool::in, intermod_info::in, intermod_info::out) is det.
|
|
|
|
gather_pred_list([], _, _, _, _, _, !Info).
|
|
gather_pred_list([PredId | PredIds], ProcessLocalPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info) :-
|
|
intermod_info_get_module_info(!.Info, ModuleInfo0),
|
|
module_info_preds(ModuleInfo0, PredTable0),
|
|
map.lookup(PredTable0, PredId, PredInfo0),
|
|
module_info_get_type_spec_info(ModuleInfo0, TypeSpecInfo),
|
|
TypeSpecInfo = type_spec_info(_, TypeSpecForcePreds, _, _),
|
|
pred_info_get_clauses_info(PredInfo0, ClausesInfo0),
|
|
(
|
|
clauses_info_get_explicit_vartypes(ClausesInfo0, ExplicitVarTypes),
|
|
map.is_empty(ExplicitVarTypes),
|
|
should_be_processed(ProcessLocalPreds, PredId, PredInfo0,
|
|
TypeSpecForcePreds, InlineThreshold, HigherOrderSizeLimit,
|
|
Deforestation, ModuleInfo0)
|
|
->
|
|
SavedInfo = !.Info,
|
|
% Write a declaration to the `.opt' file for
|
|
% `exported_to_submodules' predicates.
|
|
add_proc(PredId, DoWrite0, !Info),
|
|
clauses_info_get_clauses_rep(ClausesInfo0, ClausesRep0, ItemNumbers0),
|
|
(
|
|
DoWrite0 = yes,
|
|
clauses_info_get_vartypes(ClausesInfo0, VarTypes),
|
|
pred_info_get_typevarset(PredInfo0, TVarSet),
|
|
intermod_info_set_var_types(VarTypes, !Info),
|
|
intermod_info_set_tvarset(TVarSet, !Info),
|
|
get_clause_list(ClausesRep0, Clauses0),
|
|
intermod_traverse_clauses(Clauses0, Clauses, DoWrite, !Info),
|
|
set_clause_list(Clauses, ClausesRep)
|
|
;
|
|
DoWrite0 = no,
|
|
ClausesRep = ClausesRep0,
|
|
DoWrite = no
|
|
),
|
|
(
|
|
DoWrite = yes,
|
|
clauses_info_set_clauses_rep(ClausesRep, ItemNumbers0,
|
|
ClausesInfo0, ClausesInfo),
|
|
pred_info_set_clauses_info(ClausesInfo, PredInfo0, PredInfo),
|
|
map.det_update(PredTable0, PredId, PredInfo, PredTable),
|
|
module_info_set_preds(PredTable, ModuleInfo0, ModuleInfo),
|
|
intermod_info_get_preds(!.Info, Preds0),
|
|
( pred_info_pragma_goal_type(PredInfo) ->
|
|
% pragma foreign_decls must be written since their contents
|
|
% could be used by pragma foreign_procs.
|
|
intermod_info_set_write_header(!Info)
|
|
;
|
|
true
|
|
),
|
|
set.insert(Preds0, PredId, Preds),
|
|
intermod_info_set_preds(Preds, !Info),
|
|
intermod_info_set_module_info(ModuleInfo, !Info)
|
|
;
|
|
DoWrite = no,
|
|
% Remove any items added for the clauses for this predicate.
|
|
!:Info = SavedInfo
|
|
)
|
|
;
|
|
true
|
|
),
|
|
gather_pred_list(PredIds, ProcessLocalPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info).
|
|
|
|
:- pred should_be_processed(bool::in, pred_id::in, pred_info::in,
|
|
set(pred_id)::in, int::in, int::in, bool::in,
|
|
module_info::in) is semidet.
|
|
|
|
should_be_processed(ProcessLocalPreds, PredId, PredInfo, TypeSpecForcePreds,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, ModuleInfo) :-
|
|
(
|
|
ProcessLocalPreds = no,
|
|
( pred_info_is_exported(PredInfo)
|
|
; pred_info_is_exported_to_submodules(PredInfo)
|
|
)
|
|
;
|
|
ProcessLocalPreds = yes,
|
|
pred_info_get_import_status(PredInfo, status_local)
|
|
),
|
|
(
|
|
pred_info_get_clauses_info(PredInfo, ClauseInfo),
|
|
clauses_info_get_clauses_rep(ClauseInfo, ClausesRep, _ItemNumbers),
|
|
get_clause_list(ClausesRep, Clauses),
|
|
|
|
[ProcId | _ProcIds] = pred_info_procids(PredInfo),
|
|
pred_info_get_procedures(PredInfo, Procs),
|
|
map.lookup(Procs, ProcId, ProcInfo),
|
|
|
|
% At this point, the goal size includes some dummy unifications
|
|
% HeadVar1 = X, HeadVar2 = Y, etc. which will be optimized away
|
|
% later. To counter for this, we add the arity to the size thresholds.
|
|
Arity = pred_info_orig_arity(PredInfo),
|
|
|
|
% Predicates with `class_method' markers contain class_method_call
|
|
% goals which can't be written to `.opt' files (they can't be read
|
|
% back in). They will be recreated in the importing module.
|
|
pred_info_get_markers(PredInfo, Markers),
|
|
\+ check_marker(Markers, marker_class_method),
|
|
\+ check_marker(Markers, marker_class_instance_method),
|
|
|
|
% Don't write stub clauses to `.opt' files.
|
|
\+ check_marker(Markers, marker_stub),
|
|
|
|
% Don't export builtins since they will be recreated in the
|
|
% importing module anyway.
|
|
\+ is_unify_or_compare_pred(PredInfo),
|
|
\+ pred_info_is_builtin(PredInfo),
|
|
|
|
% These will be recreated in the importing module.
|
|
\+ set.member(PredId, TypeSpecForcePreds),
|
|
|
|
% No point exporting code which isn't very inlinable.
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.get_target(Globals, Target),
|
|
\+ clauses_contain_noninlinable_foreign_code(Target, Clauses),
|
|
|
|
% Don't export tabled predicates since they are not inlinable.
|
|
proc_info_get_eval_method(ProcInfo, eval_normal),
|
|
|
|
(
|
|
inlining.is_simple_clause_list(Clauses, InlineThreshold + Arity),
|
|
pred_info_get_markers(PredInfo, Markers),
|
|
\+ check_marker(Markers, marker_user_marked_no_inline)
|
|
;
|
|
pred_info_requested_inlining(PredInfo)
|
|
;
|
|
% Mutable access preds should always be included in .opt files.
|
|
%
|
|
check_marker(Markers, marker_mutable_access_pred)
|
|
;
|
|
has_ho_input(ModuleInfo, ProcInfo),
|
|
clause_list_size(Clauses, GoalSize),
|
|
GoalSize =< HigherOrderSizeLimit + Arity
|
|
;
|
|
Deforestation = yes,
|
|
% Double the inline-threshold since goals we want to deforest
|
|
% will have at least two disjuncts. This allows one simple goal
|
|
% in each disjunct. The disjunction adds one to the goal size,
|
|
% hence the `+1'.
|
|
DeforestThreshold = InlineThreshold * 2 + 1,
|
|
inlining.is_simple_clause_list(Clauses, DeforestThreshold + Arity),
|
|
clause_list_is_deforestable(PredId, Clauses)
|
|
)
|
|
;
|
|
% Promises that are in the interface should always get included
|
|
% in the .opt file.
|
|
pred_info_get_goal_type(PredInfo, goal_type_promise(_))
|
|
).
|
|
|
|
% If the clauses contains foreign code which requires an external
|
|
% definition, there is not much point in exporting it.
|
|
%
|
|
:- pred clauses_contain_noninlinable_foreign_code(compilation_target::in,
|
|
list(clause)::in) is semidet.
|
|
|
|
clauses_contain_noninlinable_foreign_code(Target, [C | _Cs]) :-
|
|
Target = target_il,
|
|
Lang = C ^ clause_lang,
|
|
Lang = impl_lang_foreign(ForeignLang),
|
|
ForeignLang = lang_csharp.
|
|
clauses_contain_noninlinable_foreign_code(Target, [_ | Cs]) :-
|
|
clauses_contain_noninlinable_foreign_code(Target, Cs).
|
|
|
|
:- pred intermod_traverse_clauses(list(clause)::in, list(clause)::out,
|
|
bool::out, intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod_traverse_clauses([], [], yes, !Info).
|
|
intermod_traverse_clauses([clause(P, Goal0, L, C) | Clauses0],
|
|
[clause(P, Goal, L, C) | Clauses], DoWrite, !Info) :-
|
|
intermod_traverse_goal(Goal0, Goal, DoWrite1, !Info),
|
|
(
|
|
DoWrite1 = yes,
|
|
intermod_traverse_clauses(Clauses0, Clauses, DoWrite, !Info)
|
|
;
|
|
DoWrite1 = no,
|
|
Clauses = Clauses0,
|
|
DoWrite = no
|
|
).
|
|
|
|
:- pred has_ho_input(module_info::in, proc_info::in) is semidet.
|
|
|
|
has_ho_input(ModuleInfo, ProcInfo) :-
|
|
proc_info_get_headvars(ProcInfo, HeadVars),
|
|
proc_info_get_argmodes(ProcInfo, ArgModes),
|
|
proc_info_get_vartypes(ProcInfo, VarTypes),
|
|
check_for_ho_input_args(ModuleInfo, VarTypes, HeadVars, ArgModes).
|
|
|
|
:- pred check_for_ho_input_args(module_info::in, vartypes::in,
|
|
list(prog_var)::in, list(mer_mode)::in) is semidet.
|
|
|
|
check_for_ho_input_args(ModuleInfo, VarTypes,
|
|
[HeadVar | HeadVars], [ArgMode | ArgModes]) :-
|
|
(
|
|
mode_is_input(ModuleInfo, ArgMode),
|
|
map.lookup(VarTypes, HeadVar, Type),
|
|
classify_type(ModuleInfo, Type) = ctor_cat_higher_order
|
|
;
|
|
check_for_ho_input_args(ModuleInfo, VarTypes, HeadVars, ArgModes)
|
|
).
|
|
|
|
% Rough guess: a goal is deforestable if it contains a single
|
|
% top-level branched goal and is recursive.
|
|
%
|
|
:- pred clause_list_is_deforestable(pred_id::in, list(clause)::in) is semidet.
|
|
|
|
clause_list_is_deforestable(PredId, Clauses) :-
|
|
some [Clause1] (
|
|
list.member(Clause1, Clauses),
|
|
Clause1 = clause(_, Goal1, _, _),
|
|
goal_calls_pred_id(Goal1, PredId)
|
|
),
|
|
(
|
|
Clauses = [_, _ | _]
|
|
;
|
|
Clauses = [Clause2],
|
|
Clause2 = clause(_, Goal2, _, _),
|
|
goal_to_conj_list(Goal2, GoalList),
|
|
goal_contains_one_branched_goal(GoalList)
|
|
).
|
|
|
|
:- pred goal_contains_one_branched_goal(list(hlds_goal)::in) is semidet.
|
|
|
|
goal_contains_one_branched_goal(GoalList) :-
|
|
goal_contains_one_branched_goal(GoalList, no).
|
|
|
|
:- pred goal_contains_one_branched_goal(list(hlds_goal)::in, bool::in)
|
|
is semidet.
|
|
|
|
goal_contains_one_branched_goal([], yes).
|
|
goal_contains_one_branched_goal([Goal | Goals], FoundBranch0) :-
|
|
Goal = hlds_goal(GoalExpr, _),
|
|
(
|
|
goal_is_branched(GoalExpr),
|
|
FoundBranch0 = no,
|
|
FoundBranch = yes
|
|
;
|
|
goal_expr_has_subgoals(GoalExpr) = does_not_have_subgoals,
|
|
FoundBranch = FoundBranch0
|
|
),
|
|
goal_contains_one_branched_goal(Goals, FoundBranch).
|
|
|
|
% Go over the goal of an exported proc looking for proc decls, types,
|
|
% insts and modes that we need to write to the optfile.
|
|
%
|
|
:- pred intermod_traverse_goal(hlds_goal::in, hlds_goal::out, bool::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod_traverse_goal(Goal0, Goal, DoWrite, !Info) :-
|
|
Goal0 = hlds_goal(GoalExpr0, GoalInfo),
|
|
intermod_traverse_goal_expr(GoalExpr0, GoalExpr, DoWrite, !Info),
|
|
Goal = hlds_goal(GoalExpr, GoalInfo).
|
|
|
|
:- pred intermod_traverse_goal_expr(hlds_goal_expr::in, hlds_goal_expr::out,
|
|
bool::out, intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod_traverse_goal_expr(GoalExpr0, GoalExpr, DoWrite, !Info) :-
|
|
(
|
|
GoalExpr0 = unify(LVar, RHS0, Mode, Kind, UnifyContext),
|
|
% Export declarations for preds used in higher order pred constants
|
|
% or function calls.
|
|
module_qualify_unify_rhs(RHS0, RHS, DoWrite, !Info),
|
|
GoalExpr = unify(LVar, RHS, Mode, Kind, UnifyContext)
|
|
;
|
|
GoalExpr0 = plain_call(PredId, _, _, _, _, _),
|
|
% Ensure that the called predicate will be exported.
|
|
add_proc(PredId, DoWrite, !Info),
|
|
GoalExpr = GoalExpr0
|
|
;
|
|
GoalExpr0 = generic_call(CallType, _, _, _),
|
|
GoalExpr = GoalExpr0,
|
|
(
|
|
CallType = higher_order(_, _, _, _),
|
|
DoWrite = yes
|
|
;
|
|
( CallType = class_method(_, _, _, _)
|
|
; CallType = event_call(_)
|
|
; CallType = cast(_)
|
|
),
|
|
DoWrite = no
|
|
)
|
|
;
|
|
GoalExpr0 = call_foreign_proc(Attrs, _, _, _, _, _, _),
|
|
GoalExpr = GoalExpr0,
|
|
% Inlineable exported pragma_foreign_code goals can't use any
|
|
% non-exported types, so we just write out the clauses.
|
|
MaybeMayDuplicate = get_may_duplicate(Attrs),
|
|
(
|
|
MaybeMayDuplicate = yes(MayDuplicate),
|
|
(
|
|
MayDuplicate = proc_may_duplicate,
|
|
DoWrite = yes
|
|
;
|
|
MayDuplicate = proc_may_not_duplicate,
|
|
DoWrite = no
|
|
)
|
|
;
|
|
MaybeMayDuplicate = no,
|
|
DoWrite = yes
|
|
)
|
|
;
|
|
GoalExpr0 = conj(ConjType, Goals0),
|
|
intermod_traverse_list_of_goals(Goals0, Goals, DoWrite, !Info),
|
|
GoalExpr = conj(ConjType, Goals)
|
|
;
|
|
GoalExpr0 = disj(Goals0),
|
|
intermod_traverse_list_of_goals(Goals0, Goals, DoWrite, !Info),
|
|
GoalExpr = disj(Goals)
|
|
;
|
|
GoalExpr0 = switch(Var, CanFail, Cases0),
|
|
intermod_traverse_cases(Cases0, Cases, DoWrite, !Info),
|
|
GoalExpr = switch(Var, CanFail, Cases)
|
|
;
|
|
GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
|
|
intermod_traverse_goal(Cond0, Cond, DoWrite1, !Info),
|
|
intermod_traverse_goal(Then0, Then, DoWrite2, !Info),
|
|
intermod_traverse_goal(Else0, Else, DoWrite3, !Info),
|
|
bool.and_list([DoWrite1, DoWrite2, DoWrite3], DoWrite),
|
|
GoalExpr = if_then_else(Vars, Cond, Then, Else)
|
|
;
|
|
GoalExpr0 = negation(SubGoal0),
|
|
intermod_traverse_goal(SubGoal0, SubGoal, DoWrite, !Info),
|
|
GoalExpr = negation(SubGoal)
|
|
;
|
|
GoalExpr0 = scope(Reason, SubGoal0),
|
|
% Mode analysis hasn't been run yet, so we don't know yet whether
|
|
% from_ground_term_construct scopes actually satisfy their invariants,
|
|
% specifically the invariant that say they contain no calls or
|
|
% higher-order constants. We therefore cannot special-case them here.
|
|
intermod_traverse_goal(SubGoal0, SubGoal, DoWrite, !Info),
|
|
GoalExpr = scope(Reason, SubGoal)
|
|
;
|
|
GoalExpr0 = shorthand(ShortHand0),
|
|
(
|
|
ShortHand0 = atomic_goal(GoalType, Outer, Inner, MaybeOutputVars,
|
|
MainGoal0, OrElseGoals0, OrElseInners),
|
|
intermod_traverse_goal(MainGoal0, MainGoal, DoWrite1, !Info),
|
|
intermod_traverse_list_of_goals(OrElseGoals0, OrElseGoals, DoWrite2,
|
|
!Info),
|
|
bool.and(DoWrite1, DoWrite2, DoWrite),
|
|
ShortHand = atomic_goal(GoalType, Outer, Inner, MaybeOutputVars,
|
|
MainGoal, OrElseGoals, OrElseInners)
|
|
;
|
|
ShortHand0 = try_goal(MaybeIO, ResultVar, SubGoal0),
|
|
intermod_traverse_goal(SubGoal0, SubGoal, DoWrite, !Info),
|
|
ShortHand = try_goal(MaybeIO, ResultVar, SubGoal)
|
|
;
|
|
ShortHand0 = bi_implication(_, _),
|
|
% These should have been expanded out by now.
|
|
unexpected(this_file,
|
|
"intermod_traverse_goal_expr: bi_implication")
|
|
),
|
|
GoalExpr = shorthand(ShortHand)
|
|
).
|
|
|
|
:- pred intermod_traverse_list_of_goals(hlds_goals::in, hlds_goals::out,
|
|
bool::out, intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod_traverse_list_of_goals([], [], yes, !Info).
|
|
intermod_traverse_list_of_goals([Goal0 | Goals0], [Goal | Goals], !:DoWrite,
|
|
!Info) :-
|
|
intermod_traverse_goal(Goal0, Goal, !:DoWrite, !Info),
|
|
(
|
|
!.DoWrite = yes,
|
|
intermod_traverse_list_of_goals(Goals0, Goals, !:DoWrite, !Info)
|
|
;
|
|
!.DoWrite = no,
|
|
Goals = Goals0
|
|
).
|
|
|
|
:- pred intermod_traverse_cases(list(case)::in, list(case)::out, bool::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod_traverse_cases([], [], yes, !Info).
|
|
intermod_traverse_cases([Case0 | Cases0], [Case | Cases], !:DoWrite, !Info) :-
|
|
Case0 = case(MainConsId, OtherConsIds, Goal0),
|
|
intermod_traverse_goal(Goal0, Goal, !:DoWrite, !Info),
|
|
Case = case(MainConsId, OtherConsIds, Goal),
|
|
(
|
|
!.DoWrite = yes,
|
|
intermod_traverse_cases(Cases0, Cases, !:DoWrite, !Info)
|
|
;
|
|
!.DoWrite = no,
|
|
Cases = Cases0
|
|
).
|
|
|
|
% add_proc/4 tries to do what ever is necessary to ensure that the
|
|
% specified predicate will be exported, so that it can be called from
|
|
% clauses in the `.opt' file. If it can't, then it returns DoWrite = no,
|
|
% which will prevent the caller from being included in the `.opt' file.
|
|
%
|
|
% If a proc called within an exported proc is local, we need to add
|
|
% a declaration for the called proc to the .opt file. If a proc called
|
|
% within an exported proc is from a different module, we need to include
|
|
% an `:- import_module' declaration to import that module in the `.opt'
|
|
% file.
|
|
%
|
|
:- pred add_proc(pred_id::in, bool::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
add_proc(PredId, DoWrite, !Info) :-
|
|
( PredId = invalid_pred_id ->
|
|
% This will happen for type class instance methods defined using
|
|
% the clause syntax. Currently we can't handle intermodule
|
|
% optimization of those.
|
|
DoWrite = no
|
|
;
|
|
add_proc_2(PredId, DoWrite, !Info)
|
|
).
|
|
|
|
:- pred add_proc_2(pred_id::in, bool::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
add_proc_2(PredId, DoWrite, !Info) :-
|
|
intermod_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_import_status(PredInfo, Status),
|
|
ProcIds = pred_info_procids(PredInfo),
|
|
pred_info_get_markers(PredInfo, Markers),
|
|
(
|
|
% Calling compiler-generated procedures is fine; we don't need
|
|
% to output declarations for them to the `.opt' file, since they
|
|
% will be recreated every time anyway.
|
|
|
|
is_unify_or_compare_pred(PredInfo)
|
|
->
|
|
DoWrite = yes
|
|
;
|
|
% Don't write the caller to the `.opt' file if it calls a pred
|
|
% without mode or determinism decls, because we'd need to include
|
|
% the mode decls for the callee in the `.opt' file and (since
|
|
% writing the `.opt' file happens before mode inference) we can't
|
|
% do that because we don't know what the modes are.
|
|
%
|
|
% XXX This prevents intermodule optimizations in such cases,
|
|
% which is a pity.
|
|
|
|
(
|
|
check_marker(Markers, marker_infer_modes)
|
|
;
|
|
pred_info_get_procedures(PredInfo, Procs),
|
|
list.member(ProcId, ProcIds),
|
|
map.lookup(Procs, ProcId, ProcInfo),
|
|
proc_info_get_declared_determinism(ProcInfo, no)
|
|
)
|
|
->
|
|
DoWrite = no
|
|
;
|
|
% Goals which call impure predicates cannot be written due to
|
|
% limitations in mode analysis. The problem is that only head
|
|
% unifications are allowed to be reordered with impure goals.
|
|
%
|
|
% e.g
|
|
% p(A::in, B::in, C::out) :- impure foo(A, B, C).
|
|
% becomes
|
|
% p(HeadVar1, HeadVar2, HeadVar3) :-
|
|
% A = HeadVar1, B = HeadVar2, C = HeadVar3,
|
|
% impure foo(A, B, C).
|
|
%
|
|
% In the clauses written to `.opt' files, the head unifications
|
|
% are already expanded, and are expanded again when the `.opt' file
|
|
% is read in. The `C = HeadVar3' unification cannot be reordered
|
|
% with the impure goal, resulting in a mode error. Fixing this
|
|
% in mode analysis would be tricky.
|
|
% See tests/valid/impure_intermod.m.
|
|
%
|
|
% NOTE: the above restriction applies to user predicates. For
|
|
% the compiler generated mutable access predicates we can ensure
|
|
% that reordering is not necessary by construction, so it's safe
|
|
% to include them in .opt files.
|
|
|
|
pred_info_get_purity(PredInfo, purity_impure),
|
|
not check_marker(Markers, marker_mutable_access_pred)
|
|
->
|
|
DoWrite = no
|
|
;
|
|
% If a pred whose code we're going to put in the .opt file calls
|
|
% a predicate which is exported, then we don't need to do anything
|
|
% special.
|
|
|
|
(
|
|
Status = status_exported
|
|
;
|
|
Status = status_external(ExternalStatus),
|
|
status_is_exported(ExternalStatus) = yes
|
|
)
|
|
->
|
|
DoWrite = yes
|
|
;
|
|
% Declarations for class methods will be recreated from the class
|
|
% declaration in the `.opt' file. Declarations for local classes
|
|
% are always written to the `.opt' file.
|
|
|
|
pred_info_get_markers(PredInfo, Markers),
|
|
check_marker(Markers, marker_class_method)
|
|
->
|
|
DoWrite = yes
|
|
;
|
|
% If a pred whose code we're going to put in the `.opt' file calls
|
|
% a predicate which is local to that module, then we need to put
|
|
% the declaration for the called predicate in the `.opt' file.
|
|
|
|
import_status_to_write(Status)
|
|
->
|
|
DoWrite = yes,
|
|
intermod_info_get_pred_decls(!.Info, PredDecls0),
|
|
set.insert(PredDecls0, PredId, PredDecls),
|
|
intermod_info_set_pred_decls(PredDecls, !Info)
|
|
;
|
|
( Status = status_imported(_)
|
|
; Status = status_opt_imported
|
|
)
|
|
->
|
|
% Imported pred - add import for module.
|
|
|
|
DoWrite = yes,
|
|
PredModule = pred_info_module(PredInfo),
|
|
intermod_info_get_modules(!.Info, Modules0),
|
|
set.insert(Modules0, PredModule, Modules),
|
|
intermod_info_set_modules(Modules, !Info)
|
|
;
|
|
unexpected(this_file, "add_proc: unexpected status")
|
|
).
|
|
|
|
% Resolve overloading and module qualify everything in a unify_rhs.
|
|
% Fully module-qualify the right-hand-side of a unification.
|
|
% For function calls and higher-order terms, call add_proc
|
|
% so that the predicate or function will be exported if necessary.
|
|
%
|
|
:- pred module_qualify_unify_rhs(unify_rhs::in, unify_rhs::out, bool::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
module_qualify_unify_rhs(RHS0, RHS, DoWrite, !Info) :-
|
|
(
|
|
RHS0 = rhs_var(_),
|
|
RHS = RHS0,
|
|
DoWrite = yes
|
|
;
|
|
RHS0 = rhs_lambda_goal(Purity, HOGroundness, PorF, EvalMethod,
|
|
NonLocals, QuantVars, Modes, Detism, Goal0),
|
|
intermod_traverse_goal(Goal0, Goal, DoWrite, !Info),
|
|
RHS = rhs_lambda_goal(Purity, HOGroundness, PorF, EvalMethod,
|
|
NonLocals, QuantVars, Modes, Detism, Goal)
|
|
;
|
|
RHS0 = rhs_functor(Functor, _Exist, _Vars),
|
|
RHS = RHS0,
|
|
% Is this a higher-order predicate or higher-order function term?
|
|
( Functor = closure_cons(ShroudedPredProcId, _) ->
|
|
% Yes, the unification creates a higher-order term.
|
|
% Make sure that the predicate/function is exported.
|
|
|
|
proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
add_proc(PredId, DoWrite, !Info)
|
|
;
|
|
% It's an ordinary constructor, or a constant of a builtin type,
|
|
% so just leave it alone.
|
|
%
|
|
% Constructors are module qualified by post_typecheck.m.
|
|
%
|
|
% Function calls and higher-order function applications
|
|
% are transformed into ordinary calls and higher-order calls
|
|
% by post_typecheck.m, so they can't occur here.
|
|
|
|
DoWrite = yes
|
|
)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred gather_instances(intermod_info::in, intermod_info::out) is det.
|
|
|
|
gather_instances(!Info) :-
|
|
intermod_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_instance_table(ModuleInfo, Instances),
|
|
map.foldl(gather_instances_2(ModuleInfo), Instances, !Info).
|
|
|
|
:- pred gather_instances_2(module_info::in, class_id::in,
|
|
list(hlds_instance_defn)::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
gather_instances_2(ModuleInfo, ClassId, InstanceDefns, !Info) :-
|
|
list.foldl(gather_instances_3(ModuleInfo, ClassId), InstanceDefns, !Info).
|
|
|
|
:- pred gather_instances_3(module_info::in, class_id::in,
|
|
hlds_instance_defn::in, intermod_info::in, intermod_info::out) is det.
|
|
|
|
gather_instances_3(ModuleInfo, ClassId, InstanceDefn, !Info) :-
|
|
InstanceDefn = hlds_instance_defn(A, Status, C, D, E, Interface0,
|
|
MaybePredProcIds, H, I),
|
|
DefinedThisModule = status_defined_in_this_module(Status),
|
|
(
|
|
DefinedThisModule = yes,
|
|
|
|
% The bodies are always stripped from instance declarations
|
|
% before writing them to `int' files, so the full instance
|
|
% declaration should be written even for exported instances.
|
|
|
|
SaveInfo = !.Info,
|
|
(
|
|
Interface0 = instance_body_concrete(Methods0),
|
|
(
|
|
MaybePredProcIds = yes(ClassProcs),
|
|
GetPredId =
|
|
(pred(Proc::in, PredId::out) is det :-
|
|
Proc = hlds_class_proc(PredId, _)
|
|
),
|
|
list.map(GetPredId, ClassProcs, ClassPreds0),
|
|
|
|
% The interface is sorted on pred_id.
|
|
list.remove_adjacent_dups(ClassPreds0, ClassPreds),
|
|
assoc_list.from_corresponding_lists(ClassPreds, Methods0,
|
|
MethodAL)
|
|
;
|
|
MaybePredProcIds = no,
|
|
unexpected(this_file,
|
|
"gather_instances_3: method pred_proc_ids not filled in")
|
|
),
|
|
list.map_foldl(qualify_instance_method(ModuleInfo),
|
|
MethodAL, Methods, [], PredIds),
|
|
list.map_foldl(add_proc, PredIds, DoWriteMethodsList, !Info),
|
|
bool.and_list(DoWriteMethodsList, DoWriteMethods),
|
|
(
|
|
DoWriteMethods = yes,
|
|
Interface = instance_body_concrete(Methods)
|
|
;
|
|
DoWriteMethods = no,
|
|
|
|
% Write an abstract instance declaration if any of the methods
|
|
% cannot be written to the `.opt' file for any reason.
|
|
Interface = instance_body_abstract,
|
|
|
|
% Don't write declarations for any of the methods if one
|
|
% can't be written.
|
|
!:Info = SaveInfo
|
|
)
|
|
;
|
|
Interface0 = instance_body_abstract,
|
|
Interface = Interface0
|
|
),
|
|
(
|
|
% Don't write an abstract instance declaration
|
|
% if the declaration is already in the `.int' file.
|
|
(
|
|
Interface = instance_body_abstract
|
|
=>
|
|
status_is_exported(Status) = no
|
|
)
|
|
->
|
|
InstanceDefnToWrite = hlds_instance_defn(A, Status, C, D, E,
|
|
Interface, MaybePredProcIds, H, I),
|
|
intermod_info_get_instances(!.Info, Instances0),
|
|
intermod_info_set_instances(
|
|
[ClassId - InstanceDefnToWrite | Instances0], !Info)
|
|
;
|
|
true
|
|
)
|
|
;
|
|
DefinedThisModule = no
|
|
).
|
|
|
|
% Resolve overloading of instance methods before writing them
|
|
% to the `.opt' file.
|
|
%
|
|
:- pred qualify_instance_method(module_info::in,
|
|
pair(pred_id, instance_method)::in, instance_method::out,
|
|
list(pred_id)::in, list(pred_id)::out) is det.
|
|
|
|
qualify_instance_method(ModuleInfo, MethodCallPredId - InstanceMethod0,
|
|
InstanceMethod, PredIds0, PredIds) :-
|
|
module_info_pred_info(ModuleInfo, MethodCallPredId, MethodCallPredInfo),
|
|
pred_info_get_arg_types(MethodCallPredInfo, MethodCallTVarSet,
|
|
MethodCallExistQTVars, MethodCallArgTypes),
|
|
pred_info_get_head_type_params(MethodCallPredInfo,
|
|
MethodCallHeadTypeParams),
|
|
InstanceMethod0 = instance_method(PredOrFunc, MethodName,
|
|
InstanceMethodDefn0, MethodArity, MethodContext),
|
|
(
|
|
InstanceMethodDefn0 = instance_proc_def_name(InstanceMethodName0),
|
|
PredOrFunc = pf_function,
|
|
(
|
|
find_func_matching_instance_method(ModuleInfo, InstanceMethodName0,
|
|
MethodArity, MethodCallTVarSet, MethodCallExistQTVars,
|
|
MethodCallArgTypes, MethodCallHeadTypeParams, MethodContext,
|
|
MaybePredId, InstanceMethodName)
|
|
->
|
|
(
|
|
MaybePredId = yes(PredId),
|
|
PredIds = [PredId | PredIds0]
|
|
;
|
|
MaybePredId = no,
|
|
PredIds = PredIds0
|
|
),
|
|
InstanceMethodDefn = instance_proc_def_name(InstanceMethodName)
|
|
;
|
|
% This will force add_proc to return DoWrite = no.
|
|
PredId = invalid_pred_id,
|
|
PredIds = [PredId | PredIds0],
|
|
|
|
% We can just leave the method definition unchanged.
|
|
InstanceMethodDefn = InstanceMethodDefn0
|
|
)
|
|
;
|
|
InstanceMethodDefn0 = instance_proc_def_name(InstanceMethodName0),
|
|
PredOrFunc = pf_predicate,
|
|
init_markers(Markers),
|
|
resolve_pred_overloading(ModuleInfo, Markers, MethodCallTVarSet,
|
|
MethodCallExistQTVars, MethodCallArgTypes,
|
|
MethodCallHeadTypeParams, MethodContext,
|
|
InstanceMethodName0, InstanceMethodName, PredId),
|
|
PredIds = [PredId | PredIds0],
|
|
InstanceMethodDefn = instance_proc_def_name(InstanceMethodName)
|
|
;
|
|
InstanceMethodDefn0 = instance_proc_def_clauses(_ItemList),
|
|
% XXX For methods defined using this syntax it is a little tricky
|
|
% to write out the .opt files, so for now I've just disabled
|
|
% intermodule optimization for type class instance declarations
|
|
% using the new syntax.
|
|
%
|
|
% This will force add_proc to return DoWrite = no.
|
|
PredId = invalid_pred_id,
|
|
PredIds = [PredId | PredIds0],
|
|
% We can just leave the method definition unchanged.
|
|
InstanceMethodDefn = InstanceMethodDefn0
|
|
),
|
|
InstanceMethod = instance_method(PredOrFunc, MethodName,
|
|
InstanceMethodDefn, MethodArity, MethodContext).
|
|
|
|
% A `func(x/n) is y' method implementation can match an ordinary function,
|
|
% a field access function or a constructor. For now, if there are multiple
|
|
% possible matches, we don't write the instance method.
|
|
%
|
|
:- pred find_func_matching_instance_method(module_info::in, sym_name::in,
|
|
arity::in, tvarset::in, existq_tvars::in, list(mer_type)::in,
|
|
head_type_params::in, prog_context::in, maybe(pred_id)::out,
|
|
sym_name::out) is semidet.
|
|
|
|
find_func_matching_instance_method(ModuleInfo, InstanceMethodName0,
|
|
MethodArity, MethodCallTVarSet, MethodCallExistQTVars,
|
|
MethodCallArgTypes, MethodCallHeadTypeParams, MethodContext,
|
|
MaybePredId, InstanceMethodName) :-
|
|
module_info_get_ctor_field_table(ModuleInfo, CtorFieldTable),
|
|
(
|
|
is_field_access_function_name(ModuleInfo, InstanceMethodName0,
|
|
MethodArity, _, FieldName),
|
|
map.search(CtorFieldTable, FieldName, FieldDefns)
|
|
->
|
|
TypeCtors0 = list.map(
|
|
(func(FieldDefn) = TypeCtor :-
|
|
FieldDefn = hlds_ctor_field_defn(_, _, TypeCtor, _, _)
|
|
), FieldDefns)
|
|
;
|
|
TypeCtors0 = []
|
|
),
|
|
module_info_get_cons_table(ModuleInfo, Ctors),
|
|
(
|
|
ConsId = cons(InstanceMethodName0, MethodArity,
|
|
cons_id_dummy_type_ctor),
|
|
map.search(Ctors, ConsId, MatchingConstructors)
|
|
->
|
|
TypeCtors1 = list.map(
|
|
(func(ConsDefn) = TypeCtor :-
|
|
ConsDefn ^ cons_type_ctor = TypeCtor
|
|
), MatchingConstructors)
|
|
;
|
|
TypeCtors1 = []
|
|
),
|
|
TypeCtors = TypeCtors0 ++ TypeCtors1,
|
|
|
|
module_info_get_predicate_table(ModuleInfo, PredicateTable),
|
|
(
|
|
predicate_table_search_func_sym_arity(PredicateTable,
|
|
may_be_partially_qualified, InstanceMethodName0,
|
|
MethodArity, PredIds),
|
|
find_matching_pred_id(ModuleInfo, PredIds, MethodCallTVarSet,
|
|
MethodCallExistQTVars, MethodCallArgTypes,
|
|
MethodCallHeadTypeParams, no, MethodContext,
|
|
PredId, InstanceMethodFuncName)
|
|
->
|
|
TypeCtors = [],
|
|
MaybePredId = yes(PredId),
|
|
InstanceMethodName = InstanceMethodFuncName
|
|
;
|
|
TypeCtors = [TheTypeCtor],
|
|
MaybePredId = no,
|
|
( TheTypeCtor = type_ctor(qualified(TypeModule, _), _) ->
|
|
UnqualMethodName = unqualify_name(InstanceMethodName0),
|
|
InstanceMethodName = qualified(TypeModule, UnqualMethodName)
|
|
;
|
|
unexpected(this_file, "unqualified type_ctor in " ++
|
|
"hlds_cons_defn or hlds_ctor_field_defn")
|
|
)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred gather_types(intermod_info::in, intermod_info::out) is det.
|
|
|
|
gather_types(!Info) :-
|
|
intermod_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_type_table(ModuleInfo, TypeTable),
|
|
foldl_over_type_ctor_defns(gather_types_2, TypeTable, !Info).
|
|
|
|
:- pred gather_types_2(type_ctor::in, hlds_type_defn::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
gather_types_2(TypeCtor, TypeDefn0, !Info) :-
|
|
intermod_info_get_module_info(!.Info, ModuleInfo),
|
|
module_info_get_name(ModuleInfo, ModuleName),
|
|
( should_write_type(ModuleName, TypeCtor, TypeDefn0) ->
|
|
hlds_data.get_type_defn_body(TypeDefn0, TypeBody0),
|
|
(
|
|
TypeBody0 = hlds_du_type(Ctors, Tags, CheaperTagTest, Enum,
|
|
MaybeUserEqComp0, ReservedTag, ReservedAddr, MaybeForeign0),
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.get_target(Globals, Target),
|
|
|
|
% Note that we don't resolve overloading for the definitions
|
|
% which won't be used on this back-end, because their unification
|
|
% and comparison predicates have not been typechecked. They are
|
|
% only written to the `.opt' it can be handy when building
|
|
% against a workspace for the other definitions to be present
|
|
% (e.g. when testing compiling a module to IL when the workspace
|
|
% was compiled to C).
|
|
% XXX The above sentence doesn't make sense, and never did
|
|
% (even in the first CVS version in which it appears).
|
|
|
|
(
|
|
MaybeForeign0 = yes(ForeignTypeBody0),
|
|
have_foreign_type_for_backend(Target, ForeignTypeBody0, yes)
|
|
->
|
|
% The header code must be written since it could be used
|
|
% by the foreign type.
|
|
intermod_info_set_write_header(!Info),
|
|
resolve_foreign_type_body_overloading(ModuleInfo, TypeCtor,
|
|
ForeignTypeBody0, ForeignTypeBody, !Info),
|
|
MaybeForeign = yes(ForeignTypeBody),
|
|
MaybeUserEqComp = MaybeUserEqComp0
|
|
;
|
|
resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
|
|
MaybeUserEqComp0, MaybeUserEqComp, !Info),
|
|
MaybeForeign = MaybeForeign0
|
|
),
|
|
TypeBody = hlds_du_type(Ctors, Tags, CheaperTagTest, Enum,
|
|
MaybeUserEqComp, ReservedTag, ReservedAddr, MaybeForeign),
|
|
hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn)
|
|
;
|
|
TypeBody0 = hlds_foreign_type(ForeignTypeBody0),
|
|
% The header code must be written since it could be used
|
|
% by the foreign type.
|
|
intermod_info_set_write_header(!Info),
|
|
resolve_foreign_type_body_overloading(ModuleInfo, TypeCtor,
|
|
ForeignTypeBody0, ForeignTypeBody, !Info),
|
|
TypeBody = hlds_foreign_type(ForeignTypeBody),
|
|
hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn)
|
|
;
|
|
( TypeBody0 = hlds_eqv_type(_)
|
|
; TypeBody0 = hlds_solver_type(_, _)
|
|
; TypeBody0 = hlds_abstract_type(_)
|
|
),
|
|
TypeDefn = TypeDefn0
|
|
),
|
|
intermod_info_get_types(!.Info, Types0),
|
|
intermod_info_set_types([TypeCtor - TypeDefn | Types0], !Info)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred resolve_foreign_type_body_overloading(module_info::in,
|
|
type_ctor::in, foreign_type_body::in, foreign_type_body::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
resolve_foreign_type_body_overloading(ModuleInfo, TypeCtor,
|
|
foreign_type_body(MaybeIL0, MaybeC0, MaybeJava0, MaybeErlang0),
|
|
foreign_type_body(MaybeIL, MaybeC, MaybeJava, MaybeErlang),
|
|
!Info) :-
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.get_target(Globals, Target),
|
|
|
|
% Note that we don't resolve overloading for the foreign definitions
|
|
% which won't be used on this back-end, because their unification and
|
|
% comparison predicates have not been typechecked. They are only written
|
|
% to the `.opt' it can be handy when building against a workspace
|
|
% for the other definitions to be present (e.g. when testing compiling
|
|
% a module to IL when the workspace was compiled to C).
|
|
|
|
(
|
|
( Target = target_c
|
|
; Target = target_asm
|
|
; Target = target_x86_64
|
|
; Target = target_erlang
|
|
),
|
|
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
|
|
MaybeC0, MaybeC, !Info)
|
|
;
|
|
( Target = target_il
|
|
; Target = target_java
|
|
),
|
|
MaybeC = MaybeC0
|
|
),
|
|
(
|
|
Target = target_il,
|
|
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
|
|
MaybeIL0, MaybeIL, !Info)
|
|
;
|
|
( Target = target_c
|
|
; Target = target_asm
|
|
; Target = target_java
|
|
; Target = target_x86_64
|
|
; Target = target_erlang
|
|
),
|
|
MaybeIL = MaybeIL0
|
|
),
|
|
(
|
|
Target = target_java,
|
|
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
|
|
MaybeJava0, MaybeJava, !Info)
|
|
;
|
|
( Target = target_c
|
|
; Target = target_asm
|
|
; Target = target_il
|
|
; Target = target_x86_64
|
|
; Target = target_erlang
|
|
),
|
|
MaybeJava = MaybeJava0
|
|
),
|
|
(
|
|
Target = target_erlang,
|
|
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
|
|
MaybeErlang0, MaybeErlang, !Info)
|
|
;
|
|
( Target = target_c
|
|
; Target = target_asm
|
|
; Target = target_il
|
|
; Target = target_x86_64
|
|
; Target = target_java
|
|
),
|
|
MaybeErlang = MaybeErlang0
|
|
).
|
|
|
|
:- pred resolve_foreign_type_body_overloading_2(module_info::in, type_ctor::in,
|
|
foreign_type_lang_body(T)::in, foreign_type_lang_body(T)::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
resolve_foreign_type_body_overloading_2(_, _, no, no, !Info).
|
|
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
|
|
yes(foreign_type_lang_data(Body, MaybeUserEqComp0, Assertions)),
|
|
yes(foreign_type_lang_data(Body, MaybeUserEqComp, Assertions)),
|
|
!Info) :-
|
|
resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
|
|
MaybeUserEqComp0, MaybeUserEqComp, !Info).
|
|
|
|
:- pred resolve_unify_compare_overloading(module_info::in,
|
|
type_ctor::in, maybe(unify_compare)::in, maybe(unify_compare)::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
resolve_unify_compare_overloading(_, _, no, no, !Info).
|
|
resolve_unify_compare_overloading(_, _,
|
|
yes(abstract_noncanonical_type(IsSolverType)),
|
|
yes(abstract_noncanonical_type(IsSolverType)), !Info).
|
|
resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
|
|
yes(unify_compare(MaybeUserEq0, MaybeUserCompare0)),
|
|
yes(unify_compare(MaybeUserEq, MaybeUserCompare)), !Info) :-
|
|
resolve_user_special_pred_overloading(ModuleInfo,
|
|
spec_pred_unify, TypeCtor, MaybeUserEq0, MaybeUserEq, !Info),
|
|
resolve_user_special_pred_overloading(ModuleInfo,
|
|
spec_pred_compare, TypeCtor, MaybeUserCompare0, MaybeUserCompare,
|
|
!Info).
|
|
|
|
:- pred resolve_user_special_pred_overloading(module_info::in,
|
|
special_pred_id::in, type_ctor::in, maybe(sym_name)::in,
|
|
maybe(sym_name)::out, intermod_info::in, intermod_info::out) is det.
|
|
|
|
resolve_user_special_pred_overloading(_, _, _, no, no, !Info).
|
|
resolve_user_special_pred_overloading(ModuleInfo, SpecialId,
|
|
TypeCtor, yes(Pred0), yes(Pred), !Info) :-
|
|
module_info_get_special_pred_map(ModuleInfo, SpecialPreds),
|
|
map.lookup(SpecialPreds, SpecialId - TypeCtor, UnifyPredId),
|
|
module_info_pred_info(ModuleInfo, UnifyPredId, UnifyPredInfo),
|
|
pred_info_get_arg_types(UnifyPredInfo, TVarSet, ExistQVars, ArgTypes),
|
|
pred_info_get_head_type_params(UnifyPredInfo, HeadTypeParams),
|
|
init_markers(Markers0),
|
|
add_marker(marker_calls_are_fully_qualified, Markers0, Markers),
|
|
pred_info_get_context(UnifyPredInfo, Context),
|
|
resolve_pred_overloading(ModuleInfo, Markers, TVarSet, ExistQVars,
|
|
ArgTypes, HeadTypeParams, Context, Pred0, Pred, UserEqPredId),
|
|
add_proc(UserEqPredId, _, !Info).
|
|
|
|
:- pred should_write_type(module_name::in, type_ctor::in, hlds_type_defn::in)
|
|
is semidet.
|
|
|
|
should_write_type(ModuleName, TypeCtor, TypeDefn) :-
|
|
hlds_data.get_type_defn_status(TypeDefn, ImportStatus),
|
|
TypeCtor = type_ctor(Name, _Arity),
|
|
Name = qualified(ModuleName, _),
|
|
import_status_to_write(ImportStatus).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Output module imports, types, modes, insts and predicates.
|
|
%
|
|
:- pred write_intermod_info(intermod_info::in, io::di, io::uo) is det.
|
|
|
|
write_intermod_info(IntermodInfo, !IO) :-
|
|
intermod_info_get_module_info(IntermodInfo, ModuleInfo),
|
|
module_info_get_name(ModuleInfo, ModuleName),
|
|
io.write_string(":- module ", !IO),
|
|
mercury_output_bracketed_sym_name(ModuleName, !IO),
|
|
io.write_string(".\n", !IO),
|
|
|
|
intermod_info_get_preds(IntermodInfo, Preds),
|
|
intermod_info_get_pred_decls(IntermodInfo, PredDecls),
|
|
intermod_info_get_instances(IntermodInfo, Instances),
|
|
(
|
|
% If none of these item types need writing, nothing else
|
|
% needs to be written.
|
|
|
|
set.empty(Preds),
|
|
set.empty(PredDecls),
|
|
Instances = [],
|
|
module_info_get_type_table(ModuleInfo, TypeTable),
|
|
get_all_type_ctor_defns(TypeTable, TypeCtorsDefns),
|
|
\+ (
|
|
list.member(_TypeCtor - TypeDefn, TypeCtorsDefns),
|
|
hlds_data.get_type_defn_status(TypeDefn, Status),
|
|
( Status = status_abstract_exported
|
|
; Status = status_exported_to_submodules
|
|
)
|
|
)
|
|
->
|
|
true
|
|
;
|
|
write_intermod_info_body(IntermodInfo, !IO)
|
|
).
|
|
|
|
:- pred write_intermod_info_body(intermod_info::in, io::di, io::uo) is det.
|
|
|
|
write_intermod_info_body(IntermodInfo, !IO) :-
|
|
IntermodInfo = intermod_info(_, Preds0, PredDecls0, Instances, Types,
|
|
ModuleInfo, WriteHeader, _, _),
|
|
set.to_sorted_list(Preds0, Preds),
|
|
set.to_sorted_list(PredDecls0, PredDecls),
|
|
|
|
module_info_get_imported_module_specifiers(ModuleInfo, Modules0),
|
|
set.to_sorted_list(Modules0, Modules),
|
|
(
|
|
Modules = [_ | _],
|
|
% XXX Modules could and should be reduced to the set of modules
|
|
% that are actually needed by the items being written.
|
|
io.write_string(":- use_module ", !IO),
|
|
write_modules(Modules, !IO)
|
|
;
|
|
Modules = []
|
|
),
|
|
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
OutInfo0 = init_hlds_out_info(Globals),
|
|
|
|
% We don't want to output line numbers in the .opt files,
|
|
% since that causes spurious changes to the .opt files
|
|
% when you make trivial changes (e.g. add comments) to the source files.
|
|
MercInfo0 = OutInfo0 ^ hoi_mercury_to_mercury,
|
|
MercInfo = merc_out_info_disable_line_numbers(MercInfo0),
|
|
OutInfo = OutInfo0 ^ hoi_mercury_to_mercury := MercInfo,
|
|
|
|
write_types(OutInfo, Types, !IO),
|
|
write_insts(OutInfo, ModuleInfo, !IO),
|
|
write_modes(OutInfo, ModuleInfo, !IO),
|
|
write_classes(OutInfo, ModuleInfo, !IO),
|
|
write_instances(OutInfo, Instances, !IO),
|
|
|
|
% Disable verbose dumping of clauses.
|
|
OutInfoForPreds = OutInfo ^ hoi_dump_hlds_options := "",
|
|
(
|
|
WriteHeader = yes,
|
|
module_info_get_foreign_import_module(ModuleInfo, RevForeignImports),
|
|
ForeignImports = list.reverse(RevForeignImports),
|
|
|
|
list.foldl(
|
|
(pred(ForeignImport::in, IO0::di, IO::uo) is det :-
|
|
ForeignImport = foreign_import_module_info(Lang, Import, _),
|
|
mercury_output_pragma_foreign_import_module(Lang, Import,
|
|
IO0, IO)
|
|
), ForeignImports, !IO)
|
|
;
|
|
WriteHeader = no
|
|
),
|
|
write_pred_decls(ModuleInfo, PredDecls, !IO),
|
|
write_preds(OutInfoForPreds, ModuleInfo, Preds, !IO).
|
|
|
|
:- pred write_modules(list(module_name)::in, io::di, io::uo) is det.
|
|
|
|
write_modules([], !IO).
|
|
write_modules([Module | Rest], !IO) :-
|
|
mercury_output_bracketed_sym_name(Module, !IO),
|
|
(
|
|
Rest = [],
|
|
io.write_string(".\n", !IO)
|
|
;
|
|
Rest = [_ | _],
|
|
io.write_string(", ", !IO),
|
|
write_modules(Rest, !IO)
|
|
).
|
|
|
|
:- pred write_types(hlds_out_info::in,
|
|
assoc_list(type_ctor, hlds_type_defn)::in, io::di, io::uo) is det.
|
|
|
|
write_types(OutInfo, Types, !IO) :-
|
|
list.foldl(write_type(OutInfo), Types, !IO).
|
|
|
|
:- pred write_type(hlds_out_info::in, pair(type_ctor, hlds_type_defn)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
write_type(OutInfo, TypeCtor - TypeDefn, !IO) :-
|
|
hlds_data.get_type_defn_tvarset(TypeDefn, VarSet),
|
|
hlds_data.get_type_defn_tparams(TypeDefn, Args),
|
|
hlds_data.get_type_defn_body(TypeDefn, Body),
|
|
hlds_data.get_type_defn_context(TypeDefn, Context),
|
|
TypeCtor = type_ctor(Name, Arity),
|
|
(
|
|
Body = hlds_du_type(Ctors, _, _, _, MaybeUserEqComp, _, _, _),
|
|
TypeBody = parse_tree_du_type(Ctors, MaybeUserEqComp)
|
|
;
|
|
Body = hlds_eqv_type(EqvType),
|
|
TypeBody = parse_tree_eqv_type(EqvType)
|
|
;
|
|
Body = hlds_abstract_type(IsSolverType),
|
|
TypeBody = parse_tree_abstract_type(IsSolverType)
|
|
;
|
|
Body = hlds_foreign_type(_),
|
|
TypeBody = parse_tree_abstract_type(non_solver_type)
|
|
;
|
|
Body = hlds_solver_type(SolverTypeDetails, MaybeUserEqComp),
|
|
TypeBody = parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp)
|
|
),
|
|
MainItemTypeDefn = item_type_defn_info(VarSet, Name, Args, TypeBody,
|
|
cond_true, Context, -1),
|
|
MainItem = item_type_defn(MainItemTypeDefn),
|
|
MercInfo = OutInfo ^ hoi_mercury_to_mercury,
|
|
mercury_output_item(MercInfo, MainItem, !IO),
|
|
(
|
|
( Body = hlds_foreign_type(ForeignTypeBody)
|
|
; Body ^ du_type_is_foreign_type = yes(ForeignTypeBody)
|
|
),
|
|
ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC, MaybeJava,
|
|
MaybeErlang)
|
|
->
|
|
(
|
|
MaybeIL = yes(DataIL),
|
|
DataIL = foreign_type_lang_data(ILForeignType, ILMaybeUserEqComp,
|
|
AssertionsIL),
|
|
ILItemTypeDefn = item_type_defn_info(VarSet, Name, Args,
|
|
parse_tree_foreign_type(il(ILForeignType),
|
|
ILMaybeUserEqComp, AssertionsIL),
|
|
cond_true, Context, -1),
|
|
ILItem = item_type_defn(ILItemTypeDefn),
|
|
mercury_output_item(MercInfo, ILItem, !IO)
|
|
;
|
|
MaybeIL = no
|
|
),
|
|
(
|
|
MaybeC = yes(DataC),
|
|
DataC = foreign_type_lang_data(CForeignType,
|
|
CMaybeUserEqComp, AssertionsC),
|
|
CItemTypeDefn = item_type_defn_info(VarSet, Name, Args,
|
|
parse_tree_foreign_type(c(CForeignType),
|
|
CMaybeUserEqComp, AssertionsC),
|
|
cond_true, Context, -1),
|
|
CItem = item_type_defn(CItemTypeDefn),
|
|
mercury_output_item(MercInfo, CItem, !IO)
|
|
;
|
|
MaybeC = no
|
|
),
|
|
(
|
|
MaybeJava = yes(DataJava),
|
|
DataJava = foreign_type_lang_data(JavaForeignType,
|
|
JavaMaybeUserEqComp, AssertionsJava),
|
|
JavaItemTypeDefn = item_type_defn_info(VarSet, Name, Args,
|
|
parse_tree_foreign_type(java(JavaForeignType),
|
|
JavaMaybeUserEqComp, AssertionsJava),
|
|
cond_true, Context, -1),
|
|
JavaItem = item_type_defn(JavaItemTypeDefn),
|
|
mercury_output_item(MercInfo, JavaItem, !IO)
|
|
;
|
|
MaybeJava = no
|
|
),
|
|
(
|
|
MaybeErlang = yes(DataErlang),
|
|
DataErlang = foreign_type_lang_data(ErlangForeignType,
|
|
ErlangMaybeUserEqComp, AssertionsErlang),
|
|
ErlangItemTypeDefn = item_type_defn_info(VarSet, Name, Args,
|
|
parse_tree_foreign_type(erlang(ErlangForeignType),
|
|
ErlangMaybeUserEqComp, AssertionsErlang),
|
|
cond_true, Context, -1),
|
|
ErlangItem = item_type_defn(ErlangItemTypeDefn),
|
|
mercury_output_item(MercInfo, ErlangItem, !IO)
|
|
;
|
|
MaybeErlang = no
|
|
)
|
|
;
|
|
true
|
|
),
|
|
(
|
|
ReservedTag = Body ^ du_type_reserved_tag,
|
|
ReservedTag = uses_reserved_tag
|
|
->
|
|
% The pragma_origin doesn't matter here.
|
|
ReserveItemPragma = item_pragma_info(user,
|
|
pragma_reserve_tag(Name, Arity), Context, -1),
|
|
ReserveItem = item_pragma(ReserveItemPragma),
|
|
mercury_output_item(MercInfo, ReserveItem, !IO)
|
|
;
|
|
true
|
|
),
|
|
(
|
|
Body = hlds_du_type(_, ConsTagVals, _, DuTypeKind, _, _, _, _),
|
|
DuTypeKind = du_type_kind_foreign_enum(Lang)
|
|
->
|
|
map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [],
|
|
ForeignEnumVals),
|
|
Pragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals),
|
|
ForeignItemPragma = item_pragma_info(user, Pragma, Context, -1),
|
|
ForeignItem = item_pragma(ForeignItemPragma),
|
|
mercury_output_item(MercInfo, ForeignItem, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred gather_foreign_enum_value_pair(cons_id::in, cons_tag::in,
|
|
assoc_list(sym_name, string)::in, assoc_list(sym_name, string)::out)
|
|
is det.
|
|
|
|
gather_foreign_enum_value_pair(ConsId, ConsTag, !Values) :-
|
|
( ConsId = cons(SymName0, 0, _) ->
|
|
SymName = SymName0
|
|
;
|
|
unexpected(this_file, "expected enumeration constant")
|
|
),
|
|
( ConsTag = foreign_tag(_ForeignLang, ForeignTag0) ->
|
|
ForeignTag = ForeignTag0
|
|
;
|
|
unexpected(this_file, "expected foreign tag")
|
|
),
|
|
!:Values = [SymName - ForeignTag | !.Values].
|
|
|
|
:- pred write_modes(hlds_out_info::in, module_info::in, io::di, io::uo) is det.
|
|
|
|
write_modes(OutInfo, ModuleInfo, !IO) :-
|
|
module_info_get_name(ModuleInfo, ModuleName),
|
|
module_info_get_mode_table(ModuleInfo, Modes),
|
|
mode_table_get_mode_defns(Modes, ModeDefns),
|
|
map.foldl(write_mode(OutInfo, ModuleName), ModeDefns, !IO).
|
|
|
|
:- pred write_mode(hlds_out_info::in, module_name::in, mode_id::in,
|
|
hlds_mode_defn::in, io::di, io::uo) is det.
|
|
|
|
write_mode(OutInfo, ModuleName, ModeId, ModeDefn, !IO) :-
|
|
ModeId = mode_id(SymName, _Arity),
|
|
ModeDefn = hlds_mode_defn(Varset, Args, eqv_mode(Mode), Context,
|
|
ImportStatus),
|
|
(
|
|
SymName = qualified(ModuleName, _),
|
|
import_status_to_write(ImportStatus)
|
|
->
|
|
ItemModeDefn = item_mode_defn_info(Varset, SymName, Args,
|
|
eqv_mode(Mode), cond_true, Context, -1),
|
|
Item = item_mode_defn(ItemModeDefn),
|
|
MercInfo = OutInfo ^ hoi_mercury_to_mercury,
|
|
mercury_output_item(MercInfo, Item, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred write_insts(hlds_out_info::in, module_info::in, io::di, io::uo) is det.
|
|
|
|
write_insts(OutInfo, ModuleInfo, !IO) :-
|
|
module_info_get_name(ModuleInfo, ModuleName),
|
|
module_info_get_inst_table(ModuleInfo, Insts),
|
|
inst_table_get_user_insts(Insts, UserInsts),
|
|
user_inst_table_get_inst_defns(UserInsts, InstDefns),
|
|
map.foldl(write_inst(OutInfo, ModuleName), InstDefns, !IO).
|
|
|
|
:- pred write_inst(hlds_out_info::in, module_name::in, inst_id::in,
|
|
hlds_inst_defn::in, io::di, io::uo) is det.
|
|
|
|
write_inst(OutInfo, ModuleName, InstId, InstDefn, !IO) :-
|
|
InstId = inst_id(SymName, _Arity),
|
|
InstDefn = hlds_inst_defn(Varset, Args, Body, Context, ImportStatus),
|
|
(
|
|
SymName = qualified(ModuleName, _),
|
|
import_status_to_write(ImportStatus)
|
|
->
|
|
(
|
|
Body = eqv_inst(Inst2),
|
|
InstBody = eqv_inst(Inst2)
|
|
;
|
|
Body = abstract_inst,
|
|
InstBody = abstract_inst
|
|
),
|
|
ItemInstDefn = item_inst_defn_info(Varset, SymName, Args, InstBody,
|
|
cond_true, Context, -1),
|
|
Item = item_inst_defn(ItemInstDefn),
|
|
MercInfo = OutInfo ^ hoi_mercury_to_mercury,
|
|
mercury_output_item(MercInfo, Item, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred write_classes(hlds_out_info::in, module_info::in,
|
|
io::di, io::uo) is det.
|
|
|
|
write_classes(OutInfo, ModuleInfo, !IO) :-
|
|
module_info_get_name(ModuleInfo, ModuleName),
|
|
module_info_get_class_table(ModuleInfo, Classes),
|
|
map.foldl(write_class(OutInfo, ModuleName), Classes, !IO).
|
|
|
|
:- pred write_class(hlds_out_info::in, module_name::in, class_id::in,
|
|
hlds_class_defn::in, io::di, io::uo) is det.
|
|
|
|
write_class(OutInfo, ModuleName, ClassId, ClassDefn, !IO) :-
|
|
ClassDefn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
|
|
_Ancestors, TVars, _Kinds, Interface, _HLDSClassInterface, TVarSet,
|
|
Context),
|
|
ClassId = class_id(QualifiedClassName, _),
|
|
(
|
|
QualifiedClassName = qualified(ModuleName, _),
|
|
import_status_to_write(ImportStatus)
|
|
->
|
|
FunDeps = list.map(unmake_hlds_class_fundep(TVars), HLDSFunDeps),
|
|
ItemTypeClass = item_typeclass_info(Constraints, FunDeps,
|
|
QualifiedClassName, TVars, Interface, TVarSet, Context, -1),
|
|
Item = item_typeclass(ItemTypeClass),
|
|
MercInfo = OutInfo ^ hoi_mercury_to_mercury,
|
|
mercury_output_item(MercInfo, Item, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- func unmake_hlds_class_fundep(list(tvar), hlds_class_fundep) = prog_fundep.
|
|
|
|
unmake_hlds_class_fundep(TVars, fundep(Domain0, Range0))
|
|
= fundep(Domain, Range) :-
|
|
Domain = unmake_hlds_class_fundep_2(TVars, Domain0),
|
|
Range = unmake_hlds_class_fundep_2(TVars, Range0).
|
|
|
|
:- func unmake_hlds_class_fundep_2(list(tvar), set(hlds_class_argpos)) =
|
|
list(tvar).
|
|
|
|
unmake_hlds_class_fundep_2(TVars, Set) = solutions.solutions(P) :-
|
|
P = (pred(TVar::out) is nondet :-
|
|
set.member(N, Set),
|
|
TVar = list.index1_det(TVars, N)
|
|
).
|
|
|
|
:- pred write_instances(hlds_out_info::in,
|
|
assoc_list(class_id, hlds_instance_defn)::in, io::di, io::uo) is det.
|
|
|
|
write_instances(OutInfo, Instances, !IO) :-
|
|
list.foldl(write_instance(OutInfo), Instances, !IO).
|
|
|
|
:- pred write_instance(hlds_out_info::in,
|
|
pair(class_id, hlds_instance_defn)::in, io::di, io::uo) is det.
|
|
|
|
write_instance(OutInfo, ClassId - InstanceDefn, !IO) :-
|
|
InstanceDefn = hlds_instance_defn(ModuleName, _, Context, Constraints,
|
|
Types, Body, _, TVarSet, _),
|
|
ClassId = class_id(ClassName, _),
|
|
ItemInstance = item_instance_info(Constraints, ClassName, Types, Body,
|
|
TVarSet, ModuleName, Context, -1),
|
|
Item = item_instance(ItemInstance),
|
|
MercInfo = OutInfo ^ hoi_mercury_to_mercury,
|
|
mercury_output_item(MercInfo, Item, !IO).
|
|
|
|
% We need to write all the declarations for local predicates so
|
|
% the procedure labels for the C code are calculated correctly.
|
|
%
|
|
:- pred write_pred_decls(module_info::in, list(pred_id)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
write_pred_decls(_, [], !IO).
|
|
write_pred_decls(ModuleInfo, [PredId | PredIds], !IO) :-
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
Module = pred_info_module(PredInfo),
|
|
Name = pred_info_name(PredInfo),
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
pred_info_get_arg_types(PredInfo, TVarSet, ExistQVars, ArgTypes),
|
|
pred_info_get_context(PredInfo, Context),
|
|
pred_info_get_purity(PredInfo, Purity),
|
|
pred_info_get_class_context(PredInfo, ClassContext),
|
|
pred_info_get_goal_type(PredInfo, GoalType),
|
|
(
|
|
GoalType = goal_type_foreign,
|
|
% For foreign code goals we can't append variable numbers to type
|
|
% variables in the predicate declaration because the foreign code
|
|
% may contain references to variables such as `TypeInfo_for_T'
|
|
% which will break if `T' is written as `T_1' in the pred declaration.
|
|
AppendVarNums = no
|
|
;
|
|
GoalType = goal_type_clause_and_foreign,
|
|
% Because pragmas may be present, we treat this case like
|
|
% pragmas above.
|
|
AppendVarNums = no
|
|
;
|
|
GoalType = goal_type_clause,
|
|
AppendVarNums = yes
|
|
;
|
|
GoalType = goal_type_promise(_),
|
|
AppendVarNums = yes
|
|
;
|
|
GoalType = goal_type_none,
|
|
AppendVarNums = yes
|
|
),
|
|
(
|
|
PredOrFunc = pf_predicate,
|
|
mercury_output_pred_type(TVarSet, ExistQVars, qualified(Module, Name),
|
|
ArgTypes, no, Purity, ClassContext, Context, AppendVarNums, !IO)
|
|
;
|
|
PredOrFunc = pf_function,
|
|
pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType),
|
|
mercury_output_func_type(TVarSet, ExistQVars, qualified(Module, Name),
|
|
FuncArgTypes, FuncRetType, no, Purity, ClassContext, Context,
|
|
AppendVarNums, !IO)
|
|
),
|
|
pred_info_get_procedures(PredInfo, Procs),
|
|
ProcIds = pred_info_procids(PredInfo),
|
|
% Make sure the mode declarations go out in the same order
|
|
% they came in, so that the all the modes get the same proc_id
|
|
% in the importing modules.
|
|
CompareProcId =
|
|
(pred(ProcId1::in, ProcId2::in, Result::out) is det :-
|
|
proc_id_to_int(ProcId1, ProcInt1),
|
|
proc_id_to_int(ProcId2, ProcInt2),
|
|
compare(Result, ProcInt1, ProcInt2)
|
|
),
|
|
list.sort(CompareProcId, ProcIds, SortedProcIds),
|
|
write_pred_modes(Procs, qualified(Module, Name), PredOrFunc, SortedProcIds,
|
|
!IO),
|
|
write_pragmas(PredInfo, !IO),
|
|
write_type_spec_pragmas(ModuleInfo, PredId, !IO),
|
|
write_pred_decls(ModuleInfo, PredIds, !IO).
|
|
|
|
:- pred write_pred_modes(map(proc_id, proc_info)::in, sym_name::in,
|
|
pred_or_func::in, list(proc_id)::in, io::di, io::uo) is det.
|
|
|
|
write_pred_modes(_, _, _, [], !IO).
|
|
write_pred_modes(Procs, SymName, PredOrFunc, [ProcId | ProcIds], !IO) :-
|
|
map.lookup(Procs, ProcId, ProcInfo),
|
|
proc_info_get_maybe_declared_argmodes(ProcInfo, MaybeArgModes),
|
|
proc_info_get_declared_determinism(ProcInfo, MaybeDetism),
|
|
(
|
|
MaybeArgModes = yes(ArgModes0),
|
|
MaybeDetism = yes(Detism0)
|
|
->
|
|
ArgModes = ArgModes0,
|
|
Detism = Detism0
|
|
;
|
|
unexpected(this_file,
|
|
"write_pred_modes: attempt to write undeclared mode")
|
|
),
|
|
proc_info_get_context(ProcInfo, Context),
|
|
varset.init(Varset),
|
|
(
|
|
PredOrFunc = pf_function,
|
|
pred_args_to_func_args(ArgModes, FuncArgModes, FuncRetMode),
|
|
mercury_output_func_mode_decl(Varset, SymName,
|
|
FuncArgModes, FuncRetMode, yes(Detism), Context, !IO)
|
|
;
|
|
PredOrFunc = pf_predicate,
|
|
mercury_output_pred_mode_decl(Varset, SymName, ArgModes,
|
|
yes(Detism), Context, !IO)
|
|
),
|
|
write_pred_modes(Procs, SymName, PredOrFunc, ProcIds, !IO).
|
|
|
|
:- pred write_preds(hlds_out_info::in, module_info::in, list(pred_id)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
write_preds(_, _, [], !IO).
|
|
write_preds(OutInfo, ModuleInfo, [PredId | PredIds], !IO) :-
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
Module = pred_info_module(PredInfo),
|
|
Name = pred_info_name(PredInfo),
|
|
SymName = qualified(Module, Name),
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
write_pragmas(PredInfo, !IO),
|
|
% The type specialization pragmas for exported preds should
|
|
% already be in the interface file.
|
|
|
|
pred_info_get_clauses_info(PredInfo, ClausesInfo),
|
|
clauses_info_get_varset(ClausesInfo, VarSet),
|
|
clauses_info_get_headvar_list(ClausesInfo, HeadVars),
|
|
clauses_info_get_clauses_rep(ClausesInfo, ClausesRep, _ItemNumbers),
|
|
clauses_info_get_vartypes(ClausesInfo, VarTypes),
|
|
get_clause_list(ClausesRep, Clauses),
|
|
|
|
( pred_info_get_goal_type(PredInfo, goal_type_promise(PromiseType)) ->
|
|
( Clauses = [Clause] ->
|
|
hlds_out.write_promise(OutInfo, PromiseType, 0, ModuleInfo,
|
|
PredId, VarSet, no, HeadVars, PredOrFunc, Clause,
|
|
no_varset_vartypes, !IO)
|
|
;
|
|
unexpected(this_file,
|
|
"write_preds: assertion not a single clause.")
|
|
)
|
|
;
|
|
pred_info_get_typevarset(PredInfo, TypeVarset),
|
|
MaybeVarTypes = varset_vartypes(TypeVarset, VarTypes),
|
|
list.foldl(intermod_write_clause(OutInfo, ModuleInfo, PredId, VarSet,
|
|
HeadVars, PredOrFunc, SymName, MaybeVarTypes), Clauses, !IO)
|
|
),
|
|
write_preds(OutInfo, ModuleInfo, PredIds, !IO).
|
|
|
|
:- pred intermod_write_clause(hlds_out_info::in, module_info::in, pred_id::in,
|
|
prog_varset::in, list(prog_var)::in, pred_or_func::in, sym_name::in,
|
|
maybe_vartypes::in, clause::in, io::di, io::uo) is det.
|
|
|
|
intermod_write_clause(OutInfo, ModuleInfo, PredId, VarSet, HeadVars, PredOrFunc,
|
|
SymName, MaybeVarTypes, Clause0, !IO) :-
|
|
Clause0 = clause(ApplicableProcIds, Goal, ImplLang, _),
|
|
(
|
|
ImplLang = impl_lang_mercury,
|
|
strip_headvar_unifications(HeadVars, Clause0, ClauseHeadVars, Clause),
|
|
% Variable numbers need to be appended for the case
|
|
% where the added arguments for a DCG pred expression
|
|
% are named the same as variables in the enclosing clause.
|
|
AppendVarNums = yes,
|
|
UseDeclaredModes = yes,
|
|
write_clause(OutInfo, 1, ModuleInfo, PredId, VarSet, AppendVarNums,
|
|
ClauseHeadVars, PredOrFunc, Clause, UseDeclaredModes,
|
|
MaybeVarTypes, !IO)
|
|
;
|
|
ImplLang = impl_lang_foreign(_),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_procedures(PredInfo, Procs),
|
|
(
|
|
(
|
|
% Pull the foreign code out of the goal.
|
|
Goal = hlds_goal(conj(plain_conj, Goals), _),
|
|
list.filter(
|
|
(pred(G::in) is semidet :-
|
|
G = hlds_goal(GE, _),
|
|
GE = call_foreign_proc(_, _, _, _, _, _, _)
|
|
), Goals, [ForeignCodeGoal]),
|
|
ForeignCodeGoal = hlds_goal(ForeignCodeGoalExpr, _),
|
|
ForeignCodeGoalExpr = call_foreign_proc(Attributes, _, _,
|
|
Args, _ExtraArgs, _MaybeTraceRuntimeCond, PragmaCode)
|
|
;
|
|
Goal = hlds_goal(GoalExpr, _),
|
|
GoalExpr = call_foreign_proc(Attributes, _, _,
|
|
Args, _ExtraArgs, _MaybeTraceRuntimeCond, PragmaCode)
|
|
)
|
|
->
|
|
(
|
|
ApplicableProcIds = all_modes,
|
|
unexpected(this_file,
|
|
"intermod_write_clause: all_modes foreign_proc")
|
|
;
|
|
ApplicableProcIds = selected_modes(ProcIds),
|
|
list.foldl(
|
|
write_foreign_clause(Procs, PredOrFunc, PragmaCode,
|
|
Attributes, Args, VarSet, SymName),
|
|
ProcIds, !IO)
|
|
)
|
|
;
|
|
unexpected(this_file, "foreign_proc expected within this goal")
|
|
)
|
|
).
|
|
|
|
:- pred write_foreign_clause(proc_table::in, pred_or_func::in,
|
|
pragma_foreign_code_impl::in, pragma_foreign_proc_attributes::in,
|
|
list(foreign_arg)::in, prog_varset::in, sym_name::in, proc_id::in,
|
|
io::di, io::uo) is det.
|
|
|
|
write_foreign_clause(Procs, PredOrFunc, PragmaImpl,
|
|
Attributes, Args, ProgVarset0, SymName, ProcId, !IO) :-
|
|
map.lookup(Procs, ProcId, ProcInfo),
|
|
proc_info_get_maybe_declared_argmodes(ProcInfo, MaybeArgModes),
|
|
(
|
|
MaybeArgModes = yes(ArgModes),
|
|
get_pragma_foreign_code_vars(Args, ArgModes,
|
|
ProgVarset0, ProgVarset, PragmaVars),
|
|
proc_info_get_inst_varset(ProcInfo, InstVarset),
|
|
mercury_output_pragma_foreign_code(Attributes, SymName,
|
|
PredOrFunc, PragmaVars, ProgVarset, InstVarset, PragmaImpl, !IO)
|
|
;
|
|
MaybeArgModes = no,
|
|
unexpected(this_file, "write_clause: no mode declaration")
|
|
).
|
|
|
|
% Strip the `Headvar.n = Term' unifications from each clause,
|
|
% except if the `Term' is a lambda expression.
|
|
%
|
|
% At least two problems occur if this is not done:
|
|
% - in some cases where nested unique modes were accepted by
|
|
% mode analysis, the extra aliasing added by the extra level
|
|
% of headvar unifications caused mode analysis to report
|
|
% an error (ground expected unique), when analysing the
|
|
% clauses read in from `.opt' files.
|
|
% - only HeadVar unifications may be reordered with impure goals,
|
|
% so a mode error results for the second level of headvar
|
|
% unifications added when the clauses are read in again from
|
|
% the `.opt' file. Clauses containing impure goals are not
|
|
% written to the `.opt' file for this reason.
|
|
%
|
|
:- pred strip_headvar_unifications(list(prog_var)::in,
|
|
clause::in, list(prog_term)::out, clause::out) is det.
|
|
|
|
strip_headvar_unifications(HeadVars, clause(ProcIds, Goal0, Lang, Context),
|
|
HeadTerms, clause(ProcIds, Goal, Lang, Context)) :-
|
|
Goal0 = hlds_goal(_, GoalInfo0),
|
|
goal_to_conj_list(Goal0, Goals0),
|
|
map.init(HeadVarMap0),
|
|
(
|
|
strip_headvar_unifications_from_goal_list(Goals0, HeadVars,
|
|
[], Goals, HeadVarMap0, HeadVarMap)
|
|
->
|
|
list.map(
|
|
(pred(HeadVar0::in, HeadTerm::out) is det :-
|
|
( map.search(HeadVarMap, HeadVar0, HeadTerm0) ->
|
|
HeadTerm = HeadTerm0
|
|
;
|
|
HeadTerm = term.variable(HeadVar0, Context)
|
|
)
|
|
), HeadVars, HeadTerms),
|
|
conj_list_to_goal(Goals, GoalInfo0, Goal)
|
|
;
|
|
term.var_list_to_term_list(HeadVars, HeadTerms),
|
|
Goal = Goal0
|
|
).
|
|
|
|
:- pred strip_headvar_unifications_from_goal_list(list(hlds_goal)::in,
|
|
list(prog_var)::in, list(hlds_goal)::in, list(hlds_goal)::out,
|
|
map(prog_var, prog_term)::in,
|
|
map(prog_var, prog_term)::out) is semidet.
|
|
|
|
strip_headvar_unifications_from_goal_list([], _, RevGoals, Goals,
|
|
!HeadVarMap) :-
|
|
list.reverse(RevGoals, Goals).
|
|
strip_headvar_unifications_from_goal_list([Goal | Goals0], HeadVars,
|
|
RevGoals0, Goals, !HeadVarMap) :-
|
|
(
|
|
Goal = hlds_goal(unify(LHSVar, RHS, _, _, _), _),
|
|
list.member(LHSVar, HeadVars),
|
|
term.context_init(Context),
|
|
(
|
|
RHS = rhs_var(RHSVar),
|
|
RHSTerm = term.variable(RHSVar, Context)
|
|
;
|
|
RHS = rhs_functor(ConsId, _, Args),
|
|
(
|
|
ConsId = int_const(Int),
|
|
RHSTerm = term.functor(term.integer(Int), [], Context)
|
|
;
|
|
ConsId = float_const(Float),
|
|
RHSTerm = term.functor(term.float(Float), [], Context)
|
|
;
|
|
ConsId = char_const(Char),
|
|
RHSTerm = term.functor(term.atom(term_io.escaped_char(Char)),
|
|
[], Context)
|
|
;
|
|
ConsId = string_const(String),
|
|
RHSTerm = term.functor(term.string(String), [], Context)
|
|
;
|
|
ConsId = cons(SymName, _, _),
|
|
term.var_list_to_term_list(Args, ArgTerms),
|
|
construct_qualified_term(SymName, ArgTerms, RHSTerm)
|
|
)
|
|
)
|
|
->
|
|
% Don't strip the headvar unifications if one of the
|
|
% headvars appears twice. This should probably never happen.
|
|
map.insert(!.HeadVarMap, LHSVar, RHSTerm, !:HeadVarMap),
|
|
RevGoals1 = RevGoals0
|
|
;
|
|
RevGoals1 = [Goal | RevGoals0]
|
|
),
|
|
strip_headvar_unifications_from_goal_list(Goals0, HeadVars,
|
|
RevGoals1, Goals, !HeadVarMap).
|
|
|
|
:- pred write_pragmas(pred_info::in, io::di, io::uo) is det.
|
|
|
|
write_pragmas(PredInfo, !IO) :-
|
|
Module = pred_info_module(PredInfo),
|
|
Name = pred_info_name(PredInfo),
|
|
Arity = pred_info_orig_arity(PredInfo),
|
|
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
|
|
SymName = qualified(Module, Name),
|
|
pred_info_get_markers(PredInfo, Markers),
|
|
markers_to_marker_list(Markers, MarkerList),
|
|
write_pragmas(SymName, Arity, MarkerList, PredOrFunc, !IO).
|
|
|
|
:- pred write_pragmas(sym_name::in, int::in, list(marker)::in,
|
|
pred_or_func::in, io::di, io::uo) is det.
|
|
|
|
write_pragmas(_, _, [], _, !IO).
|
|
write_pragmas(SymName, Arity, [Marker | Markers], PredOrFunc, !IO) :-
|
|
should_output_marker(Marker, ShouldOutput),
|
|
(
|
|
ShouldOutput = yes,
|
|
hlds_out.marker_name(Marker, Name),
|
|
mercury_output_pragma_decl(SymName, Arity, PredOrFunc, Name, no, !IO)
|
|
;
|
|
ShouldOutput = no
|
|
),
|
|
write_pragmas(SymName, Arity, Markers, PredOrFunc, !IO).
|
|
|
|
:- pred write_type_spec_pragmas(module_info::in, pred_id::in,
|
|
io::di, io::uo) is det.
|
|
|
|
write_type_spec_pragmas(ModuleInfo, PredId, !IO) :-
|
|
module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo),
|
|
PragmaMap = TypeSpecInfo ^ pragma_map,
|
|
( multi_map.search(PragmaMap, PredId, TypeSpecPragmas) ->
|
|
list.foldl(write_type_spec_pragma, TypeSpecPragmas, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred write_type_spec_pragma(pragma_type::in, io::di, io::uo) is det.
|
|
|
|
write_type_spec_pragma(Pragma, !IO) :-
|
|
( Pragma = pragma_type_spec(_, _, _, _, _, _, _, _) ->
|
|
AppendVarnums = yes,
|
|
mercury_output_pragma_type_spec(Pragma, AppendVarnums, !IO)
|
|
;
|
|
unexpected(this_file, "write_type_spec_pragma")
|
|
).
|
|
|
|
% Is a pragma declaration required in the `.opt' file for
|
|
% a predicate with the given marker.
|
|
%
|
|
:- pred should_output_marker(marker::in, bool::out) is det.
|
|
|
|
should_output_marker(marker_stub, no).
|
|
should_output_marker(marker_builtin_stub, no).
|
|
% Since the inferred declarations are output, these
|
|
% don't need to be done in the importing module.
|
|
should_output_marker(marker_infer_type, no).
|
|
should_output_marker(marker_infer_modes, no).
|
|
% Purity is output as part of the pred/func decl.
|
|
should_output_marker(marker_is_impure, no).
|
|
should_output_marker(marker_is_semipure, no).
|
|
% There is no pragma required for generated class methods.
|
|
should_output_marker(marker_class_method, no).
|
|
should_output_marker(marker_class_instance_method, no).
|
|
should_output_marker(marker_named_class_instance_method, no).
|
|
% The warning for calls to local obsolete predicates should appear
|
|
% once in the defining module, not in importing modules.
|
|
should_output_marker(marker_obsolete, no).
|
|
should_output_marker(marker_user_marked_inline, yes).
|
|
should_output_marker(marker_user_marked_no_inline, yes).
|
|
should_output_marker(marker_heuristic_inline, no).
|
|
should_output_marker(marker_promised_pure, yes).
|
|
should_output_marker(marker_promised_semipure, yes).
|
|
should_output_marker(marker_promised_equivalent_clauses, yes).
|
|
should_output_marker(marker_terminates, yes).
|
|
should_output_marker(marker_does_not_terminate, yes).
|
|
% Termination should only be checked in the defining module.
|
|
should_output_marker(marker_check_termination, no).
|
|
should_output_marker(marker_calls_are_fully_qualified, no).
|
|
should_output_marker(marker_mode_check_clauses, yes).
|
|
should_output_marker(marker_mutable_access_pred, no).
|
|
should_output_marker(marker_has_format_call, no).
|
|
|
|
:- pred get_pragma_foreign_code_vars(list(foreign_arg)::in, list(mer_mode)::in,
|
|
prog_varset::in, prog_varset::out, list(pragma_var)::out) is det.
|
|
|
|
get_pragma_foreign_code_vars(Args, Modes, !VarSet, PragmaVars) :-
|
|
(
|
|
Args = [Arg | ArgsTail],
|
|
Modes = [Mode | ModesTail],
|
|
Arg = foreign_arg(Var, MaybeNameAndMode, _, _),
|
|
(
|
|
MaybeNameAndMode = no,
|
|
Name = "_"
|
|
;
|
|
MaybeNameAndMode = yes(Name - _Mode2)
|
|
),
|
|
PragmaVar = pragma_var(Var, Name, Mode, native_if_possible),
|
|
varset.name_var(!.VarSet, Var, Name, !:VarSet),
|
|
get_pragma_foreign_code_vars(ArgsTail, ModesTail, !VarSet,
|
|
PragmaVarsTail),
|
|
PragmaVars = [PragmaVar | PragmaVarsTail]
|
|
;
|
|
Args = [],
|
|
Modes = [],
|
|
PragmaVars = []
|
|
;
|
|
Args = [],
|
|
Modes = [_ | _],
|
|
unexpected(this_file, "get_pragma_foreign_code_vars")
|
|
;
|
|
Args = [_ | _],
|
|
Modes = [],
|
|
unexpected(this_file, "get_pragma_foreign_code_vars")
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% A collection of stuff to go in the .opt file.
|
|
%
|
|
:- type intermod_info
|
|
---> intermod_info(
|
|
% Modules to import.
|
|
im_modules :: set(module_name),
|
|
|
|
% Preds to output clauses for.
|
|
im_preds :: set(pred_id),
|
|
|
|
% Preds to output decls for.
|
|
im_pred_decls :: set(pred_id),
|
|
|
|
% Instances declarations to write.
|
|
im_instances :: assoc_list(class_id,
|
|
hlds_instance_defn),
|
|
|
|
% Type declarations to write.
|
|
im_types :: assoc_list(type_ctor,
|
|
hlds_type_defn),
|
|
|
|
im_module_info :: module_info,
|
|
|
|
% Do the pragma foreign_decls for the module need writing,
|
|
% yes if there are pragma foreign_procs being exported.
|
|
im_write_foreign_header :: bool,
|
|
|
|
% Vartypes and tvarset for the current pred.
|
|
im_var_types :: vartypes,
|
|
im_tvarset :: tvarset
|
|
).
|
|
|
|
:- pred init_intermod_info(module_info::in, intermod_info::out) is det.
|
|
|
|
init_intermod_info(ModuleInfo, IntermodInfo) :-
|
|
set.init(Modules),
|
|
set.init(Procs),
|
|
set.init(ProcDecls),
|
|
map.init(VarTypes),
|
|
varset.init(TVarSet),
|
|
Instances = [],
|
|
Types = [],
|
|
IntermodInfo = intermod_info(Modules, Procs, ProcDecls, Instances, Types,
|
|
ModuleInfo, no, VarTypes, TVarSet).
|
|
|
|
:- pred intermod_info_get_modules(intermod_info::in, set(module_name)::out)
|
|
is det.
|
|
:- pred intermod_info_get_preds(intermod_info::in, set(pred_id)::out) is det.
|
|
:- pred intermod_info_get_pred_decls(intermod_info::in, set(pred_id)::out)
|
|
is det.
|
|
:- pred intermod_info_get_instances(intermod_info::in,
|
|
assoc_list(class_id, hlds_instance_defn)::out) is det.
|
|
:- pred intermod_info_get_types(intermod_info::in,
|
|
assoc_list(type_ctor, hlds_type_defn)::out) is det.
|
|
:- pred intermod_info_get_module_info(intermod_info::in, module_info::out)
|
|
is det.
|
|
:- pred intermod_info_get_write_foreign_header(intermod_info::in, bool::out)
|
|
is det.
|
|
:- pred intermod_info_get_var_types(intermod_info::in, vartypes::out) is det.
|
|
:- pred intermod_info_get_tvarset(intermod_info::in, tvarset::out) is det.
|
|
|
|
:- pred intermod_info_set_modules(set(module_name)::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_set_preds(set(pred_id)::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_set_pred_decls(set(pred_id)::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_set_instances(
|
|
assoc_list(class_id, hlds_instance_defn)::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_set_types(assoc_list(type_ctor, hlds_type_defn)::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
%:- pred intermod_info_set_insts(set(inst_id)::in,
|
|
% intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_set_module_info(module_info::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_set_write_header(intermod_info::in,
|
|
intermod_info::out) is det.
|
|
:- pred intermod_info_set_var_types(vartypes::in, intermod_info::in,
|
|
intermod_info::out) is det.
|
|
:- pred intermod_info_set_tvarset(tvarset::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod_info_get_modules(Info, Info ^ im_modules).
|
|
intermod_info_get_preds(Info, Info ^ im_preds).
|
|
intermod_info_get_pred_decls(Info, Info ^ im_pred_decls).
|
|
intermod_info_get_instances(Info, Info ^ im_instances).
|
|
intermod_info_get_types(Info, Info ^ im_types).
|
|
intermod_info_get_module_info(Info, Info ^ im_module_info).
|
|
intermod_info_get_write_foreign_header(Info, Info ^ im_write_foreign_header).
|
|
intermod_info_get_var_types(Info, Info ^ im_var_types).
|
|
intermod_info_get_tvarset(Info, Info ^ im_tvarset).
|
|
|
|
intermod_info_set_modules(Modules, Info, Info ^ im_modules := Modules).
|
|
intermod_info_set_preds(Procs, Info, Info ^ im_preds := Procs).
|
|
intermod_info_set_pred_decls(ProcDecls, Info,
|
|
Info ^ im_pred_decls := ProcDecls).
|
|
intermod_info_set_instances(Instances, Info, Info ^ im_instances := Instances).
|
|
intermod_info_set_types(Types, Info, Info ^ im_types := Types).
|
|
intermod_info_set_module_info(ModuleInfo, Info,
|
|
Info ^ im_module_info := ModuleInfo).
|
|
intermod_info_set_write_header(Info, Info ^ im_write_foreign_header := yes).
|
|
intermod_info_set_var_types(VarTypes, Info, Info ^ im_var_types := VarTypes).
|
|
intermod_info_set_tvarset(TVarSet, Info, Info ^ im_tvarset := TVarSet).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Make sure the labels of local preds needed by predicates in
|
|
% the .opt file are exported, and inhibit dead proc elimination
|
|
% on those preds.
|
|
%
|
|
adjust_pred_import_status(!ModuleInfo) :-
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
|
|
trace [io(!IO)] (
|
|
maybe_write_string(VeryVerbose,
|
|
"% Adjusting import status of predicates in the `.opt' file...",
|
|
!IO)
|
|
),
|
|
|
|
module_info_predids(PredIds, !ModuleInfo),
|
|
globals.lookup_int_option(Globals, intermod_inline_simple_threshold,
|
|
Threshold),
|
|
globals.lookup_bool_option(Globals, deforestation, Deforestation),
|
|
globals.lookup_int_option(Globals, higher_order_size_limit,
|
|
HigherOrderSizeLimit),
|
|
some [!Info] (
|
|
init_intermod_info(!.ModuleInfo, !:Info),
|
|
gather_preds(PredIds, yes, Threshold, HigherOrderSizeLimit,
|
|
Deforestation, !Info),
|
|
gather_instances(!Info),
|
|
gather_types(!Info),
|
|
do_adjust_pred_import_status(!.Info, !ModuleInfo)
|
|
),
|
|
trace [io(!IO)] (
|
|
maybe_write_string(VeryVerbose, " done\n", !IO)
|
|
).
|
|
|
|
:- pred do_adjust_pred_import_status(intermod_info::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
do_adjust_pred_import_status(Info, !ModuleInfo) :-
|
|
intermod_info_get_pred_decls(Info, PredDecls0),
|
|
set.to_sorted_list(PredDecls0, PredDecls),
|
|
set_list_of_preds_exported(PredDecls, !ModuleInfo),
|
|
adjust_type_status(!ModuleInfo),
|
|
adjust_class_status(!ModuleInfo),
|
|
adjust_instance_status(!ModuleInfo).
|
|
|
|
:- pred adjust_type_status(module_info::in, module_info::out) is det.
|
|
|
|
adjust_type_status(!ModuleInfo) :-
|
|
module_info_get_type_table(!.ModuleInfo, TypeTable0),
|
|
map_foldl_over_type_ctor_defns(adjust_type_status_2, TypeTable0, TypeTable,
|
|
!ModuleInfo),
|
|
module_info_set_type_table(TypeTable, !ModuleInfo).
|
|
|
|
:- pred adjust_type_status_2(type_ctor::in,
|
|
hlds_type_defn::in, hlds_type_defn::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
adjust_type_status_2(TypeCtor, TypeDefn0, TypeDefn, !ModuleInfo) :-
|
|
module_info_get_name(!.ModuleInfo, ModuleName),
|
|
( should_write_type(ModuleName, TypeCtor, TypeDefn0) ->
|
|
hlds_data.set_type_defn_status(status_exported, TypeDefn0, TypeDefn),
|
|
fixup_special_preds(TypeCtor, !ModuleInfo)
|
|
;
|
|
TypeDefn = TypeDefn0
|
|
).
|
|
|
|
:- pred fixup_special_preds((type_ctor)::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
fixup_special_preds(TypeCtor, ModuleInfo0, ModuleInfo) :-
|
|
special_pred_list(SpecialPredList),
|
|
module_info_get_special_pred_map(ModuleInfo0, SpecPredMap),
|
|
list.filter_map((pred(SpecPredId::in, PredId::out) is semidet :-
|
|
map.search(SpecPredMap, SpecPredId - TypeCtor, PredId)
|
|
), SpecialPredList, PredIds),
|
|
set_list_of_preds_exported(PredIds, ModuleInfo0, ModuleInfo).
|
|
|
|
:- pred adjust_class_status(module_info::in, module_info::out) is det.
|
|
|
|
adjust_class_status(!ModuleInfo) :-
|
|
module_info_get_class_table(!.ModuleInfo, Classes0),
|
|
map.to_assoc_list(Classes0, ClassAL0),
|
|
list.map_foldl(adjust_class_status_2, ClassAL0, ClassAL, !ModuleInfo),
|
|
map.from_sorted_assoc_list(ClassAL, Classes),
|
|
module_info_set_class_table(Classes, !ModuleInfo).
|
|
|
|
:- pred adjust_class_status_2(pair(class_id, hlds_class_defn)::in,
|
|
pair(class_id, hlds_class_defn)::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
adjust_class_status_2(ClassId - ClassDefn0, ClassId - ClassDefn,
|
|
!ModuleInfo) :-
|
|
( import_status_to_write(ClassDefn0 ^ class_status) ->
|
|
ClassDefn = ClassDefn0 ^ class_status := status_exported,
|
|
class_procs_to_pred_ids(ClassDefn ^ class_hlds_interface, PredIds),
|
|
set_list_of_preds_exported(PredIds, !ModuleInfo)
|
|
;
|
|
ClassDefn = ClassDefn0
|
|
).
|
|
|
|
:- pred class_procs_to_pred_ids(list(hlds_class_proc)::in, list(pred_id)::out)
|
|
is det.
|
|
|
|
class_procs_to_pred_ids(ClassProcs, PredIds) :-
|
|
list.map(
|
|
(pred(ClassProc::in, PredId::out) is det :-
|
|
ClassProc = hlds_class_proc(PredId, _)
|
|
),
|
|
ClassProcs, PredIds0),
|
|
list.sort_and_remove_dups(PredIds0, PredIds).
|
|
|
|
:- pred adjust_instance_status(module_info::in, module_info::out) is det.
|
|
|
|
adjust_instance_status(!ModuleInfo) :-
|
|
module_info_get_instance_table(!.ModuleInfo, Instances0),
|
|
map.to_assoc_list(Instances0, InstanceAL0),
|
|
list.map_foldl(adjust_instance_status_2, InstanceAL0, InstanceAL,
|
|
!ModuleInfo),
|
|
map.from_sorted_assoc_list(InstanceAL, Instances),
|
|
module_info_set_instance_table(Instances, !ModuleInfo).
|
|
|
|
:- pred adjust_instance_status_2(pair(class_id, list(hlds_instance_defn))::in,
|
|
pair(class_id, list(hlds_instance_defn))::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
adjust_instance_status_2(ClassId - InstanceList0, ClassId - InstanceList,
|
|
!ModuleInfo) :-
|
|
list.map_foldl(adjust_instance_status_3, InstanceList0, InstanceList,
|
|
!ModuleInfo).
|
|
|
|
:- pred adjust_instance_status_3(hlds_instance_defn::in,
|
|
hlds_instance_defn::out, module_info::in, module_info::out) is det.
|
|
|
|
adjust_instance_status_3(Instance0, Instance, !ModuleInfo) :-
|
|
Instance0 = hlds_instance_defn(InstanceModule, Status0, Context,
|
|
Constraints, Types, Body, HLDSClassInterface,
|
|
TVarSet, ConstraintProofs),
|
|
( import_status_to_write(Status0) ->
|
|
Instance = hlds_instance_defn(InstanceModule, status_exported,
|
|
Context, Constraints, Types, Body, HLDSClassInterface,
|
|
TVarSet, ConstraintProofs),
|
|
(
|
|
HLDSClassInterface = yes(ClassInterface),
|
|
class_procs_to_pred_ids(ClassInterface, PredIds),
|
|
set_list_of_preds_exported(PredIds, !ModuleInfo)
|
|
;
|
|
% This can happen if an instance has multiple
|
|
% declarations, one of which is abstract.
|
|
HLDSClassInterface = no
|
|
)
|
|
;
|
|
Instance = Instance0
|
|
).
|
|
|
|
:- pred set_list_of_preds_exported(list(pred_id)::in, module_info::in,
|
|
module_info::out) is det.
|
|
|
|
set_list_of_preds_exported(PredIds, !ModuleInfo) :-
|
|
module_info_preds(!.ModuleInfo, Preds0),
|
|
set_list_of_preds_exported_2(PredIds, Preds0, Preds),
|
|
module_info_set_preds(Preds, !ModuleInfo).
|
|
|
|
:- pred set_list_of_preds_exported_2(list(pred_id)::in,
|
|
pred_table::in, pred_table::out) is det.
|
|
|
|
set_list_of_preds_exported_2([], !Preds).
|
|
set_list_of_preds_exported_2([PredId | PredIds], !Preds) :-
|
|
map.lookup(!.Preds, PredId, PredInfo0),
|
|
(
|
|
pred_info_get_import_status(PredInfo0, Status),
|
|
import_status_to_write(Status)
|
|
->
|
|
(
|
|
pred_info_get_origin(PredInfo0, Origin),
|
|
Origin = origin_special_pred(spec_pred_unify - _)
|
|
->
|
|
NewStatus = status_pseudo_exported
|
|
;
|
|
Status = status_external(_)
|
|
->
|
|
NewStatus = status_external(status_opt_exported)
|
|
;
|
|
NewStatus = status_opt_exported
|
|
),
|
|
pred_info_set_import_status(NewStatus, PredInfo0, PredInfo),
|
|
map.det_update(!.Preds, PredId, PredInfo, !:Preds)
|
|
;
|
|
true
|
|
),
|
|
set_list_of_preds_exported_2(PredIds, !Preds).
|
|
|
|
% Should a declaration with the given status be written to the `.opt' file.
|
|
%
|
|
:- pred import_status_to_write(import_status::in) is semidet.
|
|
|
|
import_status_to_write(Status) :-
|
|
import_status_to_write(Status) = yes.
|
|
|
|
:- func import_status_to_write(import_status) = bool.
|
|
|
|
import_status_to_write(status_imported(_)) = no.
|
|
import_status_to_write(status_abstract_imported) = no.
|
|
import_status_to_write(status_pseudo_imported) = no.
|
|
import_status_to_write(status_opt_imported) = no.
|
|
import_status_to_write(status_exported) = no.
|
|
import_status_to_write(status_opt_exported) = yes.
|
|
import_status_to_write(status_abstract_exported) = yes.
|
|
import_status_to_write(status_pseudo_exported) = no.
|
|
import_status_to_write(status_exported_to_submodules) = yes.
|
|
import_status_to_write(status_local) = yes.
|
|
import_status_to_write(status_external(Status)) =
|
|
bool.not(status_is_exported(Status)).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Read in and process the optimization interfaces.
|
|
%
|
|
grab_opt_files(Globals, !Module, FoundError, !IO) :-
|
|
% Read in the .opt files for imported and ancestor modules.
|
|
ModuleName = !.Module ^ mai_module_name,
|
|
Ancestors0 = !.Module ^ mai_parent_deps,
|
|
InterfaceDeps0 = !.Module ^ mai_int_deps,
|
|
ImplementationDeps0 = !.Module ^ mai_impl_deps,
|
|
OptFiles = list.sort_and_remove_dups(list.condense(
|
|
[Ancestors0, InterfaceDeps0, ImplementationDeps0])),
|
|
globals.lookup_bool_option(Globals, read_opt_files_transitively,
|
|
Transitive),
|
|
ModulesProcessed = set.insert(set.sorted_list_to_set(OptFiles),
|
|
ModuleName),
|
|
read_optimization_interfaces(Globals, Transitive, ModuleName, OptFiles,
|
|
ModulesProcessed, cord.empty, OptItemsCord, [], OptSpecs, no, OptError,
|
|
!IO),
|
|
|
|
% Append the items to the current item list, using a `opt_imported'
|
|
% pseudo-declaration to let make_hlds know the opt_imported stuff
|
|
% is coming.
|
|
%
|
|
% XXX Using this mechanism to let make_hlds know this is a bad design.
|
|
OptItems = cord.list(OptItemsCord),
|
|
AddedItems = [make_pseudo_decl(md_opt_imported) | OptItems],
|
|
module_and_imports_add_items(cord.from_list(AddedItems), !Module),
|
|
module_and_imports_add_specs(OptSpecs, !Module),
|
|
|
|
% Get the :- pragma unused_args(...) declarations created when writing
|
|
% the .opt file for the current module. These are needed because we can
|
|
% probably remove more arguments with intermod_unused_args, but the
|
|
% interface for other modules must remain the same.
|
|
%
|
|
% Similarly for the :- pragma structure_reuse(...) declarations. With more
|
|
% information available when making the target code than when writing the
|
|
% `.opt' file, it can turn out that procedure which seemed to have
|
|
% condition reuse actually has none. But we have to maintain the interface
|
|
% for modules that use the conditional reuse information from the `.opt'
|
|
% file.
|
|
globals.lookup_bool_option(Globals, intermod_unused_args, UnusedArgs),
|
|
globals.lookup_bool_option(Globals, structure_reuse_analysis,
|
|
StructureReuse),
|
|
(
|
|
( UnusedArgs = yes
|
|
; StructureReuse = yes
|
|
)
|
|
->
|
|
read_optimization_interfaces(Globals, no, ModuleName, [ModuleName],
|
|
set.init, cord.empty, LocalItemsCord, [], LocalSpecs,
|
|
no, UA_SR_Error, !IO),
|
|
KeepPragma = (pred(Item::in) is semidet :-
|
|
Item = item_pragma(ItemPragma),
|
|
ItemPragma = item_pragma_info(_, Pragma, _, _),
|
|
(
|
|
UnusedArgs = yes,
|
|
Pragma = pragma_unused_args(_, _, _, _, _)
|
|
;
|
|
StructureReuse = yes,
|
|
Pragma = pragma_structure_reuse(_, _, _, _, _, _)
|
|
)
|
|
),
|
|
cord.filter(KeepPragma, LocalItemsCord, PragmaItemsCord),
|
|
module_and_imports_add_items(PragmaItemsCord, !Module),
|
|
module_and_imports_add_specs(LocalSpecs, !Module)
|
|
;
|
|
UA_SR_Error = no
|
|
),
|
|
|
|
% Read .int0 files required by the `.opt' files.
|
|
Int0Files = list.delete_all(
|
|
list.condense(list.map(get_ancestors, OptFiles)), ModuleName),
|
|
process_module_private_interfaces(Globals, ReadModules, Int0Files,
|
|
make_pseudo_decl(md_opt_imported),
|
|
make_pseudo_decl(md_opt_imported),
|
|
[], AncestorImports1,
|
|
[], AncestorImports2, !Module, !IO),
|
|
|
|
% Figure out which .int files are needed by the .opt files
|
|
get_dependencies(OptItems, NewImportDeps0, NewUseDeps0),
|
|
get_implicit_dependencies(OptItems, Globals,
|
|
NewImplicitImportDeps0, NewImplicitUseDeps0),
|
|
NewDeps = list.sort_and_remove_dups(list.condense(
|
|
[NewImportDeps0, NewUseDeps0,
|
|
NewImplicitImportDeps0, NewImplicitUseDeps0,
|
|
AncestorImports1, AncestorImports2])),
|
|
|
|
% Read in the .int, and .int2 files needed by the .opt files.
|
|
map.init(ReadModules),
|
|
process_module_long_interfaces(Globals, ReadModules, must_be_qualified,
|
|
NewDeps, ".int",
|
|
make_pseudo_decl(md_opt_imported), make_pseudo_decl(md_opt_imported),
|
|
[], NewIndirectDeps, [], NewImplIndirectDeps, !Module, !IO),
|
|
process_module_short_interfaces_and_impls_transitively(Globals,
|
|
ReadModules, NewIndirectDeps ++ NewImplIndirectDeps, ".int2",
|
|
make_pseudo_decl(md_opt_imported), make_pseudo_decl(md_opt_imported),
|
|
!Module, !IO),
|
|
|
|
% Figure out whether anything went wrong.
|
|
% XXX We should try to put all the relevant error indications into !Module,
|
|
% and let our caller figure out what to do with them.
|
|
module_and_imports_get_results(!.Module, _Items, _Specs, FoundError0),
|
|
(
|
|
( FoundError0 \= no_module_errors
|
|
; OptError = yes
|
|
; UA_SR_Error = yes
|
|
)
|
|
->
|
|
FoundError = yes
|
|
;
|
|
FoundError = no
|
|
).
|
|
|
|
:- pred read_optimization_interfaces(globals::in, bool::in, module_name::in,
|
|
list(module_name)::in, set(module_name)::in,
|
|
cord(item)::in, cord(item)::out,
|
|
list(error_spec)::in, list(error_spec)::out,
|
|
bool::in, bool::out, io::di, io::uo) is det.
|
|
|
|
read_optimization_interfaces(_, _, _, [], _, !Items, !Specs, !Error, !IO).
|
|
read_optimization_interfaces(Globals, Transitive, ModuleName,
|
|
[ModuleToRead | ModulesToRead], ModulesProcessed0,
|
|
!Items, !Specs, !Error, !IO) :-
|
|
globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
|
|
maybe_write_out_errors_no_module(VeryVerbose, Globals, !Specs, !IO),
|
|
maybe_write_string(VeryVerbose,
|
|
"% Reading optimization interface for module", !IO),
|
|
maybe_write_string(VeryVerbose, " `", !IO),
|
|
ModuleToReadString = sym_name_to_string(ModuleToRead),
|
|
maybe_write_string(VeryVerbose, ModuleToReadString, !IO),
|
|
maybe_write_string(VeryVerbose, "'...\n", !IO),
|
|
maybe_flush_output(VeryVerbose, !IO),
|
|
|
|
module_name_to_search_file_name(Globals, ModuleToRead, ".opt", FileName,
|
|
!IO),
|
|
actually_read_opt_file(Globals, FileName, ModuleToRead, OptItems, OptSpecs,
|
|
OptError, !IO),
|
|
update_error_status(Globals, opt_file, FileName,
|
|
OptSpecs, !Specs, OptError, !Error),
|
|
!:Items = !.Items ++ cord.from_list(OptItems),
|
|
maybe_write_out_errors_no_module(VeryVerbose, Globals, !Specs, !IO),
|
|
maybe_write_string(VeryVerbose, "% done.\n", !IO),
|
|
|
|
(
|
|
Transitive = yes,
|
|
get_dependencies(OptItems, NewImportDeps0, NewUseDeps0),
|
|
get_implicit_dependencies(OptItems, Globals,
|
|
NewImplicitImportDeps0, NewImplicitUseDeps0),
|
|
NewDeps0 = list.condense([NewImportDeps0, NewUseDeps0,
|
|
NewImplicitImportDeps0, NewImplicitUseDeps0]),
|
|
set.list_to_set(NewDeps0, NewDepsSet0),
|
|
set.difference(NewDepsSet0, ModulesProcessed0, NewDepsSet),
|
|
set.union(ModulesProcessed0, NewDepsSet, ModulesProcessed),
|
|
set.to_sorted_list(NewDepsSet, NewDeps)
|
|
;
|
|
Transitive = no,
|
|
ModulesProcessed = ModulesProcessed0,
|
|
NewDeps = []
|
|
),
|
|
read_optimization_interfaces(Globals, Transitive, ModuleName,
|
|
NewDeps ++ ModulesToRead, ModulesProcessed,
|
|
!Items, !Specs, !Error, !IO).
|
|
|
|
update_error_status(_Globals, FileType, FileName,
|
|
ModuleSpecs, !Specs, ModuleError, !Error) :-
|
|
(
|
|
ModuleError = no_module_errors
|
|
% OptSpecs contains no errors. I (zs) don't know whether it could
|
|
% contain any warnings or informational messages, but if it could,
|
|
% we should add those error_specs to !Specs. Not doing so preserves
|
|
% old behavior.
|
|
;
|
|
ModuleError = some_module_errors,
|
|
!:Specs = ModuleSpecs ++ !.Specs,
|
|
!:Error = yes
|
|
;
|
|
ModuleError = fatal_module_errors,
|
|
% We get here if we couldn't find and/or open the file.
|
|
% ModuleSpecs will already contain an error_severity error_spec
|
|
% about that, with more details than the message we generate below,
|
|
% but the test case hard_coded/intermod_unused_args insists on
|
|
% there being no error, only a warning, and on the text below.
|
|
% That is why we do not add ModuleSpecs to !Specs here.
|
|
%
|
|
% I (zs) don't know whether adding a version of ModuleSpecs (possibly
|
|
% with downgraded severity) to !Specs would be a better idea.
|
|
(
|
|
FileType = opt_file,
|
|
WarningOption = warn_missing_opt_files
|
|
;
|
|
FileType = trans_opt_file,
|
|
WarningOption = warn_missing_trans_opt_files
|
|
),
|
|
Severity =
|
|
severity_conditional(WarningOption, yes, severity_warning, no),
|
|
Pieces = [option_is_set(WarningOption, yes,
|
|
[always([words("Warning: cannot open"), quote(FileName),
|
|
suffix("."), nl])])],
|
|
Msg = error_msg(no, treat_as_first, 0, Pieces),
|
|
Spec = error_spec(Severity, phase_read_files, [Msg]),
|
|
!:Specs = [Spec | !.Specs]
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "intermod.m".
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module intermod.
|
|
%-----------------------------------------------------------------------------%
|