mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-20 00:15:27 +00:00
d075d35702
Estimated hours taken: 240 Branches: main Implement functional dependencies for the typeclass system. The implementation has two major parts. First, some of the basic checks of constraints are relaxed. These used to occur in make_hlds but that functionality has now been moved to check_typeclass. We also add a range of new tests to ensure that the FDs are used correctly. Second, an "improvement" pass to context reduction is added. This looks for constraints which match certain rules, and when it finds them updates the current bindings. The general rule is that type variables become more instantiated, but only in a way which provably does not affect the satisfiability of the constraints. XXX The plan for this change is to put the context reduction into a new module check_hlds.typeclasses.m, but I have left the code in typecheck.m for the moment because the diff will be easier to review that way. Moving to the new module will also remove the problem of one particular function being implemented in both typecheck and hlds_data, which is flagged by an XXX in the code. XXX the check for consistency of instances is not yet complete. We check all visible instances, but not instances that are only present at link time. We could check these in a similar way to the check for overlapping instances (that is, by defining a symbol that will conflict and cause a link error if there are overlapping instances), but in the long run a better solution will be required. Producing this is left for a later change. compiler/check_typeclass.m: Check for ambiguities in typeclass constraints here, rather than make_hlds. We check by calculating the closure of the bound type variables under the induced functional dependencies. This pass is merged in with the already existing pass that checks the quantifiers on constrained type variables. Check instances for range-restrictedness and for consistency. When checking for cycles in the typeclass hierarchy, build up the set of ancestors of a class which have FDs on them. This set is used when searching for opportunities to apply improvement rules during type checking. compiler/hlds_data.m: Define hlds_class_fundeps and add it to to hlds_class_defn. Add a field to hlds_class_defn to store the ancestors which have functional dependencies. Define the type 'instance_id', which is just an integer. This is what is used in proofs to identify instances. In hlds_constraints and in constraint_ids, use the terms 'assumed' and 'unproven' rather than 'existential' and 'universal'. The latter are confusing to use since the treatment of constraints differs depending on whether the constraint is on the head or the body of a clause. Add a field to the hlds_constraints for redundant constraints. These are constraints that have either already been reduced or don't need to be reduced, which may contribute to improvement of types. Define some new predicates for initialising and updating the hlds_constraints. compiler/type_util.m: Accommodate the change to hlds_constraints. compiler/hlds_out.m: Output the functional dependencies. compiler/intermod.m: Reconstruct a functional dependency from the HLDS, for outputting. compiler/make_hlds.m: Convert functional dependencies from parse tree form and add them to the HLDS. Check that functional dependencies are identical in subsequent definitions of the same typeclass. Don't check for ambiguity here. That is now done in check_typeclass. compiler/mercury_to_mercury.m: Output functional dependencies in typeclass declarations. compiler/prog_data.m: Define prog_fundeps and add them to the parse tree. compiler/prog_io_typeclass.m: Parse functional dependencies on typeclass declarations. compiler/typecheck.m: Require the class_table to be passed to reduce_context_by_rule_application, since the functional dependencies are stored here. Also thread the bindings argument through, since the bindings may be improved by context reduction. Save the resulting bindings in the type_assign. Instead of passing a list of assumed constraints and threading the unproven constraints through context reduction, thread through a hlds_constraints structure. This contains more information about redundant constraints than just the two lists. Extend context reduction with two new passes. The first applies the "class" FD rule, which tries to find two constraints which are identical on the domain of some FD, and then unifies the range arguments. The pair of constraints are either both redundant constraints, or one redundant constraint and one assumed constraint. The second applies the "instance" FD rule, which for each constraint tries to find an instance which is more general on the domain arguments. It then binds the instance arguments and unifies the range arguments of the instance with those of the constraint. When calculating the head_type_params for a predicate, include all variables that occur in universal constraints, since these may not necessarily occur in the arguments. Rename some variables: use variable prefixes "Pred" and "Parent" for types that are from the callee or that have been renamed apart respectively. This follows the same naming scheme used in polymorphism. Remove the headtypes/0 type, and use head_type_params/0 throughout. Add a new kind of cons_error for using "new" on a constructor that is not existentially typed. We check for this situation in convert_cons_defn, and report it in report_cons_error. Pass a value to convert_cons_defn indicating whether the constraints should be flipped or not, and whether the context is a constructor that uses 'new'. We flip the constraints here rather than after the fact, since creating the constraints now requires some extra processing to be done, and we don't want to have to redo that processing. Add a constant function that specifies whether variable numbers should be displayed as part of the debugging output. This is currently set to 'yes' but the previous behaviour can be achieved by changing the value to 'no'. doc/reference_manual.texi: Document the new feature. NEWS: Announce the new feature. tests/*: New test cases. compler/*.m: Minor changes related to the above. compiler/error_util.m: Fix comment grammar. compiler/prog_type.m: Fix an incorrect comment.
2421 lines
81 KiB
Mathematica
2421 lines
81 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1996-2005 The University of Melbourne.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% 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 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 parse_tree__modules.
|
|
:- import_module parse_tree__prog_data.
|
|
:- import_module parse_tree__prog_io.
|
|
|
|
:- import_module bool.
|
|
:- import_module io.
|
|
|
|
:- pred intermod__write_optfile(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 intermod__grab_optfiles(module_imports::in, module_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 intermod__adjust_pred_import_status(module_info::in, module_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
:- type opt_file_type
|
|
---> opt
|
|
; trans_opt.
|
|
|
|
% intermod__update_error_status(OptFileType, FileName, Error, Messages,
|
|
% Status0, Status)
|
|
%
|
|
% Work out whether any fatal errors have occurred while reading
|
|
% `.opt' files, updating Status0 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 intermod__update_error_status(opt_file_type::in, string::in,
|
|
module_error::in, message_list::in, bool::in, bool::out,
|
|
io::di, io::uo) 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 check_hlds__typecheck.
|
|
:- import_module hlds__goal_util.
|
|
:- import_module hlds__hlds_data.
|
|
:- import_module hlds__hlds_goal.
|
|
:- import_module hlds__hlds_out.
|
|
:- import_module hlds__hlds_pred.
|
|
:- import_module hlds__instmap.
|
|
:- import_module hlds__passes_aux.
|
|
:- import_module hlds__special_pred.
|
|
:- import_module libs__globals.
|
|
:- import_module libs__options.
|
|
:- import_module mdbcomp__prim_data.
|
|
:- 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_out.
|
|
:- import_module parse_tree__prog_util.
|
|
:- import_module transform_hlds__inlining.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module dir.
|
|
:- import_module getopt_io.
|
|
:- import_module int.
|
|
:- import_module list.
|
|
:- import_module map.
|
|
:- import_module multi_map.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module std_util.
|
|
:- import_module string.
|
|
:- import_module term.
|
|
:- import_module varset.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% 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.
|
|
|
|
intermod__write_optfile(!ModuleInfo, !IO) :-
|
|
% 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.
|
|
globals__io_lookup_bool_option(line_numbers, LineNumbers, !IO),
|
|
globals__io_set_option(line_numbers, bool(no), !IO),
|
|
|
|
module_info_name(!.ModuleInfo, ModuleName),
|
|
module_name_to_file_name(ModuleName, ".opt.tmp", yes, TmpName, !IO),
|
|
io__open_output(TmpName, Result2, !IO),
|
|
(
|
|
Result2 = error(Err2),
|
|
io__error_message(Err2, Msg2),
|
|
io__write_string(Msg2, !IO),
|
|
io__set_exit_status(1, !IO)
|
|
;
|
|
Result2 = ok(FileStream),
|
|
io__set_output_stream(FileStream, OutputStream, !IO),
|
|
module_info_predids(!.ModuleInfo, RealPredIds),
|
|
module_info_assertion_table(!.ModuleInfo, AssertionTable),
|
|
assertion_table_pred_ids(AssertionTable, AssertPredIds),
|
|
list__append(AssertPredIds, RealPredIds, PredIds),
|
|
init_intermod_info(!.ModuleInfo, IntermodInfo0),
|
|
globals__io_lookup_int_option(
|
|
intermod_inline_simple_threshold, Threshold, !IO),
|
|
globals__io_lookup_bool_option(deforestation, Deforestation,
|
|
!IO),
|
|
globals__io_lookup_int_option(higher_order_size_limit,
|
|
HigherOrderSizeLimit, !IO),
|
|
intermod__gather_preds(PredIds, yes, Threshold,
|
|
HigherOrderSizeLimit, Deforestation,
|
|
IntermodInfo0, IntermodInfo1),
|
|
intermod__gather_instances(IntermodInfo1,
|
|
IntermodInfo2),
|
|
intermod__gather_types(IntermodInfo2,
|
|
IntermodInfo),
|
|
intermod__write_intermod_info(IntermodInfo, !IO),
|
|
intermod_info_get_module_info(!:ModuleInfo, IntermodInfo, _),
|
|
io__set_output_stream(OutputStream, _, !IO),
|
|
io__close_output(FileStream, !IO),
|
|
globals__io_lookup_bool_option(intermod_unused_args,
|
|
UnusedArgs, !IO),
|
|
( UnusedArgs = yes ->
|
|
do_adjust_pred_import_status(IntermodInfo,
|
|
!ModuleInfo)
|
|
;
|
|
true
|
|
)
|
|
),
|
|
% restore the option setting that we overrode above
|
|
globals__io_set_option(line_numbers, bool(LineNumbers), !IO).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Predicates to gather stuff to output to .opt file.
|
|
|
|
:- pred intermod__gather_preds(list(pred_id)::in, bool::in, int::in,
|
|
int::in, bool::in, intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod__gather_preds(AllPredIds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info) :-
|
|
% first gather exported preds
|
|
ProcessLocalPreds = no,
|
|
intermod__gather_pred_list(AllPredIds, ProcessLocalPreds,
|
|
CollectTypes, InlineThreshold, HigherOrderSizeLimit,
|
|
Deforestation, !Info),
|
|
|
|
% then gather preds used by exported preds (recursively)
|
|
set__init(ExtraExportedPreds0),
|
|
intermod__gather_preds_2(ExtraExportedPreds0, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info).
|
|
|
|
:- pred intermod__gather_preds_2(set(pred_id)::in, bool::in, int::in,
|
|
int::in, bool::in, intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod__gather_preds_2(ExtraExportedPreds0, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info) :-
|
|
intermod_info_get_pred_decls(ExtraExportedPreds, !Info),
|
|
NewlyExportedPreds = set__to_sorted_list(
|
|
ExtraExportedPreds `set__difference` ExtraExportedPreds0),
|
|
( NewlyExportedPreds = [] ->
|
|
true
|
|
;
|
|
ProcessLocalPreds = yes,
|
|
intermod__gather_pred_list(NewlyExportedPreds,
|
|
ProcessLocalPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation,
|
|
!Info),
|
|
intermod__gather_preds_2(ExtraExportedPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation,
|
|
!Info)
|
|
).
|
|
|
|
:- pred intermod__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.
|
|
|
|
intermod__gather_pred_list([], _, _, _, _, _, !Info).
|
|
intermod__gather_pred_list([PredId | PredIds], ProcessLocalPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info) :-
|
|
intermod_info_get_module_info(ModuleInfo0, !Info),
|
|
module_info_preds(ModuleInfo0, PredTable0),
|
|
map__lookup(PredTable0, PredId, PredInfo0),
|
|
module_info_type_spec_info(ModuleInfo0, TypeSpecInfo),
|
|
TypeSpecInfo = type_spec_info(_, TypeSpecForcePreds, _, _),
|
|
pred_info_clauses_info(PredInfo0, ClausesInfo0),
|
|
(
|
|
%
|
|
% XXX hlds_out__write_clause needs to be changed to
|
|
% output explicit type qualifications to avoid type
|
|
% ambiguity errors in clauses written to `.opt' files.
|
|
%
|
|
clauses_info_explicit_vartypes(ClausesInfo0, ExplicitVarTypes),
|
|
map__is_empty(ExplicitVarTypes),
|
|
intermod__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.
|
|
intermod__add_proc(PredId, DoWrite0, !Info),
|
|
clauses_info_clauses(ClausesInfo0, Clauses0),
|
|
(
|
|
DoWrite0 = yes,
|
|
clauses_info_vartypes(ClausesInfo0, VarTypes),
|
|
pred_info_typevarset(PredInfo0, TVarSet),
|
|
intermod_info_set_var_types(VarTypes, !Info),
|
|
intermod_info_set_tvarset(TVarSet, !Info),
|
|
intermod__traverse_clauses(Clauses0, Clauses, DoWrite,
|
|
!Info)
|
|
;
|
|
DoWrite0 = no,
|
|
Clauses = Clauses0,
|
|
DoWrite = no
|
|
),
|
|
(
|
|
DoWrite = yes,
|
|
clauses_info_set_clauses(Clauses,
|
|
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(Preds0, !Info),
|
|
( pred_info_pragma_goal_type(PredInfo) ->
|
|
% The header code must be written since
|
|
% it could be used by the pragma_foreign_code.
|
|
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
|
|
),
|
|
intermod__gather_pred_list(PredIds, ProcessLocalPreds, CollectTypes,
|
|
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info).
|
|
|
|
:- pred intermod__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.
|
|
|
|
intermod__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_import_status(PredInfo, local)
|
|
),
|
|
(
|
|
pred_info_clauses_info(PredInfo, ClauseInfo),
|
|
clauses_info_clauses(ClauseInfo, Clauses),
|
|
|
|
[ProcId | _ProcIds] = pred_info_procids(PredInfo),
|
|
pred_info_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, class_method),
|
|
\+ check_marker(Markers, class_instance_method),
|
|
|
|
% Don't write stub clauses to `.opt' files.
|
|
\+ check_marker(Markers, 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_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_eval_method(ProcInfo, eval_normal),
|
|
|
|
(
|
|
inlining__is_simple_clause_list(Clauses,
|
|
InlineThreshold + Arity),
|
|
pred_info_get_markers(PredInfo, Markers),
|
|
\+ check_marker(Markers, no_inline)
|
|
;
|
|
pred_info_requested_inlining(PredInfo)
|
|
;
|
|
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, 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 = il,
|
|
Lang = C ^ clause_lang,
|
|
Lang = foreign_language(ForeignLang),
|
|
( ForeignLang = csharp
|
|
; ForeignLang = managed_cplusplus
|
|
).
|
|
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_headvars(ProcInfo, HeadVars),
|
|
proc_info_argmodes(ProcInfo, ArgModes),
|
|
proc_info_vartypes(ProcInfo, VarTypes),
|
|
check_for_ho_input_args(ModuleInfo, HeadVars, ArgModes, VarTypes).
|
|
|
|
:- pred check_for_ho_input_args(module_info::in, list(prog_var)::in,
|
|
list(mode)::in, map(prog_var, type)::in) is semidet.
|
|
|
|
check_for_ho_input_args(ModuleInfo, [HeadVar | HeadVars],
|
|
[ArgMode | ArgModes], VarTypes) :-
|
|
(
|
|
mode_is_input(ModuleInfo, ArgMode),
|
|
map__lookup(VarTypes, HeadVar, Type),
|
|
classify_type(ModuleInfo, Type) = higher_order_type
|
|
;
|
|
check_for_ho_input_args(ModuleInfo, HeadVars,
|
|
ArgModes, VarTypes)
|
|
).
|
|
|
|
% 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 = GoalExpr - _,
|
|
(
|
|
goal_is_branched(GoalExpr),
|
|
FoundBranch0 = no,
|
|
FoundBranch = yes
|
|
;
|
|
goal_is_atomic(GoalExpr),
|
|
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(conj(Goals0) - Info, conj(Goals) - Info, DoWrite,
|
|
!Info) :-
|
|
intermod__traverse_list_of_goals(Goals0, Goals, DoWrite, !Info).
|
|
intermod__traverse_goal(par_conj(Goals0) - Info, par_conj(Goals) - Info,
|
|
DoWrite, !Info) :-
|
|
intermod__traverse_list_of_goals(Goals0, Goals, DoWrite, !Info).
|
|
intermod__traverse_goal(disj(Goals0) - Info, disj(Goals) - Info, DoWrite,
|
|
!Info) :-
|
|
intermod__traverse_list_of_goals(Goals0, Goals, DoWrite, !Info).
|
|
intermod__traverse_goal(Goal, Goal, DoWrite, !Info) :-
|
|
Goal = call(PredId, _, _, _, _, _) - _,
|
|
%
|
|
% Ensure that the called predicate will be exported.
|
|
%
|
|
intermod__add_proc(PredId, DoWrite, !Info).
|
|
intermod__traverse_goal(Goal @ generic_call(CallType, _, _, _) - Info,
|
|
Goal - Info, DoWrite, !Info) :-
|
|
( CallType = higher_order(_, _, _, _), DoWrite = yes
|
|
; CallType = class_method(_, _, _, _), DoWrite = no
|
|
; CallType = unsafe_cast, DoWrite = no
|
|
; CallType = aditi_builtin(_, _), DoWrite = yes
|
|
).
|
|
intermod__traverse_goal(switch(Var, CanFail, Cases0) - Info,
|
|
switch(Var, CanFail, Cases) - Info, DoWrite, !Info) :-
|
|
intermod__traverse_cases(Cases0, Cases, DoWrite, !Info).
|
|
% Export declarations for preds used in higher order pred constants
|
|
% or function calls.
|
|
intermod__traverse_goal(unify(LVar, RHS0, C, D, E) - Info,
|
|
unify(LVar, RHS, C, D, E) - Info, DoWrite, !Info) :-
|
|
intermod__module_qualify_unify_rhs(LVar, RHS0, RHS, DoWrite, !Info).
|
|
intermod__traverse_goal(not(Goal0) - Info, not(Goal) - Info, DoWrite, !Info) :-
|
|
intermod__traverse_goal(Goal0, Goal, DoWrite, !Info).
|
|
intermod__traverse_goal(scope(Reason, Goal0) - Info,
|
|
scope(Reason, Goal) - Info, DoWrite, !Info) :-
|
|
intermod__traverse_goal(Goal0, Goal, DoWrite, !Info).
|
|
intermod__traverse_goal(if_then_else(Vars, Cond0, Then0, Else0) - Info,
|
|
if_then_else(Vars, Cond, Then, Else) - Info, DoWrite, !Info) :-
|
|
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).
|
|
% Inlineable exported pragma_foreign_code goals can't use any
|
|
% non-exported types, so we just write out the clauses.
|
|
intermod__traverse_goal(Goal @ foreign_proc(_, _, _, _, _, _) - Info,
|
|
Goal - Info, yes, !Info).
|
|
intermod__traverse_goal(shorthand(_) - _, _, _, !Info) :-
|
|
% these should have been expanded out by now
|
|
error("intermod__traverse_goal: unexpected 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, DoWrite1, !Info),
|
|
(
|
|
DoWrite1 = yes,
|
|
intermod__traverse_list_of_goals(Goals0, Goals, DoWrite, !Info)
|
|
;
|
|
DoWrite1 = no,
|
|
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([case(F, Goal0) | Cases0],
|
|
[case(F, Goal) | Cases], DoWrite, !Info) :-
|
|
intermod__traverse_goal(Goal0, Goal, DoWrite1, !Info),
|
|
(
|
|
DoWrite1 = yes,
|
|
intermod__traverse_cases(Cases0, Cases, DoWrite, !Info)
|
|
;
|
|
DoWrite1 = no,
|
|
DoWrite = no,
|
|
Cases = Cases0
|
|
).
|
|
|
|
%
|
|
% intermod__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 intermod__add_proc(pred_id::in, bool::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod__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
|
|
;
|
|
intermod__add_proc_2(PredId, DoWrite, !Info)
|
|
).
|
|
|
|
:- pred intermod__add_proc_2(pred_id::in, bool::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod__add_proc_2(PredId, DoWrite, !Info) :-
|
|
intermod_info_get_module_info(ModuleInfo, !Info),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_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, infer_modes)
|
|
;
|
|
pred_info_procedures(PredInfo, Procs),
|
|
list__member(ProcId, ProcIds),
|
|
map__lookup(Procs, ProcId, ProcInfo),
|
|
proc_info_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.
|
|
pred_info_get_purity(PredInfo, impure)
|
|
->
|
|
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 = exported
|
|
; 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, 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(PredDecls0, !Info),
|
|
set__insert(PredDecls0, PredId, PredDecls),
|
|
intermod_info_set_pred_decls(PredDecls, !Info)
|
|
;
|
|
( Status = imported(_)
|
|
; Status = opt_imported
|
|
)
|
|
->
|
|
%
|
|
% imported pred - add import for module
|
|
%
|
|
DoWrite = yes,
|
|
PredModule = pred_info_module(PredInfo),
|
|
intermod_info_get_modules(Modules0, !Info),
|
|
set__insert(Modules0, PredModule, Modules),
|
|
intermod_info_set_modules(Modules, !Info)
|
|
;
|
|
error("intermod__add_proc: unexpected status")
|
|
).
|
|
|
|
% Resolve overloading and module qualify everything in a unify_rhs.
|
|
:- pred intermod__module_qualify_unify_rhs(prog_var::in, unify_rhs::in,
|
|
unify_rhs::out, bool::out, intermod_info::in,
|
|
intermod_info::out) is det.
|
|
|
|
% Fully module-qualify the right-hand-side of a unification.
|
|
% For function calls and higher-order terms, call intermod__add_proc
|
|
% so that the predicate or function will be exported if necessary.
|
|
intermod__module_qualify_unify_rhs(_LHS, RHS @ var(_Var), RHS, yes, !Info).
|
|
intermod__module_qualify_unify_rhs(_LHS,
|
|
lambda_goal(A,B,C,D,E,F,G,H,Goal0),
|
|
lambda_goal(A,B,C,D,E,F,G,H,Goal), DoWrite, !Info) :-
|
|
intermod__traverse_goal(Goal0, Goal, DoWrite, !Info).
|
|
intermod__module_qualify_unify_rhs(_LHS, RHS @ functor(Functor, _Exist, _Vars),
|
|
RHS, DoWrite, !Info) :-
|
|
% Is this a higher-order predicate or higher-order function
|
|
% term?
|
|
( Functor = pred_const(ShroudedPredProcId, _) ->
|
|
%
|
|
% Yes, the unification creates a higher-order term.
|
|
% Make sure that the predicate/function is exported.
|
|
%
|
|
proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
intermod__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 intermod__gather_instances(intermod_info::in, intermod_info::out)
|
|
is det.
|
|
|
|
intermod__gather_instances(!Info) :-
|
|
intermod_info_get_module_info(ModuleInfo, !Info),
|
|
module_info_instances(ModuleInfo, Instances),
|
|
map__foldl(intermod__gather_instances_2(ModuleInfo), Instances, !Info).
|
|
|
|
:- pred intermod__gather_instances_2(module_info::in, class_id::in,
|
|
list(hlds_instance_defn)::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod__gather_instances_2(ModuleInfo, ClassId, InstanceDefns, !Info) :-
|
|
list__foldl(intermod__gather_instances_3(ModuleInfo, ClassId),
|
|
InstanceDefns, !Info).
|
|
|
|
:- pred intermod__gather_instances_3(module_info::in, class_id::in,
|
|
hlds_instance_defn::in, intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod__gather_instances_3(ModuleInfo, ClassId, InstanceDefn, !Info) :-
|
|
InstanceDefn = hlds_instance_defn(A, Status, C, D, E, Interface0,
|
|
MaybePredProcIds, H, I),
|
|
(
|
|
%
|
|
% 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.
|
|
%
|
|
status_defined_in_this_module(Status, yes)
|
|
->
|
|
SaveInfo = !.Info,
|
|
(
|
|
Interface0 = 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)
|
|
;
|
|
error("intermod__gather_instances_3: " ++
|
|
"method pred_proc_ids not filled in")
|
|
),
|
|
list__map_foldl(
|
|
intermod__qualify_instance_method(ModuleInfo),
|
|
MethodAL, Methods, [], PredIds),
|
|
list__map_foldl(intermod__add_proc, PredIds,
|
|
DoWriteMethodsList, !Info),
|
|
bool__and_list(DoWriteMethodsList, DoWriteMethods),
|
|
(
|
|
DoWriteMethods = yes,
|
|
Interface = 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 = abstract,
|
|
|
|
%
|
|
% Don't write declarations for any of the
|
|
% methods if one can't be written.
|
|
%
|
|
!:Info = SaveInfo
|
|
)
|
|
;
|
|
Interface0 = abstract,
|
|
Interface = Interface0
|
|
),
|
|
(
|
|
%
|
|
% Don't write an abstract instance declaration
|
|
% if the declaration is already in the `.int' file.
|
|
%
|
|
(
|
|
Interface = abstract
|
|
=>
|
|
status_is_exported(Status, no)
|
|
)
|
|
->
|
|
InstanceDefnToWrite = hlds_instance_defn(A, Status,
|
|
C, D, E, Interface, MaybePredProcIds, H, I),
|
|
intermod_info_get_instances(Instances0, !Info),
|
|
intermod_info_set_instances(
|
|
[ClassId - InstanceDefnToWrite | Instances0],
|
|
!Info)
|
|
;
|
|
true
|
|
)
|
|
;
|
|
true
|
|
).
|
|
|
|
% Resolve overloading of instance methods before writing them
|
|
% to the `.opt' file.
|
|
:- pred intermod__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.
|
|
|
|
intermod__qualify_instance_method(ModuleInfo,
|
|
MethodCallPredId - InstanceMethod0,
|
|
InstanceMethod, PredIds0, PredIds) :-
|
|
module_info_pred_info(ModuleInfo, MethodCallPredId,
|
|
MethodCallPredInfo),
|
|
pred_info_arg_types(MethodCallPredInfo, MethodCallTVarSet, _,
|
|
MethodCallArgTypes),
|
|
InstanceMethod0 = instance_method(PredOrFunc, MethodName,
|
|
InstanceMethodDefn0, MethodArity, MethodContext),
|
|
(
|
|
InstanceMethodDefn0 = name(InstanceMethodName0),
|
|
PredOrFunc = function,
|
|
(
|
|
find_func_matching_instance_method(ModuleInfo,
|
|
InstanceMethodName0, MethodArity,
|
|
MethodCallTVarSet, MethodCallArgTypes,
|
|
MaybePredId, InstanceMethodName)
|
|
->
|
|
( MaybePredId = yes(PredId) ->
|
|
PredIds = [PredId | PredIds0]
|
|
;
|
|
PredIds = PredIds0
|
|
),
|
|
InstanceMethodDefn = name(InstanceMethodName)
|
|
;
|
|
% This will force intermod__add_proc to
|
|
% return DoWrite = no
|
|
PredId = invalid_pred_id,
|
|
PredIds = [PredId | PredIds0],
|
|
|
|
% We can just leave the method definition unchanged
|
|
InstanceMethodDefn = InstanceMethodDefn0
|
|
)
|
|
;
|
|
InstanceMethodDefn0 = name(InstanceMethodName0),
|
|
PredOrFunc = predicate,
|
|
init_markers(Markers),
|
|
typecheck__resolve_pred_overloading(ModuleInfo, Markers,
|
|
MethodCallArgTypes, MethodCallTVarSet,
|
|
InstanceMethodName0, InstanceMethodName, PredId),
|
|
PredIds = [PredId | PredIds0],
|
|
InstanceMethodDefn = name(InstanceMethodName)
|
|
;
|
|
InstanceMethodDefn0 = 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 intermod__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, list(type)::in, maybe(pred_id)::out,
|
|
sym_name::out) is semidet.
|
|
|
|
find_func_matching_instance_method(ModuleInfo, InstanceMethodName0,
|
|
MethodArity, MethodCallTVarSet, MethodCallArgTypes,
|
|
MaybePredId, InstanceMethodName) :-
|
|
|
|
module_info_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_ctors(ModuleInfo, Ctors),
|
|
(
|
|
map__search(Ctors, cons(InstanceMethodName0, MethodArity),
|
|
MatchingConstructors)
|
|
->
|
|
TypeCtors1 = list__map(
|
|
(func(ConsDefn) = TypeCtor :-
|
|
ConsDefn = hlds_cons_defn(_, _, _, TypeCtor, _)
|
|
), MatchingConstructors)
|
|
;
|
|
TypeCtors1 = []
|
|
),
|
|
TypeCtors = list__append(TypeCtors0, TypeCtors1),
|
|
|
|
module_info_get_predicate_table(ModuleInfo, PredicateTable),
|
|
(
|
|
predicate_table_search_func_sym_arity(PredicateTable,
|
|
may_be_partially_qualified, InstanceMethodName0,
|
|
MethodArity, PredIds),
|
|
typecheck__find_matching_pred_id(PredIds, ModuleInfo,
|
|
MethodCallTVarSet, MethodCallArgTypes,
|
|
PredId, InstanceMethodFuncName)
|
|
->
|
|
TypeCtors = [],
|
|
MaybePredId = yes(PredId),
|
|
InstanceMethodName = InstanceMethodFuncName
|
|
;
|
|
TypeCtors = [TheTypeCtor],
|
|
MaybePredId = no,
|
|
( TheTypeCtor = qualified(TypeModule, _) - _ ->
|
|
unqualify_name(InstanceMethodName0, UnqualMethodName),
|
|
InstanceMethodName =
|
|
qualified(TypeModule, UnqualMethodName)
|
|
;
|
|
error("unqualified type_ctor in " ++
|
|
"hlds_cons_defn or hlds_ctor_field_defn")
|
|
)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred intermod__gather_types(intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod__gather_types(!Info) :-
|
|
intermod_info_get_module_info(ModuleInfo, !Info),
|
|
module_info_types(ModuleInfo, Types),
|
|
map__foldl(intermod__gather_types_2, Types, !Info).
|
|
|
|
:- pred intermod__gather_types_2(type_ctor::in, hlds_type_defn::in,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
|
|
intermod__gather_types_2(TypeCtor, TypeDefn0, !Info) :-
|
|
intermod_info_get_module_info(ModuleInfo, !Info),
|
|
module_info_name(ModuleInfo, ModuleName),
|
|
(
|
|
intermod__should_write_type(ModuleName, TypeCtor, TypeDefn0)
|
|
->
|
|
hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
|
|
(
|
|
TypeBody0 = du_type(Ctors, Tags, Enum,
|
|
MaybeUserEqComp0, ReservedTag, MaybeForeign0)
|
|
->
|
|
module_info_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).
|
|
%
|
|
(
|
|
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),
|
|
intermod__resolve_foreign_type_body_overloading(
|
|
ModuleInfo, TypeCtor, ForeignTypeBody0,
|
|
ForeignTypeBody, !Info),
|
|
MaybeForeign = yes(ForeignTypeBody),
|
|
MaybeUserEqComp = MaybeUserEqComp0
|
|
;
|
|
intermod__resolve_unify_compare_overloading(
|
|
ModuleInfo, TypeCtor,
|
|
MaybeUserEqComp0, MaybeUserEqComp,
|
|
!Info),
|
|
MaybeForeign = MaybeForeign0
|
|
),
|
|
TypeBody = du_type(Ctors, Tags, Enum,
|
|
MaybeUserEqComp, ReservedTag, MaybeForeign),
|
|
hlds_data__set_type_defn_body(TypeBody,
|
|
TypeDefn0, TypeDefn)
|
|
;
|
|
TypeBody0 = foreign_type(ForeignTypeBody0)
|
|
->
|
|
% The header code must be written since
|
|
% it could be used by the foreign type.
|
|
intermod_info_set_write_header(!Info),
|
|
intermod__resolve_foreign_type_body_overloading(
|
|
ModuleInfo, TypeCtor,
|
|
ForeignTypeBody0, ForeignTypeBody, !Info),
|
|
TypeBody = foreign_type(ForeignTypeBody),
|
|
hlds_data__set_type_defn_body(TypeBody,
|
|
TypeDefn0, TypeDefn)
|
|
;
|
|
TypeDefn = TypeDefn0
|
|
),
|
|
intermod_info_get_types(Types0, !Info),
|
|
intermod_info_set_types([TypeCtor - TypeDefn | Types0], !Info)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred intermod__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.
|
|
|
|
intermod__resolve_foreign_type_body_overloading(ModuleInfo,
|
|
TypeCtor, foreign_type_body(MaybeIL0, MaybeC0, MaybeJava0),
|
|
foreign_type_body(MaybeIL, MaybeC, MaybeJava), !Info) :-
|
|
module_info_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 = c ; Target = asm ) ->
|
|
intermod__resolve_foreign_type_body_overloading_2(ModuleInfo,
|
|
TypeCtor, MaybeC0, MaybeC, !Info)
|
|
;
|
|
MaybeC = MaybeC0
|
|
),
|
|
( Target = il ->
|
|
intermod__resolve_foreign_type_body_overloading_2(ModuleInfo,
|
|
TypeCtor, MaybeIL0, MaybeIL, !Info)
|
|
;
|
|
MaybeIL = MaybeIL0
|
|
),
|
|
( Target = java ->
|
|
intermod__resolve_foreign_type_body_overloading_2(ModuleInfo,
|
|
TypeCtor, MaybeJava0, MaybeJava, !Info)
|
|
;
|
|
MaybeJava = MaybeJava0
|
|
).
|
|
|
|
:- pred intermod__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.
|
|
|
|
intermod__resolve_foreign_type_body_overloading_2(_, _, no, no, !Info).
|
|
intermod__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) :-
|
|
intermod__resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
|
|
MaybeUserEqComp0, MaybeUserEqComp, !Info).
|
|
|
|
:- pred intermod__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.
|
|
|
|
intermod__resolve_unify_compare_overloading(_, _, no, no, !Info).
|
|
intermod__resolve_unify_compare_overloading(_, _,
|
|
yes(abstract_noncanonical_type(IsSolverType)),
|
|
yes(abstract_noncanonical_type(IsSolverType)),
|
|
!Info).
|
|
intermod__resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
|
|
yes(unify_compare(MaybeUserEq0, MaybeUserCompare0)),
|
|
yes(unify_compare(MaybeUserEq, MaybeUserCompare)),
|
|
!Info) :-
|
|
intermod__resolve_user_special_pred_overloading(ModuleInfo,
|
|
unify, TypeCtor, MaybeUserEq0, MaybeUserEq, !Info),
|
|
intermod__resolve_user_special_pred_overloading(ModuleInfo,
|
|
compare, TypeCtor, MaybeUserCompare0, MaybeUserCompare, !Info).
|
|
|
|
:- pred intermod__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.
|
|
|
|
intermod__resolve_user_special_pred_overloading(_, _, _, no, no, !Info).
|
|
intermod__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_arg_types(UnifyPredInfo, TVarSet, _, ArgTypes),
|
|
init_markers(Markers0),
|
|
add_marker(calls_are_fully_qualified, Markers0, Markers),
|
|
typecheck__resolve_pred_overloading(ModuleInfo, Markers, ArgTypes,
|
|
TVarSet, Pred0, Pred, UserEqPredId),
|
|
intermod__add_proc(UserEqPredId, _, !Info).
|
|
|
|
:- pred intermod__should_write_type(module_name::in,
|
|
type_ctor::in, hlds_type_defn::in) is semidet.
|
|
|
|
intermod__should_write_type(ModuleName, TypeCtor, TypeDefn) :-
|
|
hlds_data__get_type_defn_status(TypeDefn, ImportStatus),
|
|
TypeCtor = Name - _Arity,
|
|
Name = qualified(ModuleName, _),
|
|
import_status_to_write(ImportStatus).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Output module imports, types, modes, insts and predicates
|
|
|
|
:- pred intermod__write_intermod_info(intermod_info::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_intermod_info(IntermodInfo0, !IO) :-
|
|
intermod_info_get_module_info(ModuleInfo,
|
|
IntermodInfo0, IntermodInfo1),
|
|
module_info_name(ModuleInfo, ModuleName),
|
|
io__write_string(":- module ", !IO),
|
|
mercury_output_bracketed_sym_name(ModuleName, !IO),
|
|
io__write_string(".\n", !IO),
|
|
|
|
intermod_info_get_preds(Preds, IntermodInfo1, IntermodInfo2),
|
|
intermod_info_get_pred_decls(PredDecls,
|
|
IntermodInfo2, IntermodInfo3),
|
|
intermod_info_get_instances(Instances,
|
|
IntermodInfo3, IntermodInfo),
|
|
(
|
|
%
|
|
% If none of these item types need writing, nothing
|
|
% else needs to be written.
|
|
%
|
|
set__empty(Preds),
|
|
set__empty(PredDecls),
|
|
Instances = [],
|
|
module_info_types(ModuleInfo, Types),
|
|
\+ (
|
|
map__member(Types, _, TypeDefn),
|
|
hlds_data__get_type_defn_status(TypeDefn, Status),
|
|
( Status = abstract_exported
|
|
; Status = exported_to_submodules
|
|
)
|
|
)
|
|
->
|
|
true
|
|
;
|
|
intermod__write_intermod_info_2(IntermodInfo, !IO)
|
|
).
|
|
|
|
:- pred intermod__write_intermod_info_2(intermod_info::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_intermod_info_2(IntermodInfo, !IO) :-
|
|
IntermodInfo = 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 this could be reduced to the set that is
|
|
% actually needed by the items being written.
|
|
io__write_string(":- use_module ", !IO),
|
|
intermod__write_modules(Modules, !IO)
|
|
;
|
|
Modules = []
|
|
),
|
|
|
|
intermod__write_types(Types, !IO),
|
|
intermod__write_insts(ModuleInfo, !IO),
|
|
intermod__write_modes(ModuleInfo, !IO),
|
|
intermod__write_classes(ModuleInfo, !IO),
|
|
intermod__write_instances(Instances, !IO),
|
|
|
|
% Disable verbose dumping of clauses.
|
|
globals__io_lookup_string_option(dump_hlds_options, VerboseDump, !IO),
|
|
globals__io_set_option(dump_hlds_options, string(""), !IO),
|
|
(
|
|
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(Lang,
|
|
Import, _),
|
|
mercury_output_pragma_foreign_import_module(
|
|
Lang, Import, IO0, IO)
|
|
), ForeignImports, !IO)
|
|
;
|
|
WriteHeader = no
|
|
),
|
|
intermod__write_pred_decls(ModuleInfo, PredDecls, !IO),
|
|
intermod__write_preds(ModuleInfo, Preds, !IO),
|
|
globals__io_set_option(dump_hlds_options, string(VerboseDump), !IO).
|
|
|
|
:- pred intermod__write_modules(list(module_name)::in, io::di, io::uo) is det.
|
|
|
|
intermod__write_modules([], !IO).
|
|
intermod__write_modules([Module | Rest], !IO) :-
|
|
mercury_output_bracketed_sym_name(Module, !IO),
|
|
(
|
|
Rest = [],
|
|
io__write_string(".\n", !IO)
|
|
;
|
|
Rest = [_ | _],
|
|
io__write_string(", ", !IO),
|
|
intermod__write_modules(Rest, !IO)
|
|
).
|
|
|
|
:- pred intermod__write_types(assoc_list(type_ctor, hlds_type_defn)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_types(Types, !IO) :-
|
|
list__foldl(intermod__write_type, Types, !IO).
|
|
|
|
:- pred intermod__write_type(pair(type_ctor, hlds_type_defn)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_type(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 = Name - Arity,
|
|
(
|
|
Ctors = Body ^ du_type_ctors,
|
|
MaybeUserEqComp = Body ^ du_type_usereq,
|
|
TypeBody = du_type(Ctors, MaybeUserEqComp)
|
|
;
|
|
Body = eqv_type(EqvType),
|
|
TypeBody = eqv_type(EqvType)
|
|
;
|
|
Body = abstract_type(IsSolverType),
|
|
TypeBody = abstract_type(IsSolverType)
|
|
;
|
|
Body = foreign_type(_),
|
|
TypeBody = abstract_type(non_solver_type)
|
|
;
|
|
Body = solver_type(SolverTypeDetails, MaybeUserEqComp),
|
|
TypeBody = solver_type(SolverTypeDetails, MaybeUserEqComp)
|
|
),
|
|
mercury_output_item(
|
|
type_defn(VarSet, Name, Args, TypeBody, true),
|
|
Context, !IO),
|
|
(
|
|
( Body = foreign_type(ForeignTypeBody)
|
|
; Body ^ du_type_is_foreign_type = yes(ForeignTypeBody)
|
|
),
|
|
ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC,
|
|
MaybeJava)
|
|
->
|
|
(
|
|
MaybeIL = yes(DataIL),
|
|
DataIL = foreign_type_lang_data(ILForeignType,
|
|
ILMaybeUserEqComp, AssertionsIL),
|
|
mercury_output_item(
|
|
type_defn(VarSet, Name, Args,
|
|
foreign_type(il(ILForeignType),
|
|
ILMaybeUserEqComp,
|
|
AssertionsIL),
|
|
true),
|
|
Context, !IO)
|
|
;
|
|
MaybeIL = no
|
|
),
|
|
(
|
|
MaybeC = yes(DataC),
|
|
DataC = foreign_type_lang_data(CForeignType,
|
|
CMaybeUserEqComp, AssertionsC),
|
|
mercury_output_item(
|
|
type_defn(VarSet, Name, Args,
|
|
foreign_type(c(CForeignType),
|
|
CMaybeUserEqComp,
|
|
AssertionsC),
|
|
true),
|
|
Context, !IO)
|
|
;
|
|
MaybeC = no
|
|
),
|
|
(
|
|
MaybeJava = yes(DataJava),
|
|
DataJava = foreign_type_lang_data(JavaForeignType,
|
|
JavaMaybeUserEqComp, AssertionsJava),
|
|
mercury_output_item(
|
|
type_defn(VarSet, Name, Args,
|
|
foreign_type(java(JavaForeignType),
|
|
JavaMaybeUserEqComp,
|
|
AssertionsJava),
|
|
true),
|
|
Context, !IO)
|
|
;
|
|
MaybeJava = no
|
|
)
|
|
;
|
|
true
|
|
),
|
|
(
|
|
ReservedTag = Body ^ du_type_reserved_tag,
|
|
ReservedTag = yes
|
|
->
|
|
mercury_output_item(pragma(reserve_tag(Name, Arity)),
|
|
Context, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred intermod__write_modes(module_info::in, io::di, io::uo) is det.
|
|
|
|
intermod__write_modes(ModuleInfo, !IO) :-
|
|
module_info_name(ModuleInfo, ModuleName),
|
|
module_info_modes(ModuleInfo, Modes),
|
|
mode_table_get_mode_defns(Modes, ModeDefns),
|
|
map__foldl(intermod__write_mode(ModuleName), ModeDefns, !IO).
|
|
|
|
:- pred intermod__write_mode(module_name::in, mode_id::in, hlds_mode_defn::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_mode(ModuleName, ModeId, ModeDefn, !IO) :-
|
|
ModeId = SymName - _Arity,
|
|
ModeDefn = hlds_mode_defn(Varset, Args, eqv_mode(Mode), Context,
|
|
ImportStatus),
|
|
(
|
|
SymName = qualified(ModuleName, _),
|
|
import_status_to_write(ImportStatus)
|
|
->
|
|
mercury_output_item(
|
|
mode_defn(Varset, SymName, Args, eqv_mode(Mode), true),
|
|
Context, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred intermod__write_insts(module_info::in, io::di, io::uo) is det.
|
|
|
|
intermod__write_insts(ModuleInfo, !IO) :-
|
|
module_info_name(ModuleInfo, ModuleName),
|
|
module_info_insts(ModuleInfo, Insts),
|
|
inst_table_get_user_insts(Insts, UserInsts),
|
|
user_inst_table_get_inst_defns(UserInsts, InstDefns),
|
|
map__foldl(intermod__write_inst(ModuleName), InstDefns, !IO).
|
|
|
|
:- pred intermod__write_inst(module_name::in, inst_id::in, hlds_inst_defn::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_inst(ModuleName, InstId, InstDefn, !IO) :-
|
|
InstId = 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
|
|
),
|
|
mercury_output_item(
|
|
inst_defn(Varset, SymName, Args, InstBody, true),
|
|
Context, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
:- pred intermod__write_classes(module_info::in, io::di, io::uo) is det.
|
|
|
|
intermod__write_classes(ModuleInfo, !IO) :-
|
|
module_info_name(ModuleInfo, ModuleName),
|
|
module_info_classes(ModuleInfo, Classes),
|
|
map__foldl(intermod__write_class(ModuleName), Classes, !IO).
|
|
|
|
:- pred intermod__write_class(module_name::in, class_id::in,
|
|
hlds_class_defn::in, io::di, io::uo) is det.
|
|
|
|
intermod__write_class(ModuleName, ClassId, ClassDefn, !IO) :-
|
|
ClassDefn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
|
|
_Ancestors, TVars, 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),
|
|
Item = typeclass(Constraints, FunDeps, QualifiedClassName,
|
|
TVars, Interface, TVarSet),
|
|
mercury_output_item(Item, Context, !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(P) :-
|
|
P = (pred(TVar::out) is nondet :-
|
|
set.member(N, Set),
|
|
TVar = list.index1_det(TVars, N)
|
|
).
|
|
|
|
:- pred intermod__write_instances(assoc_list(class_id, hlds_instance_defn)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_instances(Instances, !IO) :-
|
|
list__foldl(intermod__write_instance, Instances, !IO).
|
|
|
|
:- pred intermod__write_instance(pair(class_id, hlds_instance_defn)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_instance(ClassId - InstanceDefn, !IO) :-
|
|
InstanceDefn = hlds_instance_defn(ModuleName, _, Context,
|
|
Constraints, Types, Body, _, TVarSet, _),
|
|
ClassId = class_id(ClassName, _),
|
|
Item = instance(Constraints, ClassName, Types, Body, TVarSet,
|
|
ModuleName),
|
|
mercury_output_item(Item, Context, !IO).
|
|
|
|
% We need to write all the declarations for local predicates so
|
|
% the procedure labels for the C code are calculated correctly.
|
|
:- pred intermod__write_pred_decls(module_info::in, list(pred_id)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_pred_decls(_, [], !IO).
|
|
intermod__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_arg_types(PredInfo, TVarSet, ExistQVars, ArgTypes),
|
|
pred_info_context(PredInfo, Context),
|
|
pred_info_get_purity(PredInfo, Purity),
|
|
pred_info_get_class_context(PredInfo, ClassContext),
|
|
pred_info_get_goal_type(PredInfo, GoalType),
|
|
(
|
|
GoalType = pragmas,
|
|
% 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 = clauses_and_pragmas,
|
|
% Because pragmas may be present, we treat this case like
|
|
% pragmas above.
|
|
AppendVarNums = no
|
|
;
|
|
GoalType = clauses,
|
|
AppendVarNums = yes
|
|
;
|
|
GoalType = promise(_),
|
|
AppendVarNums = yes
|
|
;
|
|
GoalType = none,
|
|
AppendVarNums = yes
|
|
),
|
|
(
|
|
PredOrFunc = predicate,
|
|
mercury_output_pred_type(TVarSet, ExistQVars,
|
|
qualified(Module, Name), ArgTypes, no, Purity,
|
|
ClassContext, Context, AppendVarNums, !IO)
|
|
;
|
|
PredOrFunc = 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_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),
|
|
intermod__write_pred_modes(Procs, qualified(Module, Name),
|
|
PredOrFunc, SortedProcIds, !IO),
|
|
intermod__write_pragmas(PredInfo, !IO),
|
|
intermod__write_type_spec_pragmas(ModuleInfo, PredId, !IO),
|
|
intermod__write_pred_decls(ModuleInfo, PredIds, !IO).
|
|
|
|
:- pred intermod__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.
|
|
|
|
intermod__write_pred_modes(_, _, _, [], !IO).
|
|
intermod__write_pred_modes(Procs, SymName, PredOrFunc, [ProcId | ProcIds],
|
|
!IO) :-
|
|
map__lookup(Procs, ProcId, ProcInfo),
|
|
proc_info_maybe_declared_argmodes(ProcInfo, MaybeArgModes),
|
|
proc_info_declared_determinism(ProcInfo, MaybeDetism),
|
|
(
|
|
MaybeArgModes = yes(ArgModes0),
|
|
MaybeDetism = yes(Detism0)
|
|
->
|
|
ArgModes = ArgModes0,
|
|
Detism = Detism0
|
|
;
|
|
error("intermod__write_pred_modes: " ++
|
|
"attempt to write undeclared mode")
|
|
),
|
|
proc_info_context(ProcInfo, Context),
|
|
varset__init(Varset),
|
|
(
|
|
PredOrFunc = function,
|
|
pred_args_to_func_args(ArgModes, FuncArgModes, FuncRetMode),
|
|
mercury_output_func_mode_decl(Varset, SymName,
|
|
FuncArgModes, FuncRetMode,
|
|
yes(Detism), Context, !IO)
|
|
;
|
|
PredOrFunc = predicate,
|
|
mercury_output_pred_mode_decl(Varset, SymName, ArgModes,
|
|
yes(Detism), Context, !IO)
|
|
),
|
|
intermod__write_pred_modes(Procs, SymName, PredOrFunc, ProcIds, !IO).
|
|
|
|
:- pred intermod__write_preds(module_info::in, list(pred_id)::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_preds(_, [], !IO).
|
|
intermod__write_preds(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),
|
|
intermod__write_pragmas(PredInfo, !IO),
|
|
% The type specialization pragmas for exported preds should
|
|
% already be in the interface file.
|
|
|
|
pred_info_clauses_info(PredInfo, ClausesInfo),
|
|
clauses_info_varset(ClausesInfo, VarSet),
|
|
clauses_info_headvars(ClausesInfo, HeadVars),
|
|
clauses_info_clauses(ClausesInfo, Clauses),
|
|
|
|
( pred_info_get_goal_type(PredInfo, promise(PromiseType)) ->
|
|
( Clauses = [Clause] ->
|
|
hlds_out__write_promise(PromiseType, 0, ModuleInfo,
|
|
PredId, VarSet, no, HeadVars,
|
|
PredOrFunc, Clause, no, !IO)
|
|
;
|
|
error("intermod__write_preds: " ++
|
|
"assertion not a single clause.")
|
|
)
|
|
;
|
|
list__foldl(intermod__write_clause(ModuleInfo, PredId, VarSet,
|
|
HeadVars, PredOrFunc, SymName), Clauses, !IO)
|
|
),
|
|
intermod__write_preds(ModuleInfo, PredIds, !IO).
|
|
|
|
:- pred intermod__write_clause(module_info::in, pred_id::in, prog_varset::in,
|
|
list(prog_var)::in, pred_or_func::in, sym_name::in, clause::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_clause(ModuleInfo, PredId, VarSet, HeadVars,
|
|
PredOrFunc, _SymName, Clause0, !IO) :-
|
|
Clause0 = clause(_, _, 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,
|
|
MaybeVarTypes = no,
|
|
hlds_out__write_clause(1, ModuleInfo, PredId, VarSet, AppendVarNums,
|
|
ClauseHeadVars, PredOrFunc, Clause, UseDeclaredModes,
|
|
MaybeVarTypes, !IO).
|
|
|
|
intermod__write_clause(ModuleInfo, PredId, VarSet, _HeadVars,
|
|
PredOrFunc, SymName, Clause, !IO) :-
|
|
Clause = clause(ProcIds, Goal, foreign_language(_), _),
|
|
module_info_pred_info(ModuleInfo, PredId, PredInfo),
|
|
pred_info_procedures(PredInfo, Procs),
|
|
(
|
|
(
|
|
% Pull the foreign code out of the goal.
|
|
Goal = conj(Goals) - _,
|
|
list__filter((pred(X::in) is semidet :-
|
|
X = foreign_proc(_, _, _, _, _, _) - _
|
|
), Goals, [ForeignCodeGoal]),
|
|
ForeignCodeGoal = foreign_proc(Attributes,
|
|
_, _, Args, _, PragmaCode) - _
|
|
;
|
|
Goal = foreign_proc(Attributes,
|
|
_, _, Args, _, PragmaCode) - _
|
|
)
|
|
->
|
|
list__foldl(intermod__write_foreign_clause(Procs, PredOrFunc,
|
|
PragmaCode, Attributes, Args, VarSet, SymName),
|
|
ProcIds, !IO)
|
|
;
|
|
error("foreign_proc expected within this goal")
|
|
).
|
|
|
|
:- pred intermod__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.
|
|
|
|
intermod__write_foreign_clause(Procs, PredOrFunc, PragmaImpl,
|
|
Attributes, Args, VarSet0, SymName, ProcId, !IO) :-
|
|
map__lookup(Procs, ProcId, ProcInfo),
|
|
proc_info_maybe_declared_argmodes(ProcInfo, MaybeArgModes),
|
|
( MaybeArgModes = yes(ArgModes) ->
|
|
get_pragma_foreign_code_vars(Args, ArgModes, VarSet0, VarSet,
|
|
PragmaVars),
|
|
mercury_output_pragma_foreign_code(Attributes, SymName,
|
|
PredOrFunc, PragmaVars, VarSet, PragmaImpl, !IO)
|
|
;
|
|
error("intermod__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 = _ - 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)
|
|
)
|
|
), 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 = unify(LHSVar, RHS, _, _, _) - _,
|
|
list__member(LHSVar, HeadVars),
|
|
(
|
|
RHS = var(RHSVar),
|
|
RHSTerm = term__variable(RHSVar)
|
|
;
|
|
RHS = functor(ConsId, _, Args),
|
|
term__context_init(Context),
|
|
(
|
|
ConsId = int_const(Int),
|
|
RHSTerm = term__functor(term__integer(Int),
|
|
[], Context)
|
|
;
|
|
ConsId = float_const(Float),
|
|
RHSTerm = term__functor(term__float(Float),
|
|
[], 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 intermod__write_pragmas(pred_info::in, io::di, io::uo) is det.
|
|
|
|
intermod__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),
|
|
intermod__write_pragmas(SymName, Arity, MarkerList, PredOrFunc, !IO).
|
|
|
|
:- pred intermod__write_pragmas(sym_name::in, int::in, list(marker)::in,
|
|
pred_or_func::in, io::di, io::uo) is det.
|
|
|
|
intermod__write_pragmas(_, _, [], _, !IO).
|
|
intermod__write_pragmas(SymName, Arity, [Marker | Markers], PredOrFunc, !IO) :-
|
|
intermod__should_output_marker(Marker, ShouldOutput),
|
|
( ShouldOutput = yes ->
|
|
hlds_out__marker_name(Marker, Name),
|
|
mercury_output_pragma_decl(SymName, Arity, PredOrFunc, Name,
|
|
!IO)
|
|
;
|
|
true
|
|
),
|
|
intermod__write_pragmas(SymName, Arity, Markers, PredOrFunc, !IO).
|
|
|
|
:- pred intermod__write_type_spec_pragmas(module_info::in, pred_id::in,
|
|
io::di, io::uo) is det.
|
|
|
|
intermod__write_type_spec_pragmas(ModuleInfo, PredId, !IO) :-
|
|
module_info_type_spec_info(ModuleInfo,
|
|
type_spec_info(_, _, _, PragmaMap)),
|
|
( multi_map__search(PragmaMap, PredId, TypeSpecPragmas) ->
|
|
list__foldl(
|
|
( pred(Pragma::in, IO0::di, IO::uo) is det :-
|
|
( Pragma = type_spec(_, _, _, _, _, _, _, _) ->
|
|
AppendVarnums = yes,
|
|
mercury_output_pragma_type_spec(Pragma,
|
|
AppendVarnums, IO0, IO)
|
|
;
|
|
error("write_type_spec_pragmas")
|
|
)
|
|
), TypeSpecPragmas, !IO)
|
|
;
|
|
true
|
|
).
|
|
|
|
% Is a pragma declaration required in the `.opt' file for
|
|
% a predicate with the given marker.
|
|
:- pred intermod__should_output_marker(marker::in, bool::out) is det.
|
|
|
|
intermod__should_output_marker(stub, no).
|
|
% Since the inferred declarations are output, these
|
|
% don't need to be done in the importing module.
|
|
intermod__should_output_marker(infer_type, no).
|
|
intermod__should_output_marker(infer_modes, no).
|
|
% Purity is output as part of the pred/func decl.
|
|
intermod__should_output_marker((impure), no).
|
|
intermod__should_output_marker((semipure), no).
|
|
% There is no pragma required for generated class methods.
|
|
intermod__should_output_marker(class_method, no).
|
|
intermod__should_output_marker(class_instance_method, no).
|
|
intermod__should_output_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.
|
|
intermod__should_output_marker(obsolete, no).
|
|
intermod__should_output_marker(inline, yes).
|
|
intermod__should_output_marker(no_inline, yes).
|
|
intermod__should_output_marker(dnf, yes).
|
|
intermod__should_output_marker(aditi, yes).
|
|
intermod__should_output_marker(base_relation, yes).
|
|
intermod__should_output_marker(aditi_memo, yes).
|
|
intermod__should_output_marker(aditi_no_memo, yes).
|
|
intermod__should_output_marker(naive, yes).
|
|
intermod__should_output_marker(psn, yes).
|
|
intermod__should_output_marker(supp_magic, yes).
|
|
intermod__should_output_marker(context, yes).
|
|
intermod__should_output_marker(promised_pure, yes).
|
|
intermod__should_output_marker(promised_semipure, yes).
|
|
intermod__should_output_marker(terminates, yes).
|
|
intermod__should_output_marker(does_not_terminate, yes).
|
|
% Termination should only be checked in the defining module.
|
|
intermod__should_output_marker(check_termination, no).
|
|
intermod__should_output_marker(generate_inline, _) :-
|
|
% This marker should only occur after the magic sets transformation.
|
|
error("intermod__should_output_marker: generate_inline").
|
|
intermod__should_output_marker(calls_are_fully_qualified, no).
|
|
|
|
:- pred get_pragma_foreign_code_vars(list(foreign_arg)::in, list(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),
|
|
varset__name_var(!.VarSet, Var, Name, !:VarSet),
|
|
get_pragma_foreign_code_vars(ArgsTail, ModesTail, !VarSet,
|
|
PragmaVarsTail),
|
|
PragmaVars = [PragmaVar | PragmaVarsTail]
|
|
;
|
|
Args = [],
|
|
Modes = []
|
|
->
|
|
PragmaVars = []
|
|
;
|
|
error("intermod:get_pragma_foreign_code_vars")
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% a collection of stuff to go in the .opt file
|
|
:- type intermod_info
|
|
---> info(
|
|
im_modules :: set(module_name),
|
|
% modules to import
|
|
im_preds :: set(pred_id),
|
|
% preds to output clauses for
|
|
im_pred_decls :: set(pred_id),
|
|
% preds to output decls for
|
|
im_instances :: assoc_list(class_id,
|
|
hlds_instance_defn),
|
|
% instances declarations to write
|
|
im_types :: assoc_list(type_ctor,
|
|
hlds_type_defn),
|
|
% type declarations to write
|
|
im_module_info :: module_info,
|
|
im_write_foreign_header :: bool,
|
|
% do the c_header_codes for the module
|
|
% need writing, yes if there are
|
|
% pragma_foreign_code procs being
|
|
% exported.
|
|
im_var_types :: vartypes,
|
|
im_tvarset :: tvarset
|
|
% Vartypes and tvarset for the
|
|
% current pred.
|
|
).
|
|
|
|
:- 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 = info(Modules, Procs, ProcDecls, Instances, Types,
|
|
ModuleInfo, no, VarTypes, TVarSet).
|
|
|
|
:- pred intermod_info_get_modules(set(module_name)::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_get_preds(set(pred_id)::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_get_pred_decls(set(pred_id)::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_get_instances(
|
|
assoc_list(class_id, hlds_instance_defn)::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_get_types(assoc_list(type_ctor, hlds_type_defn)::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
%:- pred intermod_info_get_insts(set(inst_id)::out,
|
|
% intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_get_module_info(module_info::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_get_write_foreign_header(bool::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_get_var_types(vartypes::out,
|
|
intermod_info::in, intermod_info::out) is det.
|
|
:- pred intermod_info_get_tvarset(tvarset::out,
|
|
intermod_info::in, intermod_info::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(map(prog_var, type)::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 ^ im_modules, Info, Info).
|
|
intermod_info_get_preds(Info ^ im_preds, Info, Info).
|
|
intermod_info_get_pred_decls(Info ^ im_pred_decls, Info, Info).
|
|
intermod_info_get_instances(Info ^ im_instances, Info, Info).
|
|
intermod_info_get_types(Info ^ im_types, Info, Info).
|
|
intermod_info_get_module_info(Info ^ im_module_info, Info, Info).
|
|
intermod_info_get_write_foreign_header(Info ^ im_write_foreign_header,
|
|
Info, Info).
|
|
intermod_info_get_var_types(Info ^ im_var_types, Info, Info).
|
|
intermod_info_get_tvarset(Info ^ im_tvarset, Info, Info).
|
|
|
|
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.
|
|
intermod__adjust_pred_import_status(Module0, Module, IO0, IO) :-
|
|
globals__io_lookup_bool_option(very_verbose, VVerbose, IO0, IO1),
|
|
maybe_write_string(VVerbose,
|
|
"% Adjusting import status of predicates in the `.opt' file...",
|
|
IO1, IO2),
|
|
|
|
init_intermod_info(Module0, Info0),
|
|
module_info_predids(Module0, PredIds),
|
|
module_info_globals(Module0, Globals),
|
|
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),
|
|
intermod__gather_preds(PredIds, yes, Threshold, HigherOrderSizeLimit,
|
|
Deforestation, Info0, Info1),
|
|
intermod__gather_instances(Info1, Info2),
|
|
intermod__gather_types(Info2, Info),
|
|
do_adjust_pred_import_status(Info, Module0, Module),
|
|
maybe_write_string(VVerbose, " done\n", IO2, IO).
|
|
|
|
:- pred do_adjust_pred_import_status(intermod_info::in,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
do_adjust_pred_import_status(Info, ModuleInfo0, ModuleInfo) :-
|
|
intermod_info_get_pred_decls(PredDecls0, Info, _),
|
|
set__to_sorted_list(PredDecls0, PredDecls),
|
|
set_list_of_preds_exported(PredDecls, ModuleInfo0, ModuleInfo1),
|
|
adjust_type_status(ModuleInfo1, ModuleInfo2),
|
|
adjust_class_status(ModuleInfo2, ModuleInfo3),
|
|
adjust_instance_status(ModuleInfo3, ModuleInfo).
|
|
|
|
:- pred adjust_type_status(module_info::in, module_info::out) is det.
|
|
|
|
adjust_type_status(!ModuleInfo) :-
|
|
module_info_types(!.ModuleInfo, Types0),
|
|
map__to_assoc_list(Types0, TypesAL0),
|
|
list__map_foldl(adjust_type_status_2, TypesAL0, TypesAL, !ModuleInfo),
|
|
map__from_assoc_list(TypesAL, Types),
|
|
module_info_set_types(Types, !ModuleInfo).
|
|
|
|
:- pred adjust_type_status_2(pair(type_ctor, hlds_type_defn)::in,
|
|
pair(type_ctor, hlds_type_defn)::out,
|
|
module_info::in, module_info::out) is det.
|
|
|
|
adjust_type_status_2(TypeCtor - TypeDefn0, TypeCtor - TypeDefn, !ModuleInfo) :-
|
|
module_info_name(!.ModuleInfo, ModuleName),
|
|
( intermod__should_write_type(ModuleName, TypeCtor, TypeDefn0) ->
|
|
hlds_data__set_type_defn_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_classes(!.ModuleInfo, Classes0),
|
|
map__to_assoc_list(Classes0, ClassAL0),
|
|
list__map_foldl(adjust_class_status_2, ClassAL0, ClassAL, !ModuleInfo),
|
|
map__from_assoc_list(ClassAL, Classes),
|
|
module_info_set_classes(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 := 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_instances(!.ModuleInfo, Instances0),
|
|
map__to_assoc_list(Instances0, InstanceAL0),
|
|
list__map_foldl(adjust_instance_status_2, InstanceAL0, InstanceAL,
|
|
!ModuleInfo),
|
|
map__from_assoc_list(InstanceAL, Instances),
|
|
module_info_set_instances(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,
|
|
ModuleInfo0, ModuleInfo) :-
|
|
list__map_foldl(adjust_instance_status_3, InstanceList0, InstanceList,
|
|
ModuleInfo0, 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, ModuleInfo0, ModuleInfo) :-
|
|
Instance0 = hlds_instance_defn(InstanceModule, Status0, Context,
|
|
Constraints, Types, Body, HLDSClassInterface,
|
|
TVarSet, ConstraintProofs),
|
|
(
|
|
import_status_to_write(Status0)
|
|
->
|
|
Instance = hlds_instance_defn(InstanceModule, exported,
|
|
Context, Constraints, Types, Body, HLDSClassInterface,
|
|
TVarSet, ConstraintProofs),
|
|
( HLDSClassInterface = yes(ClassInterface) ->
|
|
class_procs_to_pred_ids(ClassInterface, PredIds),
|
|
set_list_of_preds_exported(PredIds,
|
|
ModuleInfo0, ModuleInfo)
|
|
;
|
|
% This can happen if an instance has multiple
|
|
% declarations, one of which is abstract.
|
|
ModuleInfo = ModuleInfo0
|
|
)
|
|
;
|
|
ModuleInfo = ModuleInfo0,
|
|
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_import_status(PredInfo0, Status),
|
|
import_status_to_write(Status)
|
|
->
|
|
(
|
|
pred_info_get_origin(PredInfo0, Origin),
|
|
Origin = special_pred(unify - _)
|
|
->
|
|
NewStatus = pseudo_exported
|
|
;
|
|
Status = external(_)
|
|
->
|
|
NewStatus = external(opt_exported)
|
|
;
|
|
NewStatus = 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(imported(_)) = no.
|
|
import_status_to_write(abstract_imported) = no.
|
|
import_status_to_write(pseudo_imported) = no.
|
|
import_status_to_write(opt_imported) = no.
|
|
import_status_to_write(exported) = no.
|
|
import_status_to_write(opt_exported) = yes.
|
|
import_status_to_write(abstract_exported) = yes.
|
|
import_status_to_write(pseudo_exported) = no.
|
|
import_status_to_write(exported_to_submodules) = yes.
|
|
import_status_to_write(local) = yes.
|
|
import_status_to_write(external(Status)) = ToWrite :-
|
|
( status_is_exported(Status, yes) ->
|
|
ToWrite = no
|
|
;
|
|
ToWrite = yes
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Read in and process the optimization interfaces.
|
|
|
|
intermod__grab_optfiles(!Module, FoundError, !IO) :-
|
|
|
|
%
|
|
% Read in the .opt files for imported and ancestor modules.
|
|
%
|
|
ModuleName = !.Module ^ module_name,
|
|
Ancestors0 = !.Module ^ parent_deps,
|
|
InterfaceDeps0 = !.Module ^ int_deps,
|
|
ImplementationDeps0 = !.Module ^ impl_deps,
|
|
OptFiles = list__sort_and_remove_dups(list__condense(
|
|
[Ancestors0, InterfaceDeps0, ImplementationDeps0])),
|
|
globals__io_lookup_bool_option(read_opt_files_transitively,
|
|
Transitive, !IO),
|
|
ModulesProcessed = set__insert(set__sorted_list_to_set(OptFiles),
|
|
ModuleName),
|
|
read_optimization_interfaces(Transitive, ModuleName, OptFiles,
|
|
ModulesProcessed, [], OptItems, no, OptError, !IO),
|
|
|
|
%
|
|
% Append the items to the current item list, using
|
|
% a `opt_imported' psuedo-declaration to let
|
|
% make_hlds know the opt_imported stuff is coming.
|
|
%
|
|
module_imports_get_items(!.Module, Items0),
|
|
Items1 = Items0 ++ [make_pseudo_decl(opt_imported) | OptItems],
|
|
module_imports_set_items(Items1, !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.
|
|
%
|
|
globals__io_lookup_bool_option(intermod_unused_args, UnusedArgs, !IO),
|
|
(
|
|
UnusedArgs = yes,
|
|
read_optimization_interfaces(no, ModuleName, [ModuleName],
|
|
set__init, [], LocalItems, no, UAError, !IO),
|
|
IsPragmaUnusedArgs = (pred(Item::in) is semidet :-
|
|
Item = pragma(PragmaType) - _,
|
|
PragmaType = unused_args(_,_,_,_,_)
|
|
),
|
|
list__filter(IsPragmaUnusedArgs, LocalItems, PragmaItems),
|
|
|
|
module_imports_get_items(!.Module, Items2),
|
|
list__append(Items2, PragmaItems, Items),
|
|
module_imports_set_items(Items, !Module)
|
|
;
|
|
UnusedArgs = no,
|
|
UAError = 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(ReadModules, Int0Files,
|
|
make_pseudo_decl(opt_imported),
|
|
make_pseudo_decl(opt_imported),
|
|
[], AncestorImports1,
|
|
[], AncestorImports2, !Module, !IO),
|
|
|
|
%
|
|
% Figure out which .int files are needed by the .opt files
|
|
%
|
|
get_dependencies(OptItems, NewImportDeps0, NewUseDeps0),
|
|
globals__io_get_globals(Globals, !IO),
|
|
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(ReadModules, must_be_qualified, NewDeps,
|
|
".int",
|
|
make_pseudo_decl(opt_imported), make_pseudo_decl(opt_imported),
|
|
[], NewIndirectDeps, [], NewImplIndirectDeps, !Module, !IO),
|
|
process_module_short_interfaces_and_impls_transitively(
|
|
ReadModules, NewIndirectDeps ++ NewImplIndirectDeps, ".int2",
|
|
make_pseudo_decl(opt_imported), make_pseudo_decl(opt_imported),
|
|
!Module, !IO),
|
|
|
|
%
|
|
% Figure out whether anything went wrong
|
|
%
|
|
module_imports_get_error(!.Module, FoundError0),
|
|
(
|
|
( FoundError0 \= no_module_errors
|
|
; OptError = yes
|
|
; UAError = yes
|
|
)
|
|
->
|
|
FoundError = yes
|
|
;
|
|
FoundError = no
|
|
).
|
|
|
|
:- pred read_optimization_interfaces(bool::in, module_name::in,
|
|
list(module_name)::in, set(module_name)::in,
|
|
item_list::in, item_list::out, bool::in, bool::out,
|
|
io::di, io::uo) is det.
|
|
|
|
read_optimization_interfaces(_, _, [], _, !Items, !Error, !IO).
|
|
read_optimization_interfaces(Transitive, ModuleName,
|
|
[ModuleToRead | ModulesToRead], ModulesProcessed0,
|
|
!Items, !Error, !IO) :-
|
|
globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
|
|
maybe_write_string(VeryVerbose,
|
|
"% Reading optimization interface for module", !IO),
|
|
maybe_write_string(VeryVerbose, " `", !IO),
|
|
mdbcomp__prim_data__sym_name_to_string(ModuleToRead,
|
|
ModuleToReadString),
|
|
maybe_write_string(VeryVerbose, ModuleToReadString, !IO),
|
|
maybe_write_string(VeryVerbose, "'...\n", !IO),
|
|
maybe_flush_output(VeryVerbose, !IO),
|
|
|
|
module_name_to_search_file_name(ModuleToRead, ".opt", FileName, !IO),
|
|
prog_io__read_opt_file(FileName, ModuleToRead,
|
|
ModuleError, Messages, OptItems, !IO),
|
|
update_error_status(opt, FileName, ModuleError, Messages, !Error, !IO),
|
|
!:Items = !.Items ++ OptItems,
|
|
maybe_write_string(VeryVerbose, "% done.\n", !IO),
|
|
|
|
globals__io_get_globals(Globals, !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)
|
|
;
|
|
ModulesProcessed = ModulesProcessed0,
|
|
NewDeps = []
|
|
),
|
|
read_optimization_interfaces(Transitive, ModuleName,
|
|
NewDeps ++ ModulesToRead, ModulesProcessed,
|
|
!Items, !Error, !IO).
|
|
|
|
update_error_status(FileType, FileName, ModuleError, Messages,
|
|
!Error, !IO) :-
|
|
(
|
|
ModuleError = no_module_errors
|
|
;
|
|
ModuleError = some_module_errors,
|
|
prog_out__write_messages(Messages, !IO),
|
|
!:Error = yes
|
|
;
|
|
ModuleError = fatal_module_errors,
|
|
(
|
|
FileType = opt,
|
|
WarningOption = warn_missing_opt_files
|
|
;
|
|
FileType = trans_opt,
|
|
WarningOption = warn_missing_trans_opt_files
|
|
),
|
|
globals__io_lookup_bool_option(WarningOption, DoWarn, !IO),
|
|
(
|
|
DoWarn = yes,
|
|
io__write_string("Warning: cannot open `", !IO),
|
|
io__write_string(FileName, !IO),
|
|
io__write_string("'.\n", !IO),
|
|
globals__io_lookup_bool_option(halt_at_warn,
|
|
HaltAtWarn, !IO),
|
|
(
|
|
HaltAtWarn = yes,
|
|
!:Error = yes
|
|
;
|
|
HaltAtWarn = no
|
|
)
|
|
;
|
|
DoWarn = no
|
|
)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|