mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-14 21:35:49 +00:00
Code Issues Projects Releases Wiki Activity
Files
672f77c4ecd07daaf01217bc81c336dcf5d6aa02
mercury/compiler/intermod.m
Zoltan Somogyi 672f77c4ec Add a new compiler option. --inform-ite-instead-of-switch. 
Estimated hours taken: 20
Branches: main

Add a new compiler option. --inform-ite-instead-of-switch. If this is enabled,
the compiler will generate informational messages about if-then-elses that
it thinks should be converted to switches for the sake of program reliability.

Act on the output generated by this option.

compiler/simplify.m:
	Implement the new option.

	Fix an old bug that could cause us to generate warnings about code
	that was OK in one duplicated copy but not in another (where a switch
	arm's code is duplicated due to the case being selected for more than
	one cons_id).

compiler/options.m:
	Add the new option.

	Add a way to test for the bug fix in simplify.

doc/user_guide.texi:
	Document the new option.

NEWS:
	Mention the new option.

library/*.m:
mdbcomp/*.m:
browser/*.m:
compiler/*.m:
deep_profiler/*.m:
	Convert if-then-elses to switches at most of the sites suggested by the
	new option. At the remaining sites, switching to switches would have
	nontrivial downsides. This typically happens with the switched-on type
	has many functors, and we treat one or two specially (e.g. cons/2 in
	the cons_id type).

	Perform misc cleanups in the vicinity of the if-then-else to switch
	conversions.

	In a few cases, improve the error messages generated.

compiler/accumulator.m:
compiler/hlds_goal.m:
	(Rename and) move insts for particular kinds of goal from
	accumulator.m to hlds_goal.m, to allow them to be used in other
	modules. Using these insts allowed us to eliminate some if-then-elses
	entirely.

compiler/exprn_aux.m:
	Instead of fixing some if-then-elses, delete the predicates containing
	them, since they aren't used, and (as pointed out by the new option)
	would need considerable other fixing if they were ever needed again.

compiler/lp_rational.m:
	Add prefixes to the names of the function symbols on some types,
	since without those prefixes, it was hard to figure out what type
	the switch corresponding to an old if-then-else was switching on.

tests/invalid/reserve_tag.err_exp:
	Expect a new, improved error message.
2007-11-23 07:36:01 +00:00

2411 lines
93 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2007 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% File: intermod.m.
% Main author: stayl.
%
% This module writes out the interface for inter-module optimization.
% The .opt file includes:
% - The clauses for exported preds that can be inlined.
% - The clauses for exported preds that have higher-order pred arguments.
% - The pred/mode declarations for local predicates that the
% above clauses use.
% - Non-exported types, insts and modes used by the above
% - Pragma reserve_tag, foreign_enum, or foreign_type declarations for
% any types output due to the line above
% - :- import_module declarations to import stuff used by the above.
% - pragma declarations for the exported preds.
% - pragma foreign_header declarations if any pragma_foreign_code
% preds are written.
% All these items should be module qualified.
%
% This module also contains predicates to read in the .opt files and
% to adjust the import status of local predicates which are exported for
% intermodule optimization.
%
% Note that predicates which call predicates that do not have mode or
% determinism declarations do not have clauses exported, since this would
% require running mode analysis and determinism analysis before writing the
% .opt file, significantly increasing compile time for a very small gain.
%
%-----------------------------------------------------------------------------%
:- module transform_hlds.intermod.
:- interface.
:- import_module hlds.hlds_module.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_item.
:- import_module parse_tree.prog_io.
:- import_module bool.
:- import_module io.
%-----------------------------------------------------------------------------%
% Open the file "<module-name>.opt.tmp", and write out the declarations
% and clauses for intermodule optimization. Note that update_interface
% and touch_interface_datestamp are called from mercury_compile.m since
% they must be called after unused_args.m appends its information
% to the .opt.tmp file.
%
:- pred write_opt_file(module_info::in, module_info::out, io::di, io::uo)
is det.
% Add the items from the .opt files of imported modules to
% the items for this module.
%
:- pred grab_opt_files(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 adjust_pred_import_status(module_info::in, module_info::out,
io::di, io::uo) is det.
:- type opt_file_type
---> opt_file
; trans_opt_file.
% update_error_status(OptFileType, FileName, Error, Messages, !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 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 hlds.goal_util.
:- import_module hlds.hlds_clauses.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_pred.
:- import_module hlds.pred_table.
:- import_module hlds.special_pred.
:- import_module libs.compiler_util.
:- import_module libs.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_type.
:- import_module parse_tree.prog_util.
:- import_module transform_hlds.inlining.
:- import_module assoc_list.
:- import_module getopt_io.
:- import_module int.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module multi_map.
:- import_module pair.
:- import_module set.
:- import_module solutions.
:- import_module string.
:- import_module term.
:- import_module varset.
%-----------------------------------------------------------------------------%
write_opt_file(!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_get_name(!.ModuleInfo, ModuleName),
module_name_to_file_name(ModuleName, ".opt.tmp", yes, TmpName, !IO),
io.open_output(TmpName, Result, !IO),
(
Result = error(Err),
Msg = io.error_message(Err),
io.write_string(Msg, !IO),
io.set_exit_status(1, !IO)
;
Result = ok(FileStream),
io.set_output_stream(FileStream, OutputStream, !IO),
module_info_predids(RealPredIds, !ModuleInfo),
module_info_get_assertion_table(!.ModuleInfo, AssertionTable),
assertion_table_pred_ids(AssertionTable, AssertPredIds),
list.append(AssertPredIds, RealPredIds, PredIds),
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),
some [!IntermodInfo] (
init_intermod_info(!.ModuleInfo, !:IntermodInfo),
gather_preds(PredIds, yes, Threshold, HigherOrderSizeLimit,
Deforestation, !IntermodInfo),
gather_instances(!IntermodInfo),
gather_types(!IntermodInfo),
write_intermod_info(!.IntermodInfo, !IO),
intermod_info_get_module_info(!.IntermodInfo, !:ModuleInfo),
io.set_output_stream(OutputStream, _, !IO),
io.close_output(FileStream, !IO),
do_adjust_pred_import_status(!.IntermodInfo, !ModuleInfo)
)
),
%
% Restore the option setting that we overrode above.
%
globals.io_set_option(line_numbers, bool(LineNumbers), !IO).
%-----------------------------------------------------------------------------%
%
% Predicates to gather items to output to .opt file
%
:- pred gather_preds(list(pred_id)::in, bool::in, int::in, int::in, bool::in,
intermod_info::in, intermod_info::out) is det.
gather_preds(AllPredIds, CollectTypes, InlineThreshold, HigherOrderSizeLimit,
Deforestation, !Info) :-
% First gather exported preds.
ProcessLocalPreds = no,
gather_pred_list(AllPredIds, ProcessLocalPreds, CollectTypes,
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info),
% Then gather preds used by exported preds (recursively).
set.init(ExtraExportedPreds0),
gather_preds_fixpoint(ExtraExportedPreds0, CollectTypes, InlineThreshold,
HigherOrderSizeLimit, Deforestation, !Info).
:- pred gather_preds_fixpoint(set(pred_id)::in, bool::in, int::in, int::in,
bool::in, intermod_info::in, intermod_info::out) is det.
gather_preds_fixpoint(ExtraExportedPreds0, CollectTypes, InlineThreshold,
HigherOrderSizeLimit, Deforestation, !Info) :-
intermod_info_get_pred_decls(!.Info, ExtraExportedPreds),
NewlyExportedPreds = set.to_sorted_list(
ExtraExportedPreds `set.difference` ExtraExportedPreds0),
(
NewlyExportedPreds = []
;
NewlyExportedPreds = [_ | _],
ProcessLocalPreds = yes,
gather_pred_list(NewlyExportedPreds, ProcessLocalPreds, CollectTypes,
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info),
gather_preds_fixpoint(ExtraExportedPreds, CollectTypes,
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info)
).
:- pred gather_pred_list(list(pred_id)::in, bool::in, bool::in,
int::in, int::in, bool::in, intermod_info::in, intermod_info::out) is det.
gather_pred_list([], _, _, _, _, _, !Info).
gather_pred_list([PredId | PredIds], ProcessLocalPreds, CollectTypes,
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info) :-
intermod_info_get_module_info(!.Info, ModuleInfo0),
module_info_preds(ModuleInfo0, PredTable0),
map.lookup(PredTable0, PredId, PredInfo0),
module_info_get_type_spec_info(ModuleInfo0, TypeSpecInfo),
TypeSpecInfo = type_spec_info(_, TypeSpecForcePreds, _, _),
pred_info_get_clauses_info(PredInfo0, ClausesInfo0),
(
clauses_info_get_explicit_vartypes(ClausesInfo0, ExplicitVarTypes),
map.is_empty(ExplicitVarTypes),
should_be_processed(ProcessLocalPreds, PredId, PredInfo0,
TypeSpecForcePreds, InlineThreshold, HigherOrderSizeLimit,
Deforestation, ModuleInfo0)
->
SavedInfo = !.Info,
% Write a declaration to the `.opt' file for
% `exported_to_submodules' predicates.
add_proc(PredId, DoWrite0, !Info),
clauses_info_get_clauses_rep(ClausesInfo0, ClausesRep0),
(
DoWrite0 = yes,
clauses_info_get_vartypes(ClausesInfo0, VarTypes),
pred_info_get_typevarset(PredInfo0, TVarSet),
intermod_info_set_var_types(VarTypes, !Info),
intermod_info_set_tvarset(TVarSet, !Info),
get_clause_list(ClausesRep0, Clauses0),
intermod_traverse_clauses(Clauses0, Clauses, DoWrite, !Info),
set_clause_list(Clauses, ClausesRep)
;
DoWrite0 = no,
ClausesRep = ClausesRep0,
DoWrite = no
),
(
DoWrite = yes,
clauses_info_set_clauses_rep(ClausesRep,
ClausesInfo0, ClausesInfo),
pred_info_set_clauses_info(ClausesInfo, PredInfo0, PredInfo),
map.det_update(PredTable0, PredId, PredInfo, PredTable),
module_info_set_preds(PredTable, ModuleInfo0, ModuleInfo),
intermod_info_get_preds(!.Info, Preds0),
( pred_info_pragma_goal_type(PredInfo) ->
% pragma foreign_decls must be written since their contents
% could be used by pragma foreign_procs.
intermod_info_set_write_header(!Info)
;
true
),
set.insert(Preds0, PredId, Preds),
intermod_info_set_preds(Preds, !Info),
intermod_info_set_module_info(ModuleInfo, !Info)
;
DoWrite = no,
% Remove any items added for the clauses for this predicate.
!:Info = SavedInfo
)
;
true
),
gather_pred_list(PredIds, ProcessLocalPreds, CollectTypes,
InlineThreshold, HigherOrderSizeLimit, Deforestation, !Info).
:- pred should_be_processed(bool::in, pred_id::in, pred_info::in,
set(pred_id)::in, int::in, int::in, bool::in,
module_info::in) is semidet.
should_be_processed(ProcessLocalPreds, PredId, PredInfo, TypeSpecForcePreds,
InlineThreshold, HigherOrderSizeLimit, Deforestation, ModuleInfo) :-
(
ProcessLocalPreds = no,
( pred_info_is_exported(PredInfo)
; pred_info_is_exported_to_submodules(PredInfo)
)
;
ProcessLocalPreds = yes,
pred_info_get_import_status(PredInfo, status_local)
),
(
pred_info_get_clauses_info(PredInfo, ClauseInfo),
clauses_info_clauses_only(ClauseInfo, Clauses),
[ProcId | _ProcIds] = pred_info_procids(PredInfo),
pred_info_get_procedures(PredInfo, Procs),
map.lookup(Procs, ProcId, ProcInfo),
% At this point, the goal size includes some dummy unifications
% HeadVar1 = X, HeadVar2 = Y, etc. which will be optimized away
% later. To counter for this, we add the arity to the size thresholds.
Arity = pred_info_orig_arity(PredInfo),
% Predicates with `class_method' markers contain class_method_call
% goals which can't be written to `.opt' files (they can't be read
% back in). They will be recreated in the importing module.
pred_info_get_markers(PredInfo, Markers),
\+ check_marker(Markers, marker_class_method),
\+ check_marker(Markers, marker_class_instance_method),
% Don't write stub clauses to `.opt' files.
\+ check_marker(Markers, marker_stub),
% Don't export builtins since they will be recreated in the
% importing module anyway.
\+ is_unify_or_compare_pred(PredInfo),
\+ pred_info_is_builtin(PredInfo),
% These will be recreated in the importing module.
\+ set.member(PredId, TypeSpecForcePreds),
% No point exporting code which isn't very inlinable.
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
\+ clauses_contain_noninlinable_foreign_code(Target, Clauses),
% Don't export tabled predicates since they are not inlinable.
proc_info_get_eval_method(ProcInfo, eval_normal),
(
inlining.is_simple_clause_list(Clauses, InlineThreshold + Arity),
pred_info_get_markers(PredInfo, Markers),
\+ check_marker(Markers, marker_user_marked_no_inline)
;
pred_info_requested_inlining(PredInfo)
;
% Mutable access preds should always be included in .opt files.
%
check_marker(Markers, marker_mutable_access_pred)
;
has_ho_input(ModuleInfo, ProcInfo),
clause_list_size(Clauses, GoalSize),
GoalSize =< HigherOrderSizeLimit + Arity
;
Deforestation = yes,
% Double the inline-threshold since goals we want to deforest
% will have at least two disjuncts. This allows one simple goal
% in each disjunct. The disjunction adds one to the goal size,
% hence the `+1'.
DeforestThreshold = InlineThreshold * 2 + 1,
inlining.is_simple_clause_list(Clauses, DeforestThreshold + Arity),
clause_list_is_deforestable(PredId, Clauses)
)
;
% Promises that are in the interface should always get included
% in the .opt file.
pred_info_get_goal_type(PredInfo, goal_type_promise(_))
).
% If the clauses contains foreign code which requires an external
% definition, there is not much point in exporting it.
%
:- pred clauses_contain_noninlinable_foreign_code(compilation_target::in,
list(clause)::in) is semidet.
clauses_contain_noninlinable_foreign_code(Target, [C | _Cs]) :-
Target = target_il,
Lang = C ^ clause_lang,
Lang = impl_lang_foreign(ForeignLang),
ForeignLang = lang_csharp.
clauses_contain_noninlinable_foreign_code(Target, [_ | Cs]) :-
clauses_contain_noninlinable_foreign_code(Target, Cs).
:- pred intermod_traverse_clauses(list(clause)::in, list(clause)::out,
bool::out, intermod_info::in, intermod_info::out) is det.
intermod_traverse_clauses([], [], yes, !Info).
intermod_traverse_clauses([clause(P, Goal0, L, C) | Clauses0],
[clause(P, Goal, L, C) | Clauses], DoWrite, !Info) :-
intermod_traverse_goal(Goal0, Goal, DoWrite1, !Info),
(
DoWrite1 = yes,
intermod_traverse_clauses(Clauses0, Clauses, DoWrite, !Info)
;
DoWrite1 = no,
Clauses = Clauses0,
DoWrite = no
).
:- pred has_ho_input(module_info::in, proc_info::in) is semidet.
has_ho_input(ModuleInfo, ProcInfo) :-
proc_info_get_headvars(ProcInfo, HeadVars),
proc_info_get_argmodes(ProcInfo, ArgModes),
proc_info_get_vartypes(ProcInfo, VarTypes),
check_for_ho_input_args(ModuleInfo, VarTypes, HeadVars, ArgModes).
:- pred check_for_ho_input_args(module_info::in, vartypes::in,
list(prog_var)::in, list(mer_mode)::in) is semidet.
check_for_ho_input_args(ModuleInfo, VarTypes,
[HeadVar | HeadVars], [ArgMode | ArgModes]) :-
(
mode_is_input(ModuleInfo, ArgMode),
map.lookup(VarTypes, HeadVar, Type),
classify_type(ModuleInfo, Type) = type_cat_higher_order
;
check_for_ho_input_args(ModuleInfo, VarTypes, HeadVars, ArgModes)
).
% Rough guess: a goal is deforestable if it contains a single
% top-level branched goal and is recursive.
%
:- pred clause_list_is_deforestable(pred_id::in, list(clause)::in) is semidet.
clause_list_is_deforestable(PredId, Clauses) :-
some [Clause1] (
list.member(Clause1, Clauses),
Clause1 = clause(_, Goal1, _, _),
goal_calls_pred_id(Goal1, PredId)
),
(
Clauses = [_, _ | _]
;
Clauses = [Clause2],
Clause2 = clause(_, Goal2, _, _),
goal_to_conj_list(Goal2, GoalList),
goal_contains_one_branched_goal(GoalList)
).
:- pred goal_contains_one_branched_goal(list(hlds_goal)::in) is semidet.
goal_contains_one_branched_goal(GoalList) :-
goal_contains_one_branched_goal(GoalList, no).
:- pred goal_contains_one_branched_goal(list(hlds_goal)::in, bool::in)
is semidet.
goal_contains_one_branched_goal([], yes).
goal_contains_one_branched_goal([Goal | Goals], FoundBranch0) :-
Goal = hlds_goal(GoalExpr, _),
(
goal_is_branched(GoalExpr),
FoundBranch0 = no,
FoundBranch = yes
;
goal_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(Goal0, Goal, DoWrite, !Info) :-
Goal0 = hlds_goal(GoalExpr0, GoalInfo),
intermod_traverse_goal_expr(GoalExpr0, GoalExpr, DoWrite, !Info),
Goal = hlds_goal(GoalExpr, GoalInfo).
:- pred intermod_traverse_goal_expr(hlds_goal_expr::in, hlds_goal_expr::out,
bool::out, intermod_info::in, intermod_info::out) is det.
intermod_traverse_goal_expr(conj(ConjType, Goals0), conj(ConjType, Goals),
DoWrite, !Info) :-
intermod_traverse_list_of_goals(Goals0, Goals, DoWrite, !Info).
intermod_traverse_goal_expr(disj(Goals0), disj(Goals), DoWrite, !Info) :-
intermod_traverse_list_of_goals(Goals0, Goals, DoWrite, !Info).
intermod_traverse_goal_expr(Goal, Goal, DoWrite, !Info) :-
Goal = plain_call(PredId, _, _, _, _, _),
% Ensure that the called predicate will be exported.
add_proc(PredId, DoWrite, !Info).
intermod_traverse_goal_expr(Goal @ generic_call(CallType, _, _, _), Goal,
DoWrite, !Info) :-
(
CallType = higher_order(_, _, _, _),
DoWrite = yes
;
( CallType = class_method(_, _, _, _)
; CallType = event_call(_)
; CallType = cast(_)
),
DoWrite = no
).
intermod_traverse_goal_expr(switch(Var, CanFail, Cases0),
switch(Var, CanFail, Cases), 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_expr(unify(LVar, RHS0, C, D, E),
unify(LVar, RHS, C, D, E), DoWrite, !Info) :-
module_qualify_unify_rhs(RHS0, RHS, DoWrite, !Info).
intermod_traverse_goal_expr(negation(Goal0), negation(Goal), DoWrite, !Info) :-
intermod_traverse_goal(Goal0, Goal, DoWrite, !Info).
intermod_traverse_goal_expr(scope(Reason, Goal0), scope(Reason, Goal),
DoWrite, !Info) :-
intermod_traverse_goal(Goal0, Goal, DoWrite, !Info).
intermod_traverse_goal_expr(if_then_else(Vars, Cond0, Then0, Else0),
if_then_else(Vars, Cond, Then, Else), 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_expr(Goal @ call_foreign_proc(_, _, _, _, _, _, _),
Goal, yes, !Info).
intermod_traverse_goal_expr(shorthand(_), _, _, _, _) :-
% These should have been expanded out by now.
unexpected(this_file, "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, !:DoWrite, !Info),
(
!.DoWrite = yes,
intermod_traverse_list_of_goals(Goals0, Goals, !:DoWrite, !Info)
;
!.DoWrite = no,
Goals = Goals0
).
:- pred intermod_traverse_cases(list(case)::in, list(case)::out, bool::out,
intermod_info::in, intermod_info::out) is det.
intermod_traverse_cases([], [], yes, !Info).
intermod_traverse_cases([case(F, Goal0) | Cases0],
[case(F, Goal) | Cases], !:DoWrite, !Info) :-
intermod_traverse_goal(Goal0, Goal, !:DoWrite, !Info),
(
!.DoWrite = yes,
intermod_traverse_cases(Cases0, Cases, !:DoWrite, !Info)
;
!.DoWrite = no,
Cases = Cases0
).
% add_proc/4 tries to do what ever is necessary to ensure that the
% specified predicate will be exported, so that it can be called from
% clauses in the `.opt' file. If it can't, then it returns DoWrite = no,
% which will prevent the caller from being included in the `.opt' file.
%
% If a proc called within an exported proc is local, we need to add
% a declaration for the called proc to the .opt file. If a proc called
% within an exported proc is from a different module, we need to include
% an `:- import_module' declaration to import that module in the `.opt'
% file.
%
:- pred add_proc(pred_id::in, bool::out,
intermod_info::in, intermod_info::out) is det.
add_proc(PredId, DoWrite, !Info) :-
( PredId = invalid_pred_id ->
% This will happen for type class instance methods defined using
% the clause syntax. Currently we can't handle intermodule
% optimization of those.
DoWrite = no
;
add_proc_2(PredId, DoWrite, !Info)
).
:- pred add_proc_2(pred_id::in, bool::out,
intermod_info::in, intermod_info::out) is det.
add_proc_2(PredId, DoWrite, !Info) :-
intermod_info_get_module_info(!.Info, ModuleInfo),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_get_import_status(PredInfo, Status),
ProcIds = pred_info_procids(PredInfo),
pred_info_get_markers(PredInfo, Markers),
(
%
% Calling compiler-generated procedures is fine; we don't need
% to output declarations for them to the `.opt' file, since they
% will be recreated every time anyway.
%
is_unify_or_compare_pred(PredInfo)
->
DoWrite = yes
;
%
% Don't write the caller to the `.opt' file if it calls a pred
% without mode or determinism decls, because we'd need to include
% the mode decls for the callee in the `.opt' file and (since
% writing the `.opt' file happens before mode inference) we can't
% do that because we don't know what the modes are.
%
% XXX This prevents intermodule optimizations in such cases,
% which is a pity.
%
(
check_marker(Markers, marker_infer_modes)
;
pred_info_get_procedures(PredInfo, Procs),
list.member(ProcId, ProcIds),
map.lookup(Procs, ProcId, ProcInfo),
proc_info_get_declared_determinism(ProcInfo, no)
)
->
DoWrite = no
;
% Goals which call impure predicates cannot be written due to
% limitations in mode analysis. The problem is that only head
% unifications are allowed to be reordered with impure goals.
%
% e.g
% p(A::in, B::in, C::out) :- impure foo(A, B, C).
% becomes
% p(HeadVar1, HeadVar2, HeadVar3) :-
% A = HeadVar1, B = HeadVar2, C = HeadVar3,
% impure foo(A, B, C).
%
% In the clauses written to `.opt' files, the head unifications
% are already expanded, and are expanded again when the `.opt' file
% is read in. The `C = HeadVar3' unification cannot be reordered
% with the impure goal, resulting in a mode error. Fixing this
% in mode analysis would be tricky.
% See tests/valid/impure_intermod.m.
%
% NOTE: the above restriction applies to user predicates. For
% the compiler generated mutable access predicates we can ensure
% that reordering is not necessary by construction, so it's safe
% to include them in .opt files.
%
pred_info_get_purity(PredInfo, purity_impure),
not check_marker(Markers, marker_mutable_access_pred)
->
DoWrite = no
;
%
% If a pred whose code we're going to put in the .opt file calls
% a predicate which is exported, then we don't need to do anything
% special.
%
(
Status = status_exported
;
Status = status_external(ExternalStatus),
status_is_exported(ExternalStatus) = yes
)
->
DoWrite = yes
;
%
% Declarations for class methods will be recreated from the class
% declaration in the `.opt' file. Declarations for local classes
% are always written to the `.opt' file.
%
pred_info_get_markers(PredInfo, Markers),
check_marker(Markers, marker_class_method)
->
DoWrite = yes
;
%
% If a pred whose code we're going to put in the `.opt' file calls
% a predicate which is local to that module, then we need to put
% the declaration for the called predicate in the `.opt' file.
%
import_status_to_write(Status)
->
DoWrite = yes,
intermod_info_get_pred_decls(!.Info, PredDecls0),
set.insert(PredDecls0, PredId, PredDecls),
intermod_info_set_pred_decls(PredDecls, !Info)
;
( Status = status_imported(_)
; Status = status_opt_imported
)
->
%
% Imported pred - add import for module.
%
DoWrite = yes,
PredModule = pred_info_module(PredInfo),
intermod_info_get_modules(!.Info, Modules0),
set.insert(Modules0, PredModule, Modules),
intermod_info_set_modules(Modules, !Info)
;
unexpected(this_file, "add_proc: unexpected status")
).
% Resolve overloading and module qualify everything in a unify_rhs.
% Fully module-qualify the right-hand-side of a unification.
% For function calls and higher-order terms, call add_proc
% so that the predicate or function will be exported if necessary.
%
:- pred module_qualify_unify_rhs(unify_rhs::in, unify_rhs::out, bool::out,
intermod_info::in, intermod_info::out) is det.
module_qualify_unify_rhs(RHS0, RHS, DoWrite, !Info) :-
(
RHS0 = rhs_var(_),
RHS = RHS0,
DoWrite = yes
;
RHS0 = rhs_lambda_goal(A, B, C, D, E, F, G, Goal0),
intermod_traverse_goal(Goal0, Goal, DoWrite, !Info),
RHS = rhs_lambda_goal(A, B, C, D, E, F, G, Goal)
;
RHS0 = rhs_functor(Functor, _Exist, _Vars),
RHS = RHS0,
% 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),
add_proc(PredId, DoWrite, !Info)
;
% It's an ordinary constructor, or a constant of a builtin type,
% so just leave it alone.
%
% Constructors are module qualified by post_typecheck.m.
%
% Function calls and higher-order function applications
% are transformed into ordinary calls and higher-order calls
% by post_typecheck.m, so they can't occur here.
DoWrite = yes
)
).
%-----------------------------------------------------------------------------%
:- pred gather_instances(intermod_info::in, intermod_info::out) is det.
gather_instances(!Info) :-
intermod_info_get_module_info(!.Info, ModuleInfo),
module_info_get_instance_table(ModuleInfo, Instances),
map.foldl(gather_instances_2(ModuleInfo), Instances, !Info).
:- pred gather_instances_2(module_info::in, class_id::in,
list(hlds_instance_defn)::in,
intermod_info::in, intermod_info::out) is det.
gather_instances_2(ModuleInfo, ClassId, InstanceDefns, !Info) :-
list.foldl(gather_instances_3(ModuleInfo, ClassId), InstanceDefns, !Info).
:- pred gather_instances_3(module_info::in, class_id::in,
hlds_instance_defn::in, intermod_info::in, intermod_info::out) is det.
gather_instances_3(ModuleInfo, ClassId, InstanceDefn, !Info) :-
InstanceDefn = hlds_instance_defn(A, Status, C, D, E, Interface0,
MaybePredProcIds, H, I),
DefinedThisModule = status_defined_in_this_module(Status),
(
DefinedThisModule = yes,
%
% The bodies are always stripped from instance declarations
% before writing them to `int' files, so the full instance
% declaration should be written even for exported instances.
%
SaveInfo = !.Info,
(
Interface0 = instance_body_concrete(Methods0),
(
MaybePredProcIds = yes(ClassProcs),
GetPredId =
(pred(Proc::in, PredId::out) is det :-
Proc = hlds_class_proc(PredId, _)
),
list.map(GetPredId, ClassProcs, ClassPreds0),
% The interface is sorted on pred_id.
list.remove_adjacent_dups(ClassPreds0, ClassPreds),
assoc_list.from_corresponding_lists(ClassPreds, Methods0,
MethodAL)
;
MaybePredProcIds = no,
unexpected(this_file,
"gather_instances_3: method pred_proc_ids not filled in")
),
list.map_foldl(qualify_instance_method(ModuleInfo),
MethodAL, Methods, [], PredIds),
list.map_foldl(add_proc, PredIds, DoWriteMethodsList, !Info),
bool.and_list(DoWriteMethodsList, DoWriteMethods),
(
DoWriteMethods = yes,
Interface = instance_body_concrete(Methods)
;
DoWriteMethods = no,
% Write an abstract instance declaration if any of the methods
% cannot be written to the `.opt' file for any reason.
Interface = instance_body_abstract,
% Don't write declarations for any of the methods if one
% can't be written.
!:Info = SaveInfo
)
;
Interface0 = instance_body_abstract,
Interface = Interface0
),
(
% Don't write an abstract instance declaration
% if the declaration is already in the `.int' file.
(
Interface = instance_body_abstract
=>
status_is_exported(Status) = no
)
->
InstanceDefnToWrite = hlds_instance_defn(A, Status, C, D, E,
Interface, MaybePredProcIds, H, I),
intermod_info_get_instances(!.Info, Instances0),
intermod_info_set_instances(
[ClassId - InstanceDefnToWrite | Instances0], !Info)
;
true
)
;
DefinedThisModule = no
).
% Resolve overloading of instance methods before writing them
% to the `.opt' file.
%
:- pred qualify_instance_method(module_info::in,
pair(pred_id, instance_method)::in, instance_method::out,
list(pred_id)::in, list(pred_id)::out) is det.
qualify_instance_method(ModuleInfo, MethodCallPredId - InstanceMethod0,
InstanceMethod, PredIds0, PredIds) :-
module_info_pred_info(ModuleInfo, MethodCallPredId, MethodCallPredInfo),
pred_info_get_arg_types(MethodCallPredInfo, MethodCallTVarSet, _,
MethodCallArgTypes),
InstanceMethod0 = instance_method(PredOrFunc, MethodName,
InstanceMethodDefn0, MethodArity, MethodContext),
(
InstanceMethodDefn0 = instance_proc_def_name(InstanceMethodName0),
PredOrFunc = pf_function,
(
find_func_matching_instance_method(ModuleInfo, InstanceMethodName0,
MethodArity, MethodCallTVarSet, MethodCallArgTypes,
MaybePredId, InstanceMethodName)
->
(
MaybePredId = yes(PredId),
PredIds = [PredId | PredIds0]
;
MaybePredId = no,
PredIds = PredIds0
),
InstanceMethodDefn = instance_proc_def_name(InstanceMethodName)
;
% This will force add_proc to return DoWrite = no.
PredId = invalid_pred_id,
PredIds = [PredId | PredIds0],
% We can just leave the method definition unchanged.
InstanceMethodDefn = InstanceMethodDefn0
)
;
InstanceMethodDefn0 = instance_proc_def_name(InstanceMethodName0),
PredOrFunc = pf_predicate,
init_markers(Markers),
resolve_pred_overloading(ModuleInfo, Markers,
MethodCallArgTypes, MethodCallTVarSet,
InstanceMethodName0, InstanceMethodName, PredId),
PredIds = [PredId | PredIds0],
InstanceMethodDefn = instance_proc_def_name(InstanceMethodName)
;
InstanceMethodDefn0 = instance_proc_def_clauses(_ItemList),
% XXX For methods defined using this syntax it is a little tricky
% to write out the .opt files, so for now I've just disabled
% intermodule optimization for type class instance declarations
% using the new syntax.
%
% This will force add_proc to return DoWrite = no.
PredId = invalid_pred_id,
PredIds = [PredId | PredIds0],
% We can just leave the method definition unchanged.
InstanceMethodDefn = InstanceMethodDefn0
),
InstanceMethod = instance_method(PredOrFunc, MethodName,
InstanceMethodDefn, MethodArity, MethodContext).
% A `func(x/n) is y' method implementation can match an ordinary function,
% a field access function or a constructor. For now, if there are multiple
% possible matches, we don't write the instance method.
%
:- pred find_func_matching_instance_method(module_info::in, sym_name::in,
arity::in, tvarset::in, list(mer_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_get_ctor_field_table(ModuleInfo, CtorFieldTable),
(
is_field_access_function_name(ModuleInfo, InstanceMethodName0,
MethodArity, _, FieldName),
map.search(CtorFieldTable, FieldName, FieldDefns)
->
TypeCtors0 = list.map(
(func(FieldDefn) = TypeCtor :-
FieldDefn = hlds_ctor_field_defn(_, _, TypeCtor, _, _)
), FieldDefns)
;
TypeCtors0 = []
),
module_info_get_cons_table(ModuleInfo, Ctors),
(
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),
find_matching_pred_id(ModuleInfo, PredIds, MethodCallTVarSet,
MethodCallArgTypes, no, PredId, InstanceMethodFuncName)
->
TypeCtors = [],
MaybePredId = yes(PredId),
InstanceMethodName = InstanceMethodFuncName
;
TypeCtors = [TheTypeCtor],
MaybePredId = no,
( TheTypeCtor = type_ctor(qualified(TypeModule, _), _) ->
UnqualMethodName = unqualify_name(InstanceMethodName0),
InstanceMethodName = qualified(TypeModule, UnqualMethodName)
;
unexpected(this_file, "unqualified type_ctor in " ++
"hlds_cons_defn or hlds_ctor_field_defn")
)
).
%-----------------------------------------------------------------------------%
:- pred gather_types(intermod_info::in, intermod_info::out) is det.
gather_types(!Info) :-
intermod_info_get_module_info(!.Info, ModuleInfo),
module_info_get_type_table(ModuleInfo, Types),
map.foldl(gather_types_2, Types, !Info).
:- pred gather_types_2(type_ctor::in, hlds_type_defn::in,
intermod_info::in, intermod_info::out) is det.
gather_types_2(TypeCtor, TypeDefn0, !Info) :-
intermod_info_get_module_info(!.Info, ModuleInfo),
module_info_get_name(ModuleInfo, ModuleName),
( should_write_type(ModuleName, TypeCtor, TypeDefn0) ->
hlds_data.get_type_defn_body(TypeDefn0, TypeBody0),
(
TypeBody0 = hlds_du_type(Ctors, Tags, Enum, MaybeUserEqComp0,
ReservedTag, ReservedAddr, MaybeForeign0),
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
% Note that we don't resolve overloading for the definitions
% which won't be used on this back-end, because their unification
% and comparison predicates have not been typechecked. They are
% only written to the `.opt' it can be handy when building
% against a workspace for the other definitions to be present
% (e.g. when testing compiling a module to IL when the workspace
% was compiled to C).
% XXX The above sentence doesn't make sense, and never did
% (even in the first CVS version in which it appears).
(
MaybeForeign0 = yes(ForeignTypeBody0),
have_foreign_type_for_backend(Target, ForeignTypeBody0, yes)
->
% The header code must be written since it could be used
% by the foreign type.
intermod_info_set_write_header(!Info),
resolve_foreign_type_body_overloading(ModuleInfo, TypeCtor,
ForeignTypeBody0, ForeignTypeBody, !Info),
MaybeForeign = yes(ForeignTypeBody),
MaybeUserEqComp = MaybeUserEqComp0
;
resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
MaybeUserEqComp0, MaybeUserEqComp, !Info),
MaybeForeign = MaybeForeign0
),
TypeBody = hlds_du_type(Ctors, Tags, Enum, MaybeUserEqComp,
ReservedTag, ReservedAddr, MaybeForeign),
hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn)
;
TypeBody0 = hlds_foreign_type(ForeignTypeBody0),
% The header code must be written since it could be used
% by the foreign type.
intermod_info_set_write_header(!Info),
resolve_foreign_type_body_overloading(ModuleInfo, TypeCtor,
ForeignTypeBody0, ForeignTypeBody, !Info),
TypeBody = hlds_foreign_type(ForeignTypeBody),
hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn)
;
( TypeBody0 = hlds_eqv_type(_)
; TypeBody0 = hlds_solver_type(_, _)
; TypeBody0 = hlds_abstract_type(_)
),
TypeDefn = TypeDefn0
),
intermod_info_get_types(!.Info, Types0),
intermod_info_set_types([TypeCtor - TypeDefn | Types0], !Info)
;
true
).
:- pred resolve_foreign_type_body_overloading(module_info::in,
type_ctor::in, foreign_type_body::in, foreign_type_body::out,
intermod_info::in, intermod_info::out) is det.
resolve_foreign_type_body_overloading(ModuleInfo, TypeCtor,
foreign_type_body(MaybeIL0, MaybeC0, MaybeJava0, MaybeErlang0),
foreign_type_body(MaybeIL, MaybeC, MaybeJava, MaybeErlang),
!Info) :-
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
%
% Note that we don't resolve overloading for the foreign definitions
% which won't be used on this back-end, because their unification and
% comparison predicates have not been typechecked. They are only written
% to the `.opt' it can be handy when building against a workspace
% for the other definitions to be present (e.g. when testing compiling
% a module to IL when the workspace was compiled to C).
%
(
( Target = target_c
; Target = target_asm
; Target = target_x86_64
; Target = target_erlang
),
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
MaybeC0, MaybeC, !Info)
;
( Target = target_il
; Target = target_java
),
MaybeC = MaybeC0
),
(
Target = target_il,
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
MaybeIL0, MaybeIL, !Info)
;
( Target = target_c
; Target = target_asm
; Target = target_java
; Target = target_x86_64
; Target = target_erlang
),
MaybeIL = MaybeIL0
),
(
Target = target_java,
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
MaybeJava0, MaybeJava, !Info)
;
( Target = target_c
; Target = target_asm
; Target = target_il
; Target = target_x86_64
; Target = target_erlang
),
MaybeJava = MaybeJava0
),
(
Target = target_erlang,
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
MaybeErlang0, MaybeErlang, !Info)
;
( Target = target_c
; Target = target_asm
; Target = target_il
; Target = target_x86_64
; Target = target_java
),
MaybeErlang = MaybeErlang0
).
:- pred resolve_foreign_type_body_overloading_2(module_info::in, type_ctor::in,
foreign_type_lang_body(T)::in, foreign_type_lang_body(T)::out,
intermod_info::in, intermod_info::out) is det.
resolve_foreign_type_body_overloading_2(_, _, no, no, !Info).
resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
yes(foreign_type_lang_data(Body, MaybeUserEqComp0, Assertions)),
yes(foreign_type_lang_data(Body, MaybeUserEqComp, Assertions)),
!Info) :-
resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
MaybeUserEqComp0, MaybeUserEqComp, !Info).
:- pred resolve_unify_compare_overloading(module_info::in,
type_ctor::in, maybe(unify_compare)::in, maybe(unify_compare)::out,
intermod_info::in, intermod_info::out) is det.
resolve_unify_compare_overloading(_, _, no, no, !Info).
resolve_unify_compare_overloading(_, _,
yes(abstract_noncanonical_type(IsSolverType)),
yes(abstract_noncanonical_type(IsSolverType)), !Info).
resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
yes(unify_compare(MaybeUserEq0, MaybeUserCompare0)),
yes(unify_compare(MaybeUserEq, MaybeUserCompare)), !Info) :-
resolve_user_special_pred_overloading(ModuleInfo,
spec_pred_unify, TypeCtor, MaybeUserEq0, MaybeUserEq, !Info),
resolve_user_special_pred_overloading(ModuleInfo,
spec_pred_compare, TypeCtor, MaybeUserCompare0, MaybeUserCompare,
!Info).
:- pred resolve_user_special_pred_overloading(module_info::in,
special_pred_id::in, type_ctor::in, maybe(sym_name)::in,
maybe(sym_name)::out, intermod_info::in, intermod_info::out) is det.
resolve_user_special_pred_overloading(_, _, _, no, no, !Info).
resolve_user_special_pred_overloading(ModuleInfo, SpecialId,
TypeCtor, yes(Pred0), yes(Pred), !Info) :-
module_info_get_special_pred_map(ModuleInfo, SpecialPreds),
map.lookup(SpecialPreds, SpecialId - TypeCtor, UnifyPredId),
module_info_pred_info(ModuleInfo, UnifyPredId, UnifyPredInfo),
pred_info_get_arg_types(UnifyPredInfo, TVarSet, _, ArgTypes),
init_markers(Markers0),
add_marker(marker_calls_are_fully_qualified, Markers0, Markers),
resolve_pred_overloading(ModuleInfo, Markers, ArgTypes,
TVarSet, Pred0, Pred, UserEqPredId),
add_proc(UserEqPredId, _, !Info).
:- pred should_write_type(module_name::in, type_ctor::in, hlds_type_defn::in)
is semidet.
should_write_type(ModuleName, TypeCtor, TypeDefn) :-
hlds_data.get_type_defn_status(TypeDefn, ImportStatus),
TypeCtor = type_ctor(Name, _Arity),
Name = qualified(ModuleName, _),
import_status_to_write(ImportStatus).
%-----------------------------------------------------------------------------%
% Output module imports, types, modes, insts and predicates.
%
:- pred write_intermod_info(intermod_info::in, io::di, io::uo) is det.
write_intermod_info(IntermodInfo, !IO) :-
intermod_info_get_module_info(IntermodInfo, ModuleInfo),
module_info_get_name(ModuleInfo, ModuleName),
io.write_string(":- module ", !IO),
mercury_output_bracketed_sym_name(ModuleName, !IO),
io.write_string(".\n", !IO),
intermod_info_get_preds(IntermodInfo, Preds),
intermod_info_get_pred_decls(IntermodInfo, PredDecls),
intermod_info_get_instances(IntermodInfo, Instances),
(
% If none of these item types need writing, nothing else
% needs to be written.
set.empty(Preds),
set.empty(PredDecls),
Instances = [],
module_info_get_type_table(ModuleInfo, Types),
\+ (
map.member(Types, _, TypeDefn),
hlds_data.get_type_defn_status(TypeDefn, Status),
( Status = status_abstract_exported
; Status = status_exported_to_submodules
)
)
->
true
;
write_intermod_info_body(IntermodInfo, !IO)
).
:- pred write_intermod_info_body(intermod_info::in, io::di, io::uo) is det.
write_intermod_info_body(IntermodInfo, !IO) :-
IntermodInfo = intermod_info(_, Preds0, PredDecls0, Instances, Types,
ModuleInfo, WriteHeader, _, _),
set.to_sorted_list(Preds0, Preds),
set.to_sorted_list(PredDecls0, PredDecls),
module_info_get_imported_module_specifiers(ModuleInfo, Modules0),
set.to_sorted_list(Modules0, Modules),
(
Modules = [_ | _],
% XXX Modules could and should be reduced to the set of modules
% that are actually needed by the items being written.
io.write_string(":- use_module ", !IO),
write_modules(Modules, !IO)
;
Modules = []
),
write_types(Types, !IO),
write_insts(ModuleInfo, !IO),
write_modes(ModuleInfo, !IO),
write_classes(ModuleInfo, !IO),
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_info(Lang, Import, _),
mercury_output_pragma_foreign_import_module(Lang, Import,
IO0, IO)
), ForeignImports, !IO)
;
WriteHeader = no
),
write_pred_decls(ModuleInfo, PredDecls, !IO),
write_preds(ModuleInfo, Preds, !IO),
globals.io_set_option(dump_hlds_options, string(VerboseDump), !IO).
:- pred write_modules(list(module_name)::in, io::di, io::uo) is det.
write_modules([], !IO).
write_modules([Module | Rest], !IO) :-
mercury_output_bracketed_sym_name(Module, !IO),
(
Rest = [],
io.write_string(".\n", !IO)
;
Rest = [_ | _],
io.write_string(", ", !IO),
write_modules(Rest, !IO)
).
:- pred write_types(assoc_list(type_ctor, hlds_type_defn)::in, io::di, io::uo)
is det.
write_types(Types, !IO) :-
list.foldl(write_type, Types, !IO).
:- pred write_type(pair(type_ctor, hlds_type_defn)::in, io::di, io::uo) is det.
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 = type_ctor(Name, Arity),
(
Body = hlds_du_type(Ctors, _, _, MaybeUserEqComp, _, _, _),
TypeBody = parse_tree_du_type(Ctors, MaybeUserEqComp)
;
Body = hlds_eqv_type(EqvType),
TypeBody = parse_tree_eqv_type(EqvType)
;
Body = hlds_abstract_type(IsSolverType),
TypeBody = parse_tree_abstract_type(IsSolverType)
;
Body = hlds_foreign_type(_),
TypeBody = parse_tree_abstract_type(non_solver_type)
;
Body = hlds_solver_type(SolverTypeDetails, MaybeUserEqComp),
TypeBody = parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp)
),
mercury_output_item(
item_type_defn(VarSet, Name, Args, TypeBody, cond_true),
Context, !IO),
(
( Body = hlds_foreign_type(ForeignTypeBody)
; Body ^ du_type_is_foreign_type = yes(ForeignTypeBody)
),
ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC, MaybeJava,
MaybeErlang)
->
(
MaybeIL = yes(DataIL),
DataIL = foreign_type_lang_data(ILForeignType, ILMaybeUserEqComp,
AssertionsIL),
mercury_output_item(
item_type_defn(VarSet, Name, Args,
parse_tree_foreign_type(il(ILForeignType),
ILMaybeUserEqComp, AssertionsIL),
cond_true),
Context, !IO)
;
MaybeIL = no
),
(
MaybeC = yes(DataC),
DataC = foreign_type_lang_data(CForeignType,
CMaybeUserEqComp, AssertionsC),
mercury_output_item(
item_type_defn(VarSet, Name, Args,
parse_tree_foreign_type(c(CForeignType),
CMaybeUserEqComp, AssertionsC),
cond_true),
Context, !IO)
;
MaybeC = no
),
(
MaybeJava = yes(DataJava),
DataJava = foreign_type_lang_data(JavaForeignType,
JavaMaybeUserEqComp, AssertionsJava),
mercury_output_item(
item_type_defn(VarSet, Name, Args,
parse_tree_foreign_type(java(JavaForeignType),
JavaMaybeUserEqComp, AssertionsJava),
cond_true),
Context, !IO)
;
MaybeJava = no
),
(
MaybeErlang = yes(DataErlang),
DataErlang = foreign_type_lang_data(ErlangForeignType,
ErlangMaybeUserEqComp, AssertionsErlang),
mercury_output_item(
item_type_defn(VarSet, Name, Args,
parse_tree_foreign_type(erlang(ErlangForeignType),
ErlangMaybeUserEqComp, AssertionsErlang),
cond_true),
Context, !IO)
;
MaybeErlang = no
)
;
true
),
(
ReservedTag = Body ^ du_type_reserved_tag,
ReservedTag = uses_reserved_tag
->
% The pragma_origin doesn't matter here.
mercury_output_item(item_pragma(user, pragma_reserve_tag(Name, Arity)),
Context, !IO)
;
true
),
(
Body = hlds_du_type(_, ConsTagVals, EnumOrDummy, _, _, _, _),
EnumOrDummy = is_foreign_enum(Lang)
->
map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [],
ForeignEnumVals),
Pragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals),
Item = item_pragma(user, Pragma),
mercury_output_item(Item, Context, !IO)
;
true
).
:- pred gather_foreign_enum_value_pair(cons_id::in, cons_tag::in,
assoc_list(sym_name, string)::in, assoc_list(sym_name, string)::out)
is det.
gather_foreign_enum_value_pair(ConsId, ConsTag, !Values) :-
( ConsId = cons(SymName0, 0) ->
SymName = SymName0
;
unexpected(this_file, "expected enumeration constant")
),
( ConsTag = foreign_tag(_ForeignLang, ForeignTag0) ->
ForeignTag = ForeignTag0
;
unexpected(this_file, "expected foreign tag")
),
!:Values = [SymName - ForeignTag | !.Values].
:- pred write_modes(module_info::in, io::di, io::uo) is det.
write_modes(ModuleInfo, !IO) :-
module_info_get_name(ModuleInfo, ModuleName),
module_info_get_mode_table(ModuleInfo, Modes),
mode_table_get_mode_defns(Modes, ModeDefns),
map.foldl(write_mode(ModuleName), ModeDefns, !IO).
:- pred write_mode(module_name::in, mode_id::in, hlds_mode_defn::in,
io::di, io::uo) is det.
write_mode(ModuleName, ModeId, ModeDefn, !IO) :-
ModeId = mode_id(SymName, _Arity),
ModeDefn = hlds_mode_defn(Varset, Args, eqv_mode(Mode), Context,
ImportStatus),
(
SymName = qualified(ModuleName, _),
import_status_to_write(ImportStatus)
->
mercury_output_item(
item_mode_defn(Varset, SymName, Args, eqv_mode(Mode), cond_true),
Context, !IO)
;
true
).
:- pred write_insts(module_info::in, io::di, io::uo) is det.
write_insts(ModuleInfo, !IO) :-
module_info_get_name(ModuleInfo, ModuleName),
module_info_get_inst_table(ModuleInfo, Insts),
inst_table_get_user_insts(Insts, UserInsts),
user_inst_table_get_inst_defns(UserInsts, InstDefns),
map.foldl(write_inst(ModuleName), InstDefns, !IO).
:- pred write_inst(module_name::in, inst_id::in, hlds_inst_defn::in,
io::di, io::uo) is det.
write_inst(ModuleName, InstId, InstDefn, !IO) :-
InstId = inst_id(SymName, _Arity),
InstDefn = hlds_inst_defn(Varset, Args, Body, Context, ImportStatus),
(
SymName = qualified(ModuleName, _),
import_status_to_write(ImportStatus)
->
(
Body = eqv_inst(Inst2),
InstBody = eqv_inst(Inst2)
;
Body = abstract_inst,
InstBody = abstract_inst
),
mercury_output_item(item_inst_defn(Varset, SymName, Args, InstBody,
cond_true), Context, !IO)
;
true
).
:- pred write_classes(module_info::in, io::di, io::uo) is det.
write_classes(ModuleInfo, !IO) :-
module_info_get_name(ModuleInfo, ModuleName),
module_info_get_class_table(ModuleInfo, Classes),
map.foldl(write_class(ModuleName), Classes, !IO).
:- pred write_class(module_name::in, class_id::in,
hlds_class_defn::in, io::di, io::uo) is det.
write_class(ModuleName, ClassId, ClassDefn, !IO) :-
ClassDefn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
_Ancestors, TVars, _Kinds, Interface, _HLDSClassInterface, TVarSet,
Context),
ClassId = class_id(QualifiedClassName, _),
(
QualifiedClassName = qualified(ModuleName, _),
import_status_to_write(ImportStatus)
->
FunDeps = list.map(unmake_hlds_class_fundep(TVars), HLDSFunDeps),
Item = 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.solutions(P) :-
P = (pred(TVar::out) is nondet :-
set.member(N, Set),
TVar = list.index1_det(TVars, N)
).
:- pred write_instances(assoc_list(class_id, hlds_instance_defn)::in,
io::di, io::uo) is det.
write_instances(Instances, !IO) :-
list.foldl(write_instance, Instances, !IO).
:- pred write_instance(pair(class_id, hlds_instance_defn)::in,
io::di, io::uo) is det.
write_instance(ClassId - InstanceDefn, !IO) :-
InstanceDefn = hlds_instance_defn(ModuleName, _, Context, Constraints,
Types, Body, _, TVarSet, _),
ClassId = class_id(ClassName, _),
Item = 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 write_pred_decls(module_info::in, list(pred_id)::in,
io::di, io::uo) is det.
write_pred_decls(_, [], !IO).
write_pred_decls(ModuleInfo, [PredId | PredIds], !IO) :-
module_info_pred_info(ModuleInfo, PredId, PredInfo),
Module = pred_info_module(PredInfo),
Name = pred_info_name(PredInfo),
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
pred_info_get_arg_types(PredInfo, TVarSet, ExistQVars, ArgTypes),
pred_info_get_context(PredInfo, Context),
pred_info_get_purity(PredInfo, Purity),
pred_info_get_class_context(PredInfo, ClassContext),
pred_info_get_goal_type(PredInfo, GoalType),
(
GoalType = goal_type_foreign,
% For foreign code goals we can't append variable numbers to type
% variables in the predicate declaration because the foreign code
% may contain references to variables such as `TypeInfo_for_T'
% which will break if `T' is written as `T_1' in the pred declaration.
AppendVarNums = no
;
GoalType = goal_type_clause_and_foreign,
% Because pragmas may be present, we treat this case like
% pragmas above.
AppendVarNums = no
;
GoalType = goal_type_clause,
AppendVarNums = yes
;
GoalType = goal_type_promise(_),
AppendVarNums = yes
;
GoalType = goal_type_none,
AppendVarNums = yes
),
(
PredOrFunc = pf_predicate,
mercury_output_pred_type(TVarSet, ExistQVars, qualified(Module, Name),
ArgTypes, no, Purity, ClassContext, Context, AppendVarNums, !IO)
;
PredOrFunc = pf_function,
pred_args_to_func_args(ArgTypes, FuncArgTypes, FuncRetType),
mercury_output_func_type(TVarSet, ExistQVars, qualified(Module, Name),
FuncArgTypes, FuncRetType, no, Purity, ClassContext, Context,
AppendVarNums, !IO)
),
pred_info_get_procedures(PredInfo, Procs),
ProcIds = pred_info_procids(PredInfo),
% Make sure the mode declarations go out in the same order
% they came in, so that the all the modes get the same proc_id
% in the importing modules.
CompareProcId =
(pred(ProcId1::in, ProcId2::in, Result::out) is det :-
proc_id_to_int(ProcId1, ProcInt1),
proc_id_to_int(ProcId2, ProcInt2),
compare(Result, ProcInt1, ProcInt2)
),
list.sort(CompareProcId, ProcIds, SortedProcIds),
write_pred_modes(Procs, qualified(Module, Name), PredOrFunc, SortedProcIds,
!IO),
write_pragmas(PredInfo, !IO),
write_type_spec_pragmas(ModuleInfo, PredId, !IO),
write_pred_decls(ModuleInfo, PredIds, !IO).
:- pred write_pred_modes(map(proc_id, proc_info)::in, sym_name::in,
pred_or_func::in, list(proc_id)::in, io::di, io::uo) is det.
write_pred_modes(_, _, _, [], !IO).
write_pred_modes(Procs, SymName, PredOrFunc, [ProcId | ProcIds], !IO) :-
map.lookup(Procs, ProcId, ProcInfo),
proc_info_get_maybe_declared_argmodes(ProcInfo, MaybeArgModes),
proc_info_get_declared_determinism(ProcInfo, MaybeDetism),
(
MaybeArgModes = yes(ArgModes0),
MaybeDetism = yes(Detism0)
->
ArgModes = ArgModes0,
Detism = Detism0
;
unexpected(this_file,
"write_pred_modes: attempt to write undeclared mode")
),
proc_info_get_context(ProcInfo, Context),
varset.init(Varset),
(
PredOrFunc = pf_function,
pred_args_to_func_args(ArgModes, FuncArgModes, FuncRetMode),
mercury_output_func_mode_decl(Varset, SymName,
FuncArgModes, FuncRetMode, yes(Detism), Context, !IO)
;
PredOrFunc = pf_predicate,
mercury_output_pred_mode_decl(Varset, SymName, ArgModes,
yes(Detism), Context, !IO)
),
write_pred_modes(Procs, SymName, PredOrFunc, ProcIds, !IO).
:- pred write_preds(module_info::in, list(pred_id)::in,
io::di, io::uo) is det.
write_preds(_, [], !IO).
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),
write_pragmas(PredInfo, !IO),
% The type specialization pragmas for exported preds should
% already be in the interface file.
pred_info_get_clauses_info(PredInfo, ClausesInfo),
clauses_info_get_varset(ClausesInfo, VarSet),
clauses_info_get_headvar_list(ClausesInfo, HeadVars),
clauses_info_clauses_only(ClausesInfo, Clauses),
clauses_info_get_vartypes(ClausesInfo, VarTypes),
( pred_info_get_goal_type(PredInfo, goal_type_promise(PromiseType)) ->
( Clauses = [Clause] ->
hlds_out.write_promise(PromiseType, 0, ModuleInfo, PredId, VarSet,
no, HeadVars, PredOrFunc, Clause, no_varset_vartypes, !IO)
;
unexpected(this_file,
"write_preds: assertion not a single clause.")
)
;
pred_info_get_typevarset(PredInfo, TypeVarset),
MaybeVarTypes = varset_vartypes(TypeVarset, VarTypes),
list.foldl(write_clause(ModuleInfo, PredId, VarSet,
HeadVars, PredOrFunc, SymName, MaybeVarTypes), Clauses, !IO)
),
write_preds(ModuleInfo, PredIds, !IO).
:- pred write_clause(module_info::in, pred_id::in, prog_varset::in,
list(prog_var)::in, pred_or_func::in, sym_name::in,
maybe_vartypes::in, clause::in, io::di, io::uo) is det.
write_clause(ModuleInfo, PredId, VarSet, HeadVars, PredOrFunc, _SymName,
MaybeVarTypes, Clause0, !IO) :-
Clause0 = clause(_, _, impl_lang_mercury, _),
strip_headvar_unifications(HeadVars, Clause0, ClauseHeadVars, Clause),
% Variable numbers need to be appended for the case
% where the added arguments for a DCG pred expression
% are named the same as variables in the enclosing clause.
AppendVarNums = yes,
UseDeclaredModes = yes,
hlds_out.write_clause(1, ModuleInfo, PredId, VarSet, AppendVarNums,
ClauseHeadVars, PredOrFunc, Clause, UseDeclaredModes, MaybeVarTypes,
!IO).
write_clause(ModuleInfo, PredId, VarSet, _HeadVars, PredOrFunc, SymName,
_, Clause, !IO) :-
Clause = clause(ProcIds, Goal, impl_lang_foreign(_), _),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_get_procedures(PredInfo, Procs),
(
(
% Pull the foreign code out of the goal.
Goal = hlds_goal(conj(plain_conj, Goals), _),
list.filter((pred(X::in) is semidet :-
X = hlds_goal(call_foreign_proc(_, _, _, _, _, _, _), _)
), Goals, [ForeignCodeGoal]),
ForeignCodeGoal = hlds_goal(call_foreign_proc(Attributes,
_, _, Args, _ExtraArgs, _MaybeTraceRuntimeCond, PragmaCode), _)
;
Goal = hlds_goal(call_foreign_proc(Attributes, _, _,
Args, _ExtraArgs, _MaybeTraceRuntimeCond, PragmaCode), _)
)
->
list.foldl(write_foreign_clause(Procs, PredOrFunc,
PragmaCode, Attributes, Args, VarSet, SymName), ProcIds, !IO)
;
unexpected(this_file, "foreign_proc expected within this goal")
).
:- pred write_foreign_clause(proc_table::in, pred_or_func::in,
pragma_foreign_code_impl::in, pragma_foreign_proc_attributes::in,
list(foreign_arg)::in, prog_varset::in, sym_name::in, proc_id::in,
io::di, io::uo) is det.
write_foreign_clause(Procs, PredOrFunc, PragmaImpl,
Attributes, Args, ProgVarset0, SymName, ProcId, !IO) :-
map.lookup(Procs, ProcId, ProcInfo),
proc_info_get_maybe_declared_argmodes(ProcInfo, MaybeArgModes),
(
MaybeArgModes = yes(ArgModes),
get_pragma_foreign_code_vars(Args, ArgModes,
ProgVarset0, ProgVarset, PragmaVars),
proc_info_get_inst_varset(ProcInfo, InstVarset),
mercury_output_pragma_foreign_code(Attributes, SymName,
PredOrFunc, PragmaVars, ProgVarset, InstVarset, PragmaImpl, !IO)
;
MaybeArgModes = no,
unexpected(this_file, "write_clause: no mode declaration")
).
% Strip the `Headvar.n = Term' unifications from each clause,
% except if the `Term' is a lambda expression.
%
% At least two problems occur if this is not done:
% - in some cases where nested unique modes were accepted by
% mode analysis, the extra aliasing added by the extra level
% of headvar unifications caused mode analysis to report
% an error (ground expected unique), when analysing the
% clauses read in from `.opt' files.
% - only HeadVar unifications may be reordered with impure goals,
% so a mode error results for the second level of headvar
% unifications added when the clauses are read in again from
% the `.opt' file. Clauses containing impure goals are not
% written to the `.opt' file for this reason.
%
:- pred strip_headvar_unifications(list(prog_var)::in,
clause::in, list(prog_term)::out, clause::out) is det.
strip_headvar_unifications(HeadVars, clause(ProcIds, Goal0, Lang, Context),
HeadTerms, clause(ProcIds, Goal, Lang, Context)) :-
Goal0 = hlds_goal(_, GoalInfo0),
goal_to_conj_list(Goal0, Goals0),
map.init(HeadVarMap0),
(
strip_headvar_unifications_from_goal_list(Goals0, HeadVars,
[], Goals, HeadVarMap0, HeadVarMap)
->
list.map(
(pred(HeadVar0::in, HeadTerm::out) is det :-
( map.search(HeadVarMap, HeadVar0, HeadTerm0) ->
HeadTerm = HeadTerm0
;
HeadTerm = term.variable(HeadVar0, Context)
)
), HeadVars, HeadTerms),
conj_list_to_goal(Goals, GoalInfo0, Goal)
;
term.var_list_to_term_list(HeadVars, HeadTerms),
Goal = Goal0
).
:- pred strip_headvar_unifications_from_goal_list(list(hlds_goal)::in,
list(prog_var)::in, list(hlds_goal)::in, list(hlds_goal)::out,
map(prog_var, prog_term)::in,
map(prog_var, prog_term)::out) is semidet.
strip_headvar_unifications_from_goal_list([], _, RevGoals, Goals,
!HeadVarMap) :-
list.reverse(RevGoals, Goals).
strip_headvar_unifications_from_goal_list([Goal | Goals0], HeadVars,
RevGoals0, Goals, !HeadVarMap) :-
(
Goal = hlds_goal(unify(LHSVar, RHS, _, _, _), _),
list.member(LHSVar, HeadVars),
term.context_init(Context),
(
RHS = rhs_var(RHSVar),
RHSTerm = term.variable(RHSVar, Context)
;
RHS = rhs_functor(ConsId, _, Args),
(
ConsId = int_const(Int),
RHSTerm = term.functor(term.integer(Int), [], Context)
;
ConsId = float_const(Float),
RHSTerm = term.functor(term.float(Float), [], Context)
;
ConsId = string_const(String),
RHSTerm = term.functor(term.string(String), [], Context)
;
ConsId = cons(SymName, _),
term.var_list_to_term_list(Args, ArgTerms),
construct_qualified_term(SymName, ArgTerms, RHSTerm)
)
)
->
% Don't strip the headvar unifications if one of the
% headvars appears twice. This should probably never happen.
map.insert(!.HeadVarMap, LHSVar, RHSTerm, !:HeadVarMap),
RevGoals1 = RevGoals0
;
RevGoals1 = [Goal | RevGoals0]
),
strip_headvar_unifications_from_goal_list(Goals0, HeadVars,
RevGoals1, Goals, !HeadVarMap).
:- pred write_pragmas(pred_info::in, io::di, io::uo) is det.
write_pragmas(PredInfo, !IO) :-
Module = pred_info_module(PredInfo),
Name = pred_info_name(PredInfo),
Arity = pred_info_orig_arity(PredInfo),
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
SymName = qualified(Module, Name),
pred_info_get_markers(PredInfo, Markers),
markers_to_marker_list(Markers, MarkerList),
write_pragmas(SymName, Arity, MarkerList, PredOrFunc, !IO).
:- pred write_pragmas(sym_name::in, int::in, list(marker)::in,
pred_or_func::in, io::di, io::uo) is det.
write_pragmas(_, _, [], _, !IO).
write_pragmas(SymName, Arity, [Marker | Markers], PredOrFunc, !IO) :-
should_output_marker(Marker, ShouldOutput),
(
ShouldOutput = yes,
hlds_out.marker_name(Marker, Name),
mercury_output_pragma_decl(SymName, Arity, PredOrFunc, Name, no, !IO)
;
ShouldOutput = no
),
write_pragmas(SymName, Arity, Markers, PredOrFunc, !IO).
:- pred write_type_spec_pragmas(module_info::in, pred_id::in,
io::di, io::uo) is det.
write_type_spec_pragmas(ModuleInfo, PredId, !IO) :-
module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo),
PragmaMap = TypeSpecInfo ^ pragma_map,
( multi_map.search(PragmaMap, PredId, TypeSpecPragmas) ->
list.foldl(write_type_spec_pragma, TypeSpecPragmas, !IO)
;
true
).
:- pred write_type_spec_pragma(pragma_type::in, io::di, io::uo) is det.
write_type_spec_pragma(Pragma, !IO) :-
( Pragma = pragma_type_spec(_, _, _, _, _, _, _, _) ->
AppendVarnums = yes,
mercury_output_pragma_type_spec(Pragma, AppendVarnums, !IO)
;
unexpected(this_file, "write_type_spec_pragma")
).
% Is a pragma declaration required in the `.opt' file for
% a predicate with the given marker.
%
:- pred should_output_marker(marker::in, bool::out) is det.
should_output_marker(marker_stub, no).
% Since the inferred declarations are output, these
% don't need to be done in the importing module.
should_output_marker(marker_infer_type, no).
should_output_marker(marker_infer_modes, no).
% Purity is output as part of the pred/func decl.
should_output_marker(marker_is_impure, no).
should_output_marker(marker_is_semipure, no).
% There is no pragma required for generated class methods.
should_output_marker(marker_class_method, no).
should_output_marker(marker_class_instance_method, no).
should_output_marker(marker_named_class_instance_method, no).
% The warning for calls to local obsolete predicates should appear
% once in the defining module, not in importing modules.
should_output_marker(marker_obsolete, no).
should_output_marker(marker_user_marked_inline, yes).
should_output_marker(marker_user_marked_no_inline, yes).
should_output_marker(marker_heuristic_inline, no).
should_output_marker(marker_promised_pure, yes).
should_output_marker(marker_promised_semipure, yes).
should_output_marker(marker_promised_equivalent_clauses, yes).
should_output_marker(marker_terminates, yes).
should_output_marker(marker_does_not_terminate, yes).
% Termination should only be checked in the defining module.
should_output_marker(marker_check_termination, no).
should_output_marker(marker_calls_are_fully_qualified, no).
should_output_marker(marker_mode_check_clauses, yes).
should_output_marker(marker_mutable_access_pred, no).
:- pred get_pragma_foreign_code_vars(list(foreign_arg)::in, list(mer_mode)::in,
prog_varset::in, prog_varset::out, list(pragma_var)::out) is det.
get_pragma_foreign_code_vars(Args, Modes, !VarSet, PragmaVars) :-
(
Args = [Arg | ArgsTail],
Modes = [Mode | ModesTail],
Arg = foreign_arg(Var, MaybeNameAndMode, _, _),
(
MaybeNameAndMode = no,
Name = "_"
;
MaybeNameAndMode = yes(Name - _Mode2)
),
PragmaVar = pragma_var(Var, Name, Mode, native_if_possible),
varset.name_var(!.VarSet, Var, Name, !:VarSet),
get_pragma_foreign_code_vars(ArgsTail, ModesTail, !VarSet,
PragmaVarsTail),
PragmaVars = [PragmaVar | PragmaVarsTail]
;
Args = [],
Modes = [],
PragmaVars = []
;
Args = [],
Modes = [_ | _],
unexpected(this_file, "get_pragma_foreign_code_vars")
;
Args = [_ | _],
Modes = [],
unexpected(this_file, "get_pragma_foreign_code_vars")
).
%-----------------------------------------------------------------------------%
% A collection of stuff to go in the .opt file.
%
:- type intermod_info
---> intermod_info(
% Modules to import.
im_modules :: set(module_name),
% Preds to output clauses for.
im_preds :: set(pred_id),
% Preds to output decls for.
im_pred_decls :: set(pred_id),
% Instances declarations to write.
im_instances :: assoc_list(class_id,
hlds_instance_defn),
% Type declarations to write.
im_types :: assoc_list(type_ctor,
hlds_type_defn),
im_module_info :: module_info,
% Do the pragma foreign_decls for the module need writing,
% yes if there are pragma foreign_procs being exported.
im_write_foreign_header :: bool,
% Vartypes and tvarset for the current pred.
im_var_types :: vartypes,
im_tvarset :: tvarset
).
:- pred init_intermod_info(module_info::in, intermod_info::out) is det.
init_intermod_info(ModuleInfo, IntermodInfo) :-
set.init(Modules),
set.init(Procs),
set.init(ProcDecls),
map.init(VarTypes),
varset.init(TVarSet),
Instances = [],
Types = [],
IntermodInfo = intermod_info(Modules, Procs, ProcDecls, Instances, Types,
ModuleInfo, no, VarTypes, TVarSet).
:- pred intermod_info_get_modules(intermod_info::in, set(module_name)::out)
is det.
:- pred intermod_info_get_preds(intermod_info::in, set(pred_id)::out) is det.
:- pred intermod_info_get_pred_decls(intermod_info::in, set(pred_id)::out)
is det.
:- pred intermod_info_get_instances(intermod_info::in,
assoc_list(class_id, hlds_instance_defn)::out) is det.
:- pred intermod_info_get_types(intermod_info::in,
assoc_list(type_ctor, hlds_type_defn)::out) is det.
:- pred intermod_info_get_module_info(intermod_info::in, module_info::out)
is det.
:- pred intermod_info_get_write_foreign_header(intermod_info::in, bool::out)
is det.
:- pred intermod_info_get_var_types(intermod_info::in, vartypes::out) is det.
:- pred intermod_info_get_tvarset(intermod_info::in, tvarset::out) is det.
:- pred intermod_info_set_modules(set(module_name)::in,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_preds(set(pred_id)::in,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_pred_decls(set(pred_id)::in,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_instances(
assoc_list(class_id, hlds_instance_defn)::in,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_types(assoc_list(type_ctor, hlds_type_defn)::in,
intermod_info::in, intermod_info::out) is det.
%:- pred intermod_info_set_insts(set(inst_id)::in,
% intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_module_info(module_info::in,
intermod_info::in, intermod_info::out) is det.
:- pred intermod_info_set_write_header(intermod_info::in,
intermod_info::out) is det.
:- pred intermod_info_set_var_types(vartypes::in, intermod_info::in,
intermod_info::out) is det.
:- pred intermod_info_set_tvarset(tvarset::in,
intermod_info::in, intermod_info::out) is det.
intermod_info_get_modules(Info, Info ^ im_modules).
intermod_info_get_preds(Info, Info ^ im_preds).
intermod_info_get_pred_decls(Info, Info ^ im_pred_decls).
intermod_info_get_instances(Info, Info ^ im_instances).
intermod_info_get_types(Info, Info ^ im_types).
intermod_info_get_module_info(Info, Info ^ im_module_info).
intermod_info_get_write_foreign_header(Info, Info ^ im_write_foreign_header).
intermod_info_get_var_types(Info, Info ^ im_var_types).
intermod_info_get_tvarset(Info, Info ^ im_tvarset).
intermod_info_set_modules(Modules, Info, Info ^ im_modules := Modules).
intermod_info_set_preds(Procs, Info, Info ^ im_preds := Procs).
intermod_info_set_pred_decls(ProcDecls, Info,
Info ^ im_pred_decls := ProcDecls).
intermod_info_set_instances(Instances, Info, Info ^ im_instances := Instances).
intermod_info_set_types(Types, Info, Info ^ im_types := Types).
intermod_info_set_module_info(ModuleInfo, Info,
Info ^ im_module_info := ModuleInfo).
intermod_info_set_write_header(Info, Info ^ im_write_foreign_header := yes).
intermod_info_set_var_types(VarTypes, Info, Info ^ im_var_types := VarTypes).
intermod_info_set_tvarset(TVarSet, Info, Info ^ im_tvarset := TVarSet).
%-----------------------------------------------------------------------------%
% Make sure the labels of local preds needed by predicates in
% the .opt file are exported, and inhibit dead proc elimination
% on those preds.
%
adjust_pred_import_status(!ModuleInfo, !IO) :-
globals.io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
maybe_write_string(VeryVerbose,
"% Adjusting import status of predicates in the `.opt' file...", !IO),
module_info_predids(PredIds, !ModuleInfo),
module_info_get_globals(!.ModuleInfo, 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),
some [!Info] (
init_intermod_info(!.ModuleInfo, !:Info),
gather_preds(PredIds, yes, Threshold, HigherOrderSizeLimit,
Deforestation, !Info),
gather_instances(!Info),
gather_types(!Info),
do_adjust_pred_import_status(!.Info, !ModuleInfo)
),
maybe_write_string(VeryVerbose, " done\n", !IO).
:- pred do_adjust_pred_import_status(intermod_info::in,
module_info::in, module_info::out) is det.
do_adjust_pred_import_status(Info, !ModuleInfo) :-
intermod_info_get_pred_decls(Info, PredDecls0),
set.to_sorted_list(PredDecls0, PredDecls),
set_list_of_preds_exported(PredDecls, !ModuleInfo),
adjust_type_status(!ModuleInfo),
adjust_class_status(!ModuleInfo),
adjust_instance_status(!ModuleInfo).
:- pred adjust_type_status(module_info::in, module_info::out) is det.
adjust_type_status(!ModuleInfo) :-
module_info_get_type_table(!.ModuleInfo, 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_type_table(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_get_name(!.ModuleInfo, ModuleName),
( should_write_type(ModuleName, TypeCtor, TypeDefn0) ->
hlds_data.set_type_defn_status(status_exported, TypeDefn0, TypeDefn),
fixup_special_preds(TypeCtor, !ModuleInfo)
;
TypeDefn = TypeDefn0
).
:- pred fixup_special_preds((type_ctor)::in,
module_info::in, module_info::out) is det.
fixup_special_preds(TypeCtor, ModuleInfo0, ModuleInfo) :-
special_pred_list(SpecialPredList),
module_info_get_special_pred_map(ModuleInfo0, SpecPredMap),
list.filter_map((pred(SpecPredId::in, PredId::out) is semidet :-
map.search(SpecPredMap, SpecPredId - TypeCtor, PredId)
), SpecialPredList, PredIds),
set_list_of_preds_exported(PredIds, ModuleInfo0, ModuleInfo).
:- pred adjust_class_status(module_info::in, module_info::out) is det.
adjust_class_status(!ModuleInfo) :-
module_info_get_class_table(!.ModuleInfo, Classes0),
map.to_assoc_list(Classes0, ClassAL0),
list.map_foldl(adjust_class_status_2, ClassAL0, ClassAL, !ModuleInfo),
map.from_assoc_list(ClassAL, Classes),
module_info_set_class_table(Classes, !ModuleInfo).
:- pred adjust_class_status_2(pair(class_id, hlds_class_defn)::in,
pair(class_id, hlds_class_defn)::out,
module_info::in, module_info::out) is det.
adjust_class_status_2(ClassId - ClassDefn0, ClassId - ClassDefn,
!ModuleInfo) :-
( import_status_to_write(ClassDefn0 ^ class_status) ->
ClassDefn = ClassDefn0 ^ class_status := status_exported,
class_procs_to_pred_ids(ClassDefn ^ class_hlds_interface, PredIds),
set_list_of_preds_exported(PredIds, !ModuleInfo)
;
ClassDefn = ClassDefn0
).
:- pred class_procs_to_pred_ids(list(hlds_class_proc)::in, list(pred_id)::out)
is det.
class_procs_to_pred_ids(ClassProcs, PredIds) :-
list.map(
(pred(ClassProc::in, PredId::out) is det :-
ClassProc = hlds_class_proc(PredId, _)
),
ClassProcs, PredIds0),
list.sort_and_remove_dups(PredIds0, PredIds).
:- pred adjust_instance_status(module_info::in, module_info::out) is det.
adjust_instance_status(!ModuleInfo) :-
module_info_get_instance_table(!.ModuleInfo, Instances0),
map.to_assoc_list(Instances0, InstanceAL0),
list.map_foldl(adjust_instance_status_2, InstanceAL0, InstanceAL,
!ModuleInfo),
map.from_assoc_list(InstanceAL, Instances),
module_info_set_instance_table(Instances, !ModuleInfo).
:- pred adjust_instance_status_2(pair(class_id, list(hlds_instance_defn))::in,
pair(class_id, list(hlds_instance_defn))::out,
module_info::in, module_info::out) is det.
adjust_instance_status_2(ClassId - InstanceList0, ClassId - InstanceList,
!ModuleInfo) :-
list.map_foldl(adjust_instance_status_3, InstanceList0, InstanceList,
!ModuleInfo).
:- pred adjust_instance_status_3(hlds_instance_defn::in,
hlds_instance_defn::out, module_info::in, module_info::out) is det.
adjust_instance_status_3(Instance0, Instance, !ModuleInfo) :-
Instance0 = hlds_instance_defn(InstanceModule, Status0, Context,
Constraints, Types, Body, HLDSClassInterface,
TVarSet, ConstraintProofs),
( import_status_to_write(Status0) ->
Instance = hlds_instance_defn(InstanceModule, status_exported,
Context, Constraints, Types, Body, HLDSClassInterface,
TVarSet, ConstraintProofs),
(
HLDSClassInterface = yes(ClassInterface),
class_procs_to_pred_ids(ClassInterface, PredIds),
set_list_of_preds_exported(PredIds, !ModuleInfo)
;
% This can happen if an instance has multiple
% declarations, one of which is abstract.
HLDSClassInterface = no
)
;
Instance = Instance0
).
:- pred set_list_of_preds_exported(list(pred_id)::in, module_info::in,
module_info::out) is det.
set_list_of_preds_exported(PredIds, !ModuleInfo) :-
module_info_preds(!.ModuleInfo, Preds0),
set_list_of_preds_exported_2(PredIds, Preds0, Preds),
module_info_set_preds(Preds, !ModuleInfo).
:- pred set_list_of_preds_exported_2(list(pred_id)::in,
pred_table::in, pred_table::out) is det.
set_list_of_preds_exported_2([], !Preds).
set_list_of_preds_exported_2([PredId | PredIds], !Preds) :-
map.lookup(!.Preds, PredId, PredInfo0),
(
pred_info_get_import_status(PredInfo0, Status),
import_status_to_write(Status)
->
(
pred_info_get_origin(PredInfo0, Origin),
Origin = origin_special_pred(spec_pred_unify - _)
->
NewStatus = status_pseudo_exported
;
Status = status_external(_)
->
NewStatus = status_external(status_opt_exported)
;
NewStatus = status_opt_exported
),
pred_info_set_import_status(NewStatus, PredInfo0, PredInfo),
map.det_update(!.Preds, PredId, PredInfo, !:Preds)
;
true
),
set_list_of_preds_exported_2(PredIds, !Preds).
% Should a declaration with the given status be written to the `.opt' file.
%
:- pred import_status_to_write(import_status::in) is semidet.
import_status_to_write(Status) :-
import_status_to_write(Status) = yes.
:- func import_status_to_write(import_status) = bool.
import_status_to_write(status_imported(_)) = no.
import_status_to_write(status_abstract_imported) = no.
import_status_to_write(status_pseudo_imported) = no.
import_status_to_write(status_opt_imported) = no.
import_status_to_write(status_exported) = no.
import_status_to_write(status_opt_exported) = yes.
import_status_to_write(status_abstract_exported) = yes.
import_status_to_write(status_pseudo_exported) = no.
import_status_to_write(status_exported_to_submodules) = yes.
import_status_to_write(status_local) = yes.
import_status_to_write(status_external(Status)) =
bool.not(status_is_exported(Status)).
%-----------------------------------------------------------------------------%
% Read in and process the optimization interfaces.
%
grab_opt_files(!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(md_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(ItemAndContext::in) is semidet :-
ItemAndContext = item_and_context(item_pragma(_, PragmaType), _),
PragmaType = pragma_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(md_opt_imported),
make_pseudo_decl(md_opt_imported),
[], AncestorImports1,
[], AncestorImports2, !Module, !IO),
%
% Figure out which .int files are needed by the .opt files
%
get_dependencies(OptItems, NewImportDeps0, NewUseDeps0),
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(md_opt_imported), make_pseudo_decl(md_opt_imported),
[], NewIndirectDeps, [], NewImplIndirectDeps, !Module, !IO),
process_module_short_interfaces_and_impls_transitively(ReadModules,
NewIndirectDeps ++ NewImplIndirectDeps, ".int2",
make_pseudo_decl(md_opt_imported), make_pseudo_decl(md_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),
ModuleToReadString = sym_name_to_string(ModuleToRead),
maybe_write_string(VeryVerbose, ModuleToReadString, !IO),
maybe_write_string(VeryVerbose, "'...\n", !IO),
maybe_flush_output(VeryVerbose, !IO),
module_name_to_search_file_name(ModuleToRead, ".opt", FileName, !IO),
prog_io.read_opt_file(FileName, ModuleToRead,
ModuleError, Messages, OptItems, !IO),
update_error_status(opt_file, 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)
;
Transitive = no,
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_file,
WarningOption = warn_missing_opt_files
;
FileType = trans_opt_file,
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
)
).
%-----------------------------------------------------------------------------%
:- func this_file = string.
this_file = "intermod.m".
%-----------------------------------------------------------------------------%
:- end_module intermod.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink