[m-rev.] diff/for post-commit review: trail usage analysis and optimization
Julien Fischer
juliensf at cs.mu.OZ.AU
Tue Nov 8 16:38:49 AEDT 2005
For post-commit review:
I'm going to commit this now because it will be easier to work on it
when the installed compilers understand how to parse trailing_info
pragmas and the new foreign code attributes. It shouldn't affect
anything else as all the new stuff is disabled by default.
Estimated hours taken: 30
Branches: main
Implement trail usage analysis. This analysis performs a bottom-up traversal
of a program's call-graph to work out what parts of the program cannot modify
the trail.
Implement trail usage optimization for the high-level C backend. Use the
information from the trail usage analysis to reduce the overhead of trailing
by omitting trailing primitives where they are not needed. This diff
adds an initial version of this optimization (future versions will exploit
further opportunities that we currently ignore).
TODO: implement this optimization for the lowlevel backend.
This change adds two new foreign code attributes: `will_not_modify_trail'
and `may_modify_trail' that can be used to inform the compiler whether
foreign_procs modify the trail or not.
compiler/trailing_analysis.m:
New module. Perform a bottom-up analysis of the HLDS and annotate it
with trail usage information.
compiler/hlds_module.m:
Add a slot to the HLDS to store trail usage information for each
(opt-imported) procedure in a module.
compiler/prog_data.m:
compiler/prog_io_pragma.m:
compiler/add_pragma.m:
Add a new pragma: trailing_info. This pragma can only occur in .opt
and .trans_opt files and is used to propagate trail usage information
across module boundaries.
Add two new foreign_proc attributes, `will_not_modify_trail' and
`may_modify_trail', that allow foreign_procs to be annotated with
trail usage information.
compiler/goal_form.m:
Add a predicate that tests if a given goal modifies the trail.
compiler/add_trail_ops.m:
When performing the source-to-source transformation used to implement
trailing for the MLDS backend take account of trail usage information,
so that we can omit calls to trailing primitives in some places.
compiler/options.m:
Add two new options: `--analyse-trail-usage' and
`--optimize-trail-usage', that enable the new analysis and
optimization respectively. For the moment they are both disabled by
default.
Unrelated change: fix the formatting of the termination2 options.
compiler/trans_opt.m:
Write trailing_info pragmas to .trans_opt files.
compiler/mercury_compile.m:
Run the new analysis if `--analyse-trail-usage' is given.
compiler/mercury_to_mercury.m:
Output trailing_info pragmas.
compiler/transform_hlds.m:
compiler/recompilation.version.m:
Minor changes to conform to the above.
Julien.
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.17
diff -u -r1.17 add_pragma.m
--- compiler/add_pragma.m 8 Nov 2005 03:58:52 -0000 1.17
+++ compiler/add_pragma.m 8 Nov 2005 04:02:16 -0000
@@ -236,6 +236,17 @@
ThrowStatus, Context, !ModuleInfo, !IO)
)
;
+ Pragma = trailing_info(PredOrFunc, SymName, Arity, ModeNum,
+ TrailingStatus),
+ ( ImportStatus \= opt_imported ->
+ module_info_incr_errors(!ModuleInfo),
+ Pieces = [words("Error: illegal use of pragma `trailing_info'.")],
+ write_error_pieces(Context, 0, Pieces, !IO)
+ ;
+ add_pragma_trailing_info(PredOrFunc, SymName, Arity, ModeNum,
+ TrailingStatus, Context, !ModuleInfo, !IO)
+ )
+ ;
% Handle pragma type_spec decls later on (when we process clauses).
Pragma = type_spec(_, _, _, _, _, _, _, _)
;
@@ -576,6 +587,34 @@
%-----------------------------------------------------------------------------%
+:- pred add_pragma_trailing_info(pred_or_func::in, sym_name::in, arity::in,
+ mode_num::in, trailing_status::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+add_pragma_trailing_info(PredOrFunc, SymName, Arity, ModeNum, TrailingStatus,
+ _Context, !ModuleInfo, !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, Preds),
+ (
+ predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
+ PredOrFunc, SymName, Arity, [PredId])
+ ->
+ module_info_get_trailing_info(!.ModuleInfo, TrailingInfo0),
+ proc_id_to_int(ProcId, ModeNum),
+ map.set(TrailingInfo0, proc(PredId, ProcId), TrailingStatus,
+ TrailingInfo),
+ module_info_set_trailing_info(TrailingInfo, !ModuleInfo)
+ ;
+ % XXX We'll just ignore this for the time being -
+ % it causes errors with transitive-intermodule optimization.
+ %prog_out__write_context(Context, !IO),
+ %io__write_string("Internal compiler error: " ++
+ % "unknown predicate in `pragma trailing_info'.\n", !IO),
+ %module_info_incr_errors(!ModuleInfo)
+ true
+ ).
+
+%-----------------------------------------------------------------------------%
+
add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo, !IO) :-
Pragma = type_spec(SymName, _, Arity, MaybePredOrFunc, _, _, _, _),
module_info_get_predicate_table(!.ModuleInfo, Preds),
Index: compiler/add_trail_ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_trail_ops.m,v
retrieving revision 1.23
diff -u -r1.23 add_trail_ops.m
--- compiler/add_trail_ops.m 4 Nov 2005 03:40:42 -0000 1.23
+++ compiler/add_trail_ops.m 7 Nov 2005 05:23:29 -0000
@@ -35,13 +35,17 @@
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
-:- pred add_trail_ops(module_info::in, proc_info::in, proc_info::out) is det.
+:- import_module bool.
+
+:- pred add_trail_ops(bool::in, module_info::in,
+ proc_info::in, proc_info::out) is det.
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module hlds.code_model.
+:- import_module hlds.goal_form.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
@@ -55,7 +59,6 @@
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
-:- import_module bool.
:- import_module list.
:- import_module map.
:- import_module require.
@@ -74,21 +77,23 @@
% table that it contains to lookup the pred_ids for the builtin procedures
% that we insert calls to. We do not update the module_info as we're
% traversing the goal.
-
+ %
:- type trail_ops_info
---> trail_ops_info(
- varset :: prog_varset,
- var_types :: vartypes,
- module_info :: module_info
+ varset :: prog_varset,
+ var_types :: vartypes,
+ module_info :: module_info,
+ opt_trail_usage :: bool
).
-add_trail_ops(ModuleInfo0, !Proc) :-
+add_trail_ops(OptTrailUsage, ModuleInfo0, !Proc) :-
proc_info_goal(!.Proc, Goal0),
proc_info_varset(!.Proc, VarSet0),
proc_info_vartypes(!.Proc, VarTypes0),
- TrailOpsInfo0 = trail_ops_info(VarSet0, VarTypes0, ModuleInfo0),
+ TrailOpsInfo0 = trail_ops_info(VarSet0, VarTypes0, ModuleInfo0,
+ OptTrailUsage),
goal_add_trail_ops(Goal0, Goal, TrailOpsInfo0, TrailOpsInfo),
- TrailOpsInfo = trail_ops_info(VarSet, VarTypes, _),
+ TrailOpsInfo = trail_ops_info(VarSet, VarTypes, _, _),
proc_info_set_goal(Goal, !Proc),
proc_info_set_varset(VarSet, !Proc),
proc_info_set_vartypes(VarTypes, !Proc),
@@ -101,8 +106,19 @@
:- pred goal_add_trail_ops(hlds_goal::in, hlds_goal::out,
trail_ops_info::in, trail_ops_info::out) is det.
-goal_add_trail_ops(GoalExpr0 - GoalInfo, Goal, !Info) :-
- goal_expr_add_trail_ops(GoalExpr0, GoalInfo, Goal, !Info).
+goal_add_trail_ops(!Goal, !Info) :-
+ OptTrailUsage = !.Info ^ opt_trail_usage,
+ (
+ OptTrailUsage = yes,
+ goal_cannot_modify_trail(!.Info ^ module_info, !.Goal)
+ ->
+ % Don't add trail ops if the goal cannot modify the trail
+ % and we are optimizing trail usage.
+ true
+ ;
+ !.Goal = GoalExpr0 - GoalInfo,
+ goal_expr_add_trail_ops(GoalExpr0, GoalInfo, !:Goal, !Info)
+ ).
:- pred goal_expr_add_trail_ops(hlds_goal_expr::in, hlds_goal_info::in,
hlds_goal::out, trail_ops_info::in, trail_ops_info::out) is det.
Index: compiler/goal_form.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_form.m,v
retrieving revision 1.19
diff -u -r1.19 goal_form.m
--- compiler/goal_form.m 28 Oct 2005 02:10:06 -0000 1.19
+++ compiler/goal_form.m 3 Nov 2005 02:50:23 -0000
@@ -106,6 +106,13 @@
int::out, int::out) is det.
%-----------------------------------------------------------------------------%
+
+ % Succeeds if the goal (and its subgoals) do not modify the trail.
+ % (Requires --analyse-trail-usage to be of any use.)
+ %
+:- pred goal_cannot_modify_trail(module_info::in, hlds_goal::in) is semidet.
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
@@ -546,6 +553,49 @@
int__min(Min0, Min1, Min),
int__max(Max0, Max1, Max)
).
+%-----------------------------------------------------------------------------%
+
+goal_cannot_modify_trail(ModuleInfo, GoalExpr - _GoalInfo) :-
+ goal_cannot_modify_trail_2(ModuleInfo, GoalExpr).
+
+:- pred goal_cannot_modify_trail_2(module_info::in, hlds_goal_expr::in)
+ is semidet.
+
+goal_cannot_modify_trail_2(ModuleInfo, Goal) :-
+ (
+ Goal = conj(Goals)
+ ;
+ Goal = par_conj(Goals)
+ ;
+ Goal = disj(Goals)
+ ;
+ Goal = if_then_else(_, IfGoal, ThenGoal, ElseGoal),
+ Goals = [IfGoal, ThenGoal, ElseGoal]
+ ),
+ list.all_true(goal_cannot_modify_trail(ModuleInfo), Goals).
+goal_cannot_modify_trail_2(ModuleInfo, Goal) :-
+ Goal = call(CallPredId, CallProcId, _, _, _, _),
+ module_info_get_trailing_info(ModuleInfo, TrailingInfo),
+ map.search(TrailingInfo, proc(CallPredId, CallProcId), TrailingStatus),
+ TrailingStatus = will_not_modify_trail.
+% XXX We should actually look this up since we have closure analysis.
+goal_cannot_modify_trail_2(_ModuleInfo, generic_call(_, _, _, _)) :- fail.
+goal_cannot_modify_trail_2(ModuleInfo, switch(_, _, Goals)) :-
+ CheckCase = (pred(Case::in) is semidet :-
+ Case = case(_, Goal),
+ goal_cannot_modify_trail(ModuleInfo, Goal)
+ ),
+ list.all_true(CheckCase, Goals).
+goal_cannot_modify_trail_2(_, unify(_, _, _, _, _)). % XXX Is this correct.
+goal_cannot_modify_trail_2(ModuleInfo, not(Goal)) :-
+ goal_cannot_modify_trail(ModuleInfo, Goal).
+goal_cannot_modify_trail_2(ModuleInfo, scope(_, Goal)) :-
+ goal_cannot_modify_trail(ModuleInfo, Goal).
+goal_cannot_modify_trail_2(_, Goal) :-
+ Goal = foreign_proc(Attributes, _, _, _, _, _),
+ may_modify_trail(Attributes) = will_not_modify_trail.
+goal_cannot_modify_trail_2(_, shorthand(_)) :-
+ unexpected(this_file, "goal_cannot_modify_trial_2: shorthand goal.").
%-----------------------------------------------------------------------------%
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.123
diff -u -r1.123 hlds_module.m
--- compiler/hlds_module.m 4 Nov 2005 03:40:46 -0000 1.123
+++ compiler/hlds_module.m 7 Nov 2005 05:23:29 -0000
@@ -99,8 +99,14 @@
% Map from proc to an indication of whether or not it
% might throw an exception.
+ %
:- type exception_info == map(pred_proc_id, exception_status).
+ % Map from proc to an indication of whether or not it
+ % modifies the trail.
+ %
+:- type trailing_info == map(pred_proc_id, trailing_status).
+
% List of procedures for which there are user-requested type
% specializations, and a list of predicates which should be
% processed by higher_order.m to ensure the production of those
@@ -364,6 +370,9 @@
:- pred module_info_get_exception_info(module_info::in, exception_info::out)
is det.
+:- pred module_info_get_trailing_info(module_info::in, trailing_info::out)
+ is det.
+
:- pred module_info_set_proc_requests(proc_requests::in,
module_info::in, module_info::out) is det.
@@ -373,6 +382,9 @@
:- pred module_info_set_exception_info(exception_info::in,
module_info::in, module_info::out) is det.
+:- pred module_info_set_trailing_info(trailing_info::in,
+ module_info::in, module_info::out) is det.
+
:- pred module_info_set_num_errors(int::in, module_info::in, module_info::out)
is det.
@@ -646,9 +658,14 @@
unused_arg_info :: unused_arg_info,
% Exception information about procedures in the current module
- % (this includes opt_imported procedures).
+ % NOTE: this includes opt_imported procedures.
exception_info :: exception_info,
+ % Information about whether procedures in the current module
+ % modify the trail or not.
+ % NOTE: this includes opt_imported procedures.
+ trailing_info :: trailing_info,
+
% How many lambda expressions there are at different contexts
% in the module. This is used to uniquely identify lambda
% expressions that appear on the same line of the same file.
@@ -715,6 +732,7 @@
set__init(StratPreds),
map__init(UnusedArgInfo),
map__init(ExceptionInfo),
+ map__init(TrailingInfo),
set__init(TypeSpecPreds),
set__init(TypeSpecForcePreds),
@@ -738,7 +756,7 @@
map__init(NoTagTypes),
ModuleSubInfo = module_sub_info(Name, Globals, no, [], [], [], [], no, 0,
- [], [], StratPreds, UnusedArgInfo, ExceptionInfo,
+ [], [], StratPreds, UnusedArgInfo, ExceptionInfo, TrailingInfo,
map.init, counter__init(1), ImportedModules,
IndirectlyImportedModules, no_aditi_compilation, TypeSpecInfo,
NoTagTypes, no, [], init_analysis_info(mmc),
@@ -812,6 +830,7 @@
module_info_get_stratified_preds(MI, MI ^ sub_info ^ must_be_stratified_preds).
module_info_get_unused_arg_info(MI, MI ^ sub_info ^ unused_arg_info).
module_info_get_exception_info(MI, MI ^ sub_info ^ exception_info).
+module_info_get_trailing_info(MI, MI ^ sub_info ^ trailing_info).
module_info_get_lambdas_per_context(MI, MI ^ sub_info ^ lambdas_per_context).
module_info_get_model_non_pragma_counter(MI,
MI ^ sub_info ^ model_non_pragma_counter).
@@ -919,6 +938,8 @@
MI ^ sub_info ^ unused_arg_info := NewVal).
module_info_set_exception_info(NewVal, MI,
MI ^ sub_info ^ exception_info := NewVal).
+module_info_set_trailing_info(NewVal, MI,
+ MI ^ sub_info ^ trailing_info := NewVal).
module_info_set_lambdas_per_context(NewVal, MI,
MI ^ sub_info ^ lambdas_per_context := NewVal).
module_info_set_model_non_pragma_counter(NewVal, MI,
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.358
diff -u -r1.358 mercury_compile.m
--- compiler/mercury_compile.m 28 Oct 2005 14:00:33 -0000 1.358
+++ compiler/mercury_compile.m 8 Nov 2005 05:13:21 -0000
@@ -74,6 +74,7 @@
:- import_module transform_hlds.termination.
:- import_module transform_hlds.term_constr_main.
:- import_module transform_hlds.exception_analysis.
+:- import_module transform_hlds.trailing_analysis.
:- import_module transform_hlds.higher_order.
:- import_module transform_hlds.accumulator.
:- import_module transform_hlds.tupling.
@@ -2069,6 +2070,8 @@
ExceptionAnalysis),
globals__lookup_bool_option(Globals, analyse_closures,
ClosureAnalysis),
+ globals__lookup_bool_option(Globals, analyse_trail_usage,
+ TrailingAnalysis),
(
MakeOptInt = yes,
intermod__write_optfile(!HLDS, !IO),
@@ -2082,6 +2085,7 @@
; Termination = yes
; Termination2 = yes
; ExceptionAnalysis = yes
+ ; TrailingAnalysis = yes
)
->
frontend_pass_by_phases(!HLDS, FoundModeError, !DumpInfo, !IO),
@@ -2120,6 +2124,12 @@
maybe_termination2(Verbose, Stats, !HLDS, !IO)
;
Termination2 = no
+ ),
+ (
+ TrailingAnalysis = yes,
+ maybe_analyse_trail_usage(Verbose, Stats, !HLDS, !IO)
+ ;
+ TrailingAnalysis = no
)
;
io__set_exit_status(1, !IO)
@@ -2184,6 +2194,8 @@
maybe_dump_hlds(!.HLDS, 120, "termination", !DumpInfo, !IO),
maybe_termination2(Verbose, Stats, !HLDS, !IO),
maybe_dump_hlds(!.HLDS, 121, "termination_2", !DumpInfo, !IO),
+ maybe_analyse_trail_usage(Verbose, Stats, !HLDS, !IO),
+ maybe_dump_hlds(!.HLDS, 123, "trailing analysis", !DumpInfo, !IO),
trans_opt__write_optfile(!.HLDS, !IO).
:- pred frontend_pass_by_phases(module_info::in, module_info::out,
@@ -2297,6 +2309,12 @@
maybe_termination2(Verbose, Stats, !HLDS, !IO),
maybe_dump_hlds(!.HLDS, 121, "termination2", !DumpInfo, !IO),
+
+ % XXX We should actually do this after any optimizations
+ % that introduce new predicates, so that we can add them
+ % to the trailing_info table as well.
+ maybe_analyse_trail_usage(Verbose, Stats, !HLDS, !IO),
+ maybe_dump_hlds(!.HLDS, 123, "trail_usage", !DumpInfo, !IO),
maybe_type_ctor_infos(Verbose, Stats, !HLDS, !IO),
maybe_dump_hlds(!.HLDS, 125, "type_ctor_infos", !DumpInfo, !IO),
@@ -2929,6 +2947,20 @@
;
true
).
+:- pred maybe_analyse_trail_usage(bool::in, bool::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+maybe_analyse_trail_usage(Verbose, Stats, !HLDS, !IO) :-
+ globals.io_lookup_bool_option(analyse_trail_usage, AnalyseTrail, !IO),
+ (
+ AnalyseTrail = yes,
+ maybe_write_string(Verbose, "% Analysing trail usage...\n", !IO),
+ analyse_trail_usage(!HLDS, !IO),
+ maybe_write_string(Verbose, "% Trail usage analysis done.\n", !IO),
+ maybe_report_stats(Stats, !IO)
+ ;
+ AnalyseTrail = no
+ ).
:- pred check_unique_modes(bool::in, bool::in,
module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
@@ -3132,9 +3164,11 @@
globals__io_lookup_bool_option(use_trail, UseTrail, !IO),
(
UseTrail = yes,
+ globals.io_lookup_bool_option(optimize_trail_usage, OptTrailUse, !IO),
maybe_write_string(Verbose, "% Adding trailing operations...\n", !IO),
maybe_flush_output(Verbose, !IO),
- process_all_nonimported_procs(update_proc(add_trail_ops), !HLDS, !IO),
+ process_all_nonimported_procs(update_proc(add_trail_ops(OptTrailUse)),
+ !HLDS, !IO),
maybe_write_string(Verbose, "% done.\n", !IO),
maybe_report_stats(Stats, !IO)
;
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.273
diff -u -r1.273 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 8 Nov 2005 03:58:53 -0000 1.273
+++ compiler/mercury_to_mercury.m 8 Nov 2005 04:02:17 -0000
@@ -156,6 +156,9 @@
:- pred mercury_output_pragma_exceptions(pred_or_func::in, sym_name::in,
int::in, mode_num::in, exception_status::in, io::di, io::uo) is det.
+:- pred mercury_output_pragma_trailing_info(pred_or_func::in, sym_name::in,
+ arity::in, mode_num::in, trailing_status::in, io::di, io::uo) is det.
+
% Write an Aditi index specifier.
%
:- pred mercury_output_index_spec(index_spec::in, io::di, io::uo) is det.
@@ -598,6 +601,11 @@
mercury_output_pragma_exceptions(PredOrFunc, PredName, Arity, ModeNum,
ThrowStatus, !IO)
;
+ Pragma = trailing_info(PredOrFunc, PredName, Arity, ModeNum,
+ TrailingStatus),
+ mercury_output_pragma_trailing_info(PredOrFunc, PredName, Arity,
+ ModeNum, TrailingStatus, !IO)
+ ;
Pragma = fact_table(Pred, Arity, FileName),
mercury_format_pragma_fact_table(Pred, Arity, FileName, !IO)
;
@@ -3295,6 +3303,31 @@
%-----------------------------------------------------------------------------%
+mercury_output_pragma_trailing_info(PredOrFunc, SymName, Arity, ModeNum,
+ TrailingStatus, !IO) :-
+ io.write_string(":- pragma trailing_info(", !IO),
+ write_pred_or_func(PredOrFunc, !IO),
+ io.write_string(", ", !IO),
+ mercury_output_bracketed_sym_name(SymName, !IO),
+ io.write_string(", ", !IO),
+ io.write_int(Arity, !IO),
+ io.write_string(", ", !IO),
+ io.write_int(ModeNum, !IO),
+ io.write_string(", ", !IO),
+ (
+ TrailingStatus = may_modify_trail,
+ io.write_string("may_modify_trail", !IO)
+ ;
+ TrailingStatus = will_not_modify_trail,
+ io.write_string("will_not_modify_trail", !IO)
+ ;
+ TrailingStatus = conditional,
+ io.write_string("conditional", !IO)
+ ),
+ io.write_string(").\n", !IO).
+
+%-----------------------------------------------------------------------------%
+
mercury_output_pragma_decl(PredName, Arity, PredOrFunc, PragmaName, MaybeAfter,
!IO) :-
mercury_format_pragma_decl(PredName, Arity, PredOrFunc, PragmaName,
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.118
diff -u -r1.118 module_qual.m
--- compiler/module_qual.m 28 Oct 2005 02:10:24 -0000 1.118
+++ compiler/module_qual.m 3 Nov 2005 02:50:23 -0000
@@ -1081,6 +1081,7 @@
qualify_mode_list(Modes0, Modes, !Info, !IO).
qualify_pragma(X at unused_args(_, _, _, _, _), X, !Info, !IO).
qualify_pragma(X at exceptions(_, _, _, _, _), X, !Info, !IO).
+qualify_pragma(X at trailing_info(_, _, _, _, _), X, !Info, !IO).
qualify_pragma(type_spec(A, B, C, D, MaybeModes0, Subst0, G, H),
type_spec(A, B, C, D, MaybeModes, Subst, G, H),
!Info, !IO) :-
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.356
diff -u -r1.356 modules.m
--- compiler/modules.m 8 Nov 2005 03:58:53 -0000 1.356
+++ compiler/modules.m 8 Nov 2005 04:02:18 -0000
@@ -2116,6 +2116,7 @@
pragma_allowed_in_interface(promise_semipure(_, _), no).
pragma_allowed_in_interface(unused_args(_, _, _, _, _), no).
pragma_allowed_in_interface(exceptions(_, _, _, _, _), no).
+pragma_allowed_in_interface(trailing_info(_, _, _, _, _), no).
pragma_allowed_in_interface(type_spec(_, _, _, _, _, _, _, _), yes).
pragma_allowed_in_interface(termination_info(_, _, _, _, _), yes).
pragma_allowed_in_interface(termination2_info(_,_, _, _, _, _), yes).
@@ -7682,7 +7683,8 @@
; Pragma = check_termination(_, _), Reorderable = yes
; Pragma = context(_, _), Reorderable = no
; Pragma = does_not_terminate(_, _), Reorderable = yes
- ; Pragma = exceptions(_, _, _, _, _), Reorderable = no
+ ; Pragma = exceptions(_, _, _, _, _), Reorderable = yes
+ ; Pragma = trailing_info(_, _, _, _, _), Reorderable = yes
; Pragma = export(_, _, _, _), Reorderable = yes
; Pragma = fact_table(_, _, _), Reorderable = no
; Pragma = foreign_code(_, _), Reorderable = no
@@ -7794,6 +7796,7 @@
; Pragma = terminates(_, _), Reorderable = yes
; Pragma = termination2_info( _, _, _, _, _, _), Reorderable = no
; Pragma = termination_info(_, _, _, _, _), Reorderable = yes
+ ; Pragma = trailing_info(_, _, _, _, _), Reorderable = yes
; Pragma = type_spec(_, _, _, _, _, _, _, _), Reorderable = yes
; Pragma = unused_args(_, _, _, _, _), Reorderable = yes
).
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.474
diff -u -r1.474 options.m
--- compiler/options.m 7 Nov 2005 05:42:07 -0000 1.474
+++ compiler/options.m 7 Nov 2005 06:30:19 -0000
@@ -136,6 +136,7 @@
; debug_stack_opt
; debug_make
; debug_closure
+ ; debug_trail_usage
% Output options
; make_short_interface
@@ -522,15 +523,17 @@
% Stuff for the new termination analyser.
; termination2
- ; check_termination2
- ; verbose_check_termination2
- ; termination2_norm
- ; widening_limit
- ; arg_size_analysis_only
- ; propagate_failure_constrs
- ; term2_maximum_matrix_size
+ ; check_termination2
+ ; verbose_check_termination2
+ ; termination2_norm
+ ; widening_limit
+ ; arg_size_analysis_only
+ ; propagate_failure_constrs
+ ; term2_maximum_matrix_size
; analyse_exceptions
; analyse_closures
+ ; analyse_trail_usage
+ ; optimize_trail_usage
; untuple
; tuple
; tuple_trace_counts_file
@@ -866,7 +869,8 @@
debug_liveness - int(-1),
debug_stack_opt - int(-1),
debug_make - bool(no),
- debug_closure - bool(no)
+ debug_closure - bool(no),
+ debug_trail_usage - bool(no)
]).
option_defaults_2(output_option, [
% Output Options (mutually exclusive)
@@ -1143,7 +1147,11 @@
% value for this is.
term2_maximum_matrix_size - int(70),
analyse_exceptions - bool(no),
- analyse_closures - bool(no)
+ analyse_closures - bool(no),
+ analyse_trail_usage - bool(no),
+ % XXX Change this to yes when trailing analysis is
+ % complete.
+ optimize_trail_usage - bool(no)
]).
option_defaults_2(optimization_option, [
% Optimization options
@@ -1561,6 +1569,7 @@
long_option("debug-stack-opt", debug_stack_opt).
long_option("debug-make", debug_make).
long_option("debug-closure", debug_closure).
+long_option("debug-trail-usage", debug_trail_usage).
% output options (mutually exclusive)
long_option("generate-source-file-mapping",
@@ -1941,6 +1950,9 @@
long_option("analyse-exceptions", analyse_exceptions).
long_option("analyse-closures", analyse_closures).
long_option("analyse-local-closures", analyse_closures).
+long_option("analyse-trail-usage", analyse_trail_usage).
+long_option("optimize-trail-usage", optimize_trail_usage).
+long_option("optimise-trail-usage", optimize_trail_usage).
long_option("untuple", untuple).
long_option("tuple", tuple).
long_option("tuple-trace-counts-file", tuple_trace_counts_file).
@@ -2880,11 +2892,14 @@
"\tOutput detailed debugging traces of the liveness analysis",
"\tof the predicate with the given predicate id.",
"--debug-make",
- "\tOutput detailed debugging traces of the `--make' option."
+ "\tOutput detailed debugging traces of the `--make' option.",
% This can be uncommented when the '--analyse-closures' option is uncommented.
% (See below.)
% "--debug-closure",
% "\tOutput detailed debugging traces of the closure analysis."
+ "--debug-trail-usage",
+ "\tOutput detail debugging traces of the `--analyse-trail-usage'",
+ "\toption."
]).
:- pred options_help_output(io::di, io::uo) is det.
@@ -3966,7 +3981,7 @@
"--analyse-exceptions",
"\tEnable exception analysis. Identify those",
"\tprocedures that will not throw an exception.",
- "\tSome optimizations can make use of this information."
+ "\tSome optimizations can make use of this information.",
% XXX The options controlling closure analysis are currently
% commented out because it isn't useful. It can be uncommented when
% we actually have something that uses it.
@@ -3974,6 +3989,17 @@
% "\tEnable closure analysis. Try to identify the possible",
% "\tvalues that higher-order valued variables can take.",
% "\tSome optimizations can make use of this information.",
+ "--analyse-trail-usage",
+ "\tEnable trail usage analysis. Identify those",
+ "\tprocedures that will not modify the trail.",
+ "\tThis information can be used to reduce the overhead",
+ "\tof trailing."
+% `--no-optimize-trail-usage' is a developer-only option. It
+% is intended for benchmarking the trail usage optimization.
+% Otherwise, there is usually not any point in turning it off.
+ %"--no-optimize-trail-usage",
+ %"\tDo not try and restrict trailing to those parts",
+ %"\tof the program that actually use it."
% ,
% "--untuple",
% "\tExpand out procedure arguments when the argument type",
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.146
diff -u -r1.146 prog_data.m
--- compiler/prog_data.m 8 Nov 2005 03:58:54 -0000 1.146
+++ compiler/prog_data.m 8 Nov 2005 04:02:18 -0000
@@ -517,6 +517,16 @@
% Should only appear in `.opt' or `.trans_opt' files.
)
+ ; trailing_info(
+ trailing_info_p_or_f :: pred_or_func,
+ trailing_info_name :: sym_name,
+ trailing_info_arity :: arity,
+ trailing_info_mode :: mode_num,
+ trailing_info_status :: trailing_status
+ )
+ % PredName, Arity, Mode number, Trailing status.
+ % Should on appear in `.opt' or `.trans_opt' files.
+
%
% Diagnostics pragmas (pragmas related to compiler warnings/errors)
%
@@ -909,6 +919,16 @@
%-----------------------------------------------------------------------------%
%
+% Stuff for the trailing analysis
+%
+
+:- type trailing_status
+ ---> may_modify_trail
+ ; will_not_modify_trail
+ ; conditional.
+
+%-----------------------------------------------------------------------------%
+%
% Stuff for the `type_spec' pragma
%
@@ -1154,6 +1174,7 @@
:- func may_throw_exception(pragma_foreign_proc_attributes) =
may_throw_exception.
:- func ordinary_despite_detism(pragma_foreign_proc_attributes) = bool.
+:- func may_modify_trail(pragma_foreign_proc_attributes) = may_modify_trail.
:- func extra_attributes(pragma_foreign_proc_attributes)
= pragma_foreign_proc_extra_attributes.
@@ -1193,6 +1214,10 @@
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
+:- pred set_may_modify_trail(may_modify_trail::in,
+ pragma_foreign_proc_attributes::in,
+ pragma_foreign_proc_attributes::out) is det.
+
:- pred add_extra_attribute(pragma_foreign_proc_extra_attribute::in,
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
@@ -1222,6 +1247,10 @@
; tabled_for_io_unitize
; tabled_for_descendant_io.
+:- type may_modify_trail
+ ---> may_modify_trail
+ ; will_not_modify_trail.
+
:- type pragma_var
---> pragma_var(prog_var, string, mer_mode).
% variable, name, mode
@@ -2039,6 +2068,7 @@
may_throw_exception :: may_throw_exception,
legacy_purity_behaviour :: bool,
ordinary_despite_detism :: bool,
+ may_modify_trail :: may_modify_trail,
extra_attributes ::
list(pragma_foreign_proc_extra_attribute)
).
@@ -2046,7 +2076,7 @@
default_attributes(Language) =
attributes(Language, may_call_mercury, not_thread_safe,
not_tabled_for_io, purity_impure, depends_on_mercury_calls,
- default_exception_behaviour, no, no, []).
+ default_exception_behaviour, no, no, may_modify_trail, []).
set_may_call_mercury(MayCallMercury, Attrs0, Attrs) :-
Attrs = Attrs0 ^ may_call_mercury := MayCallMercury.
@@ -2066,6 +2096,8 @@
Attrs = Attrs0 ^ legacy_purity_behaviour := Legacy.
set_ordinary_despite_detism(OrdinaryDespiteDetism, Attrs0, Attrs) :-
Attrs = Attrs0 ^ ordinary_despite_detism := OrdinaryDespiteDetism.
+set_may_modify_trail(MayModifyTrail, Attrs0, Attrs) :-
+ Attrs = Attrs0 ^ may_modify_trail := MayModifyTrail.
attributes_to_strings(Attrs) = StringList :-
% We ignore Lang because it isn't an attribute that you can put
@@ -2073,7 +2105,7 @@
% is at the start of the pragma.
Attrs = attributes(_Lang, MayCallMercury, ThreadSafe, TabledForIO,
Purity, Terminates, Exceptions, _LegacyBehaviour,
- OrdinaryDespiteDetism, ExtraAttributes),
+ OrdinaryDespiteDetism, MayModifyTrail, ExtraAttributes),
(
MayCallMercury = may_call_mercury,
MayCallMercuryStr = "may_call_mercury"
@@ -2138,9 +2170,16 @@
OrdinaryDespiteDetism = no,
OrdinaryDespiteDetismStrList = []
),
+ (
+ MayModifyTrail = may_modify_trail,
+ MayModifyTrailStrList = ["may_modify_trail"]
+ ;
+ MayModifyTrail = will_not_modify_trail,
+ MayModifyTrailStrList = ["will_not_modify_trail"]
+ ),
StringList = [MayCallMercuryStr, ThreadSafeStr, TabledForIOStr |
PurityStrList] ++ TerminatesStrList ++ ExceptionsStrList ++
- OrdinaryDespiteDetismStrList ++
+ OrdinaryDespiteDetismStrList ++ MayModifyTrailStrList ++
list__map(extra_attribute_to_string, ExtraAttributes).
add_extra_attribute(NewAttribute, Attributes0,
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.93
diff -u -r1.93 prog_io_pragma.m
--- compiler/prog_io_pragma.m 8 Nov 2005 03:58:54 -0000 1.93
+++ compiler/prog_io_pragma.m 8 Nov 2005 04:02:19 -0000
@@ -1216,6 +1216,47 @@
Result = error("error in `:- pragma exceptions'", ErrorTerm)
).
+parse_pragma_type(ModuleName, "trailing_info", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
+ (
+ PragmaTerms = [
+ PredOrFuncTerm,
+ PredNameTerm,
+ term.functor(term.integer(Arity), [], _),
+ term.functor(term.integer(ModeNum), [], _),
+ TrailingStatusTerm
+ ],
+ (
+ PredOrFuncTerm = term.functor(term.atom("predicate"), [], _),
+ PredOrFunc = predicate
+ ;
+ PredOrFuncTerm = term.functor(term.atom("function"), [], _),
+ PredOrFunc = function
+ ),
+ parse_implicitly_qualified_term(ModuleName, PredNameTerm,
+ ErrorTerm, "`:- pragma trailing_info' declaration",
+ PredNameResult),
+ PredNameResult = ok(PredName, []),
+ (
+ TrailingStatusTerm = term.functor(
+ term.atom("will_not_modify_trail"), [], _),
+ TrailingStatus = will_not_modify_trail
+ ;
+ TrailingStatusTerm = term.functor(
+ term.atom("may_modify_trail"), [], _),
+ TrailingStatus = may_modify_trail
+ ;
+ TrailingStatusTerm = term.functor(
+ term.atom("conditional"), [], _),
+ TrailingStatus = conditional
+ )
+ ->
+ Result = ok(pragma(user, trailing_info(PredOrFunc, PredName,
+ Arity, ModeNum, TrailingStatus)))
+ ;
+ Result = error("error in `:- pragma trailing_info'", ErrorTerm)
+ ).
+
parse_pragma_type(ModuleName, "mode_check_clauses", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
parse_simple_pragma(ModuleName, "mode_check_clauses",
@@ -1312,7 +1353,8 @@
; backend(backend)
; terminates(terminates)
; will_not_throw_exception
- ; ordinary_despite_detism.
+ ; ordinary_despite_detism
+ ; may_modify_trail(may_modify_trail).
:- pred parse_pragma_foreign_proc_attributes_term(foreign_language::in,
string::in, term::in, maybe1(pragma_foreign_proc_attributes)::out)
@@ -1348,7 +1390,9 @@
purity(purity_semipure) - purity(purity_impure),
terminates(terminates) - terminates(does_not_terminate),
terminates(depends_on_mercury_calls) - terminates(terminates),
- terminates(depends_on_mercury_calls) - terminates(does_not_terminate)
+ terminates(depends_on_mercury_calls) - terminates(does_not_terminate),
+ may_modify_trail(may_modify_trail) -
+ may_modify_trail(will_not_modify_trail)
],
(
parse_pragma_foreign_proc_attributes_term0(Term, AttrList)
@@ -1395,6 +1439,8 @@
add_extra_attribute(backend(Backend), !Attrs).
process_attribute(ordinary_despite_detism, !Attrs) :-
set_ordinary_despite_detism(yes, !Attrs).
+process_attribute(may_modify_trail(TrailMod), !Attrs) :-
+ set_may_modify_trail(TrailMod, !Attrs).
% Aliasing is currently ignored in the main branch compiler.
%
@@ -1465,7 +1511,9 @@
Flag = will_not_throw_exception
; parse_ordinary_despite_detism(Term) ->
Flag = ordinary_despite_detism
- ;
+ ; parse_may_modify_trail(Term, TrailMod) ->
+ Flag = may_modify_trail(TrailMod)
+ ;
fail
).
@@ -1488,6 +1536,13 @@
not_thread_safe).
parse_threadsafe(term__functor(term__atom("maybe_thread_safe"), [], _),
maybe_thread_safe).
+
+:- pred parse_may_modify_trail(term::in, may_modify_trail::out) is semidet.
+
+parse_may_modify_trail(term.functor(term.atom("may_modify_trail"), [], _),
+ may_modify_trail).
+parse_may_modify_trail(term.functor(term.atom("will_not_modify_trail"), [], _),
+ will_not_modify_trail).
:- pred parse_tabled_for_io(term::in, tabled_for_io::out) is semidet.
@@ -1913,3 +1968,5 @@
Rational = rat__rat(Numer, Denom).
%-----------------------------------------------------------------------------%
+:- end_module prog_io_pragma.
+%-----------------------------------------------------------------------------%
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.31
diff -u -r1.31 recompilation.version.m
--- compiler/recompilation.version.m 8 Nov 2005 03:58:54 -0000 1.31
+++ compiler/recompilation.version.m 8 Nov 2005 04:02:19 -0000
@@ -576,7 +576,9 @@
is_pred_pragma(unused_args(PredOrFunc, Name, Arity, _, _),
yes(yes(PredOrFunc) - Name / Arity)).
is_pred_pragma(exceptions(PredOrFunc, Name, Arity, _, _),
- yes(yes(PredOrFunc) - Name / Arity)).
+ yes(yes(PredOrFunc) - Name / Arity)).
+is_pred_pragma(trailing_info(PredOrFunc, Name, Arity, _, _),
+ yes(yes(PredOrFunc) - Name / Arity)).
is_pred_pragma(fact_table(Name, Arity, _), yes(no - Name / Arity)).
is_pred_pragma(reserve_tag(_TypeName, _TypeArity), no).
is_pred_pragma(aditi(Name, Arity), yes(no - Name / Arity)).
Index: compiler/trailing_analysis.m
===================================================================
RCS file: compiler/trailing_analysis.m
diff -N compiler/trailing_analysis.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/trailing_analysis.m 8 Nov 2005 05:16:53 -0000
@@ -0,0 +1,689 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 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: trailing_analysis.m
+% author: juliensf
+%
+% This module implements trail usage analysis. It annotates the HLDS with
+% information about which procedures may modify the trail.
+%
+% It intended to be used in helping the compiler decide when it is safe to
+% omit trailing operations in trailing grades. After running the analysis
+% the trailing status of each procedure is one of:
+%
+% (1) will_not_modify_trail
+% (2) may_modify_trail
+% (3) conditional
+%
+% These have the following meaning:
+%
+% (1) for all inputs the procedure will not modify the trail.
+% (2) for some inputs the procedure may modify the trail.
+% (3) the procedure is polymorphic and whether it may modify the trail
+% depends upon the instantiation of the type variables. We need
+% this because we can define types with user-defined equality or
+% comparison that modify the trail.
+%
+% NOTE: to be `conditional' a procedure cannot modify the trail itself,
+% any trail modifications that occur through the conditional procedure
+% must result from a higher-order call or a call to a user-defined equality
+% or comparison predicate.
+%
+% For procedures defined using the foreign language interface we rely upon
+% the user annotations, `will_not_modify_trail' and `may_not_modify_trail'.
+%
+% The predicates for determining if individual goals modify the trail
+% are in goal_form.m.
+%
+% TODO:
+% - Rather than using the predicates in goal_form.m., annotate each
+% goal with trail usage information. These would prevent multiple
+% traversals of the goal structure. It would also make it easier
+% to do "clever" things during the trailing transformation.
+%
+% - Use the results of closure analysis to determine the trailing
+% status of higher-order calls.
+%
+%----------------------------------------------------------------------------%
+
+:- module transform_hlds.trailing_analysis.
+
+:- interface.
+
+:- import_module hlds.hlds_module.
+:- import_module hlds.hlds_pred.
+
+:- import_module io.
+
+ % Perform trailing analysis on a module.
+ %
+:- pred analyse_trail_usage(module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+ % Write out the trailing_info pragma for this module.
+ %
+:- pred write_pragma_trailing_info(module_info::in, trailing_info::in,
+ pred_id::in, io::di, io::uo) is det.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module check_hlds.mode_util.
+:- import_module check_hlds.type_util.
+:- import_module hlds.code_model.
+:- import_module hlds.hlds_error_util.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_pred.
+:- import_module hlds.make_hlds.
+:- import_module hlds.passes_aux.
+:- 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.error_util.
+:- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.modules.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_util.
+:- import_module parse_tree.prog_type.
+:- import_module transform_hlds.dependency_graph.
+
+:- import_module bool.
+:- import_module list.
+:- import_module map.
+:- import_module set.
+:- import_module std_util.
+:- import_module string.
+:- import_module term.
+
+%----------------------------------------------------------------------------%
+%
+% Perform trail usage analysis on a module
+%
+
+analyse_trail_usage(!ModuleInfo, !IO) :-
+ module_info_ensure_dependency_info(!ModuleInfo),
+ module_info_dependency_info(!.ModuleInfo, DepInfo),
+ hlds_dependency_info_get_dependency_ordering(DepInfo, SCCs),
+ globals.io_lookup_bool_option(debug_trail_usage, Debug, !IO),
+ list.foldl2(process_scc(Debug), SCCs, !ModuleInfo, !IO),
+ globals.io_lookup_bool_option(make_optimization_interface,
+ MakeOptInt, !IO),
+ (
+ MakeOptInt = yes,
+ make_opt_int(!.ModuleInfo, !IO)
+ ;
+ MakeOptInt = no
+ ).
+
+%----------------------------------------------------------------------------%
+%
+% Perform trail usage analysis on a SCC
+%
+
+:- type scc == list(pred_proc_id).
+
+:- type proc_results == list(proc_result).
+
+:- type proc_result
+ ---> proc_result(
+ ppid :: pred_proc_id,
+ status :: trailing_status
+ ).
+
+:- pred process_scc(bool::in, scc::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+process_scc(Debug, SCC, !ModuleInfo, !IO) :-
+ ProcResults = check_procs_for_trail_mods(SCC, !.ModuleInfo),
+ %
+ % The `Results' above are the results of analysing each
+ % individual procedure in the SCC - we now have to combine
+ % them in a meaningful way.
+ %
+ Status = combine_individual_proc_results(ProcResults),
+ %
+ % Print out debugging information.
+ %
+ (
+ Debug = yes,
+ dump_trail_usage_debug_info(!.ModuleInfo, SCC, Status, !IO)
+ ;
+ Debug = no
+ ),
+ %
+ % Update the trailing_info with information about this SCC.
+ %
+ module_info_get_trailing_info(!.ModuleInfo, TrailingInfo0),
+ Update = (pred(PPId::in, Info0::in, Info::out) is det :-
+ Info = Info0 ^ elem(PPId) := Status
+ ),
+ list.foldl(Update, SCC, TrailingInfo0, TrailingInfo),
+ module_info_set_trailing_info(TrailingInfo, !ModuleInfo).
+
+ % Check each procedure in the SCC individually.
+ %
+:- func check_procs_for_trail_mods(scc, module_info) = proc_results.
+
+check_procs_for_trail_mods(SCC, ModuleInfo) = Result :-
+ list.foldl(check_proc_for_trail_mods(SCC, ModuleInfo), SCC, [], Result).
+
+ % Examine how the procedures interact with other procedures that
+ % are mutually-recursive to them.
+ %
+:- func combine_individual_proc_results(proc_results) = trailing_status.
+
+combine_individual_proc_results([]) = _ :-
+ unexpected(this_file, "Empty SCC during trailing analysis.").
+combine_individual_proc_results(ProcResults @ [_|_]) = SCC_Result :-
+ (
+ % If none of the procedures modifies the trail or is conditional then
+ % the SCC cannot modify the trail.
+ all [ProcResult] list.member(ProcResult, ProcResults) =>
+ ProcResult ^ status = will_not_modify_trail
+ ->
+ SCC_Result = will_not_modify_trail
+ ;
+ all [EResult] list.member(EResult, ProcResults) =>
+ EResult ^ status \= may_modify_trail,
+ some [CResult] (
+ list.member(CResult, ProcResults),
+ CResult ^ status = conditional
+ )
+ ->
+ SCC_Result = conditional
+ ;
+ % Otherwise the SCC may modify the trail.
+ SCC_Result = may_modify_trail
+ ).
+
+%----------------------------------------------------------------------------%
+%
+% Perform trail usage analysis on a procedure
+%
+
+:- pred check_proc_for_trail_mods(scc::in, module_info::in,
+ pred_proc_id::in, proc_results::in, proc_results::out) is det.
+
+check_proc_for_trail_mods(SCC, ModuleInfo, PPId, !Results) :-
+ module_info_pred_proc_info(ModuleInfo, PPId, _, ProcInfo),
+ proc_info_goal(ProcInfo, Body),
+ proc_info_vartypes(ProcInfo, VarTypes),
+ check_goal_for_trail_mods(SCC, ModuleInfo, VarTypes, Body, Result),
+ list.cons(proc_result(PPId, Result), !Results).
+
+%----------------------------------------------------------------------------%
+%
+% Perform trail usage analysis of a goal
+%
+
+:- pred check_goal_for_trail_mods(scc::in, module_info::in, vartypes::in,
+ hlds_goal::in, trailing_status::out) is det.
+
+check_goal_for_trail_mods(SCC, ModuleInfo, VarTypes, Goal - GoalInfo,
+ Result) :-
+ check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, Goal, GoalInfo,
+ Result).
+
+:- pred check_goal_for_trail_mods_2(scc::in, module_info::in, vartypes::in,
+ hlds_goal_expr::in, hlds_goal_info::in, trailing_status::out) is det.
+
+check_goal_for_trail_mods_2(_, _, _, Goal, _, will_not_modify_trail) :-
+ Goal = unify(_, _, _, Kind, _),
+ ( Kind = complicated_unify(_, _, _) ->
+ unexpected(this_file, "complicated unify during trail usage analysis.")
+ ;
+ true
+ ).
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, Goal, _, Result) :-
+ Goal = call(CallPredId, CallProcId, CallArgs, _, _, _),
+ CallPPId = proc(CallPredId, CallProcId),
+ module_info_pred_info(ModuleInfo, CallPredId, CallPredInfo),
+ (
+ % Handle (mutually-)recursive calls.
+ list.member(CallPPId, SCC)
+ ->
+ Types = list.map((func(Var) = VarTypes ^ det_elem(Var)), CallArgs),
+ TrailingStatus = check_types(ModuleInfo, Types),
+ Result = TrailingStatus
+ ;
+ pred_info_is_builtin(CallPredInfo)
+ ->
+ % There are no builtins that will modify the trail.
+ Result = will_not_modify_trail
+ ;
+ % Handle unify and compare.
+ (
+ ModuleName = pred_info_module(CallPredInfo),
+ any_mercury_builtin_module(ModuleName),
+ Name = pred_info_name(CallPredInfo),
+ Arity = pred_info_orig_arity(CallPredInfo),
+ ( SpecialPredId = spec_pred_compare
+ ; SpecialPredId = spec_pred_unify
+ ),
+ special_pred_name_arity(SpecialPredId, Name, _, Arity)
+ ;
+ pred_info_get_origin(CallPredInfo, Origin),
+ Origin = special_pred(SpecialPredId - _),
+ ( SpecialPredId = spec_pred_compare
+ ; SpecialPredId = spec_pred_unify
+ )
+ )
+ ->
+ % At the moment we assume that calls to out-of-line
+ % unification/comparisons are going to modify the trail.
+ % XXX This is far too conservative.
+ Result = may_modify_trail
+ ;
+ check_nonrecursive_call(ModuleInfo, VarTypes, CallPPId, CallArgs,
+ Result)
+ ).
+check_goal_for_trail_mods_2(_, _ModuleInfo, _VarTypes, Goal, _GoalInfo,
+ Result) :-
+ Goal = generic_call(Details, _Args, _ArgModes, _),
+ (
+ % XXX Use results of closure analysis to handle this.
+ Details = higher_order(_Var, _, _, _),
+ Result = may_modify_trail
+ ;
+ % XXX We could do better with class methods.
+ Details = class_method(_, _, _, _),
+ Result = may_modify_trail
+ ;
+ Details = cast(_),
+ Result = will_not_modify_trail
+ ;
+ % XXX I'm not sure what the correct thing to do for
+ % aditi builtins is.
+ Details = aditi_builtin(_, _),
+ Result = may_modify_trail
+ ).
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, not(Goal), _,
+ Result) :-
+ check_goal_for_trail_mods(SCC, ModuleInfo, VarTypes, Goal, Result).
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, Goal, OuterGoalInfo,
+ Result) :-
+ Goal = scope(_, InnerGoal),
+ check_goal_for_trail_mods(SCC, ModuleInfo, VarTypes, InnerGoal, Result0),
+ InnerGoal = _ - InnerGoalInfo,
+ goal_info_get_code_model(InnerGoalInfo, InnerCodeModel),
+ goal_info_get_code_model(OuterGoalInfo, OuterCodeModel),
+ (
+ % If we're at a commit for goal that might modify the trail then
+ % we will need to emit some trailing code around the scope goal.
+ InnerCodeModel = model_non,
+ OuterCodeModel \= model_non,
+ Result0 \= will_not_modify_trail
+ ->
+ Result = may_modify_trail
+ ;
+ Result = Result0
+ ).
+check_goal_for_trail_mods_2(_, _, _, Goal, _, Result) :-
+ Goal = foreign_proc(Attributes, _, _, _, _, _),
+ %
+ % XXX polymorphic foreign calls.
+ ( may_modify_trail(Attributes) = may_modify_trail ->
+ Result = may_modify_trail
+ ;
+ Result = will_not_modify_trail
+ ).
+check_goal_for_trail_mods_2(_, _, _, shorthand(_), _, _) :-
+ unexpected(this_file,
+ "shorthand goal encountered during trailing analysis.").
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, Goal, _, Result) :-
+ Goal = switch(_, _, Cases),
+ CaseGoals = list.map((func(case(_, CaseGoal)) = CaseGoal), Cases),
+ check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, CaseGoals, Result).
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, Goal, _, Result) :-
+ Goal = if_then_else(_, If, Then, Else),
+ check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, [If, Then, Else],
+ Result0),
+ (
+ % If none of the disjuncts can modify the trail then we don't need
+ % to emit trailing code around this disjunction.
+ Result0 = will_not_modify_trail,
+ Result = will_not_modify_trail
+ ;
+ % XXX In the case where this is conditional we could do better
+ % by creating specialised versions of the procedure.
+ ( Result0 = conditional ; Result0 = may_modify_trail),
+ Result = may_modify_trail
+ ).
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, conj(Goals), _,
+ Result) :-
+ check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, Goals, Result).
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, par_conj(Goals), _,
+ Result) :-
+ check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, Goals, Result).
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, disj(Goals), _,
+ Result) :-
+ check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, Goals, Result0),
+ (
+ % If none of the disjuncts can modify the trail then we don't need
+ % to emit trailing code around this disjunction.
+ Result0 = will_not_modify_trail,
+ Result = will_not_modify_trail
+ ;
+ % One or or more fo the disjuncts may modify the trail, so
+ % we need to emit the trailing code - XXX could do better by
+ % specialising conditional code.
+ ( Result0 = conditional ; Result0 = may_modify_trail),
+ Result = may_modify_trail
+ ).
+
+:- pred check_goals_for_trail_mods(scc::in, module_info::in, vartypes::in,
+ hlds_goals::in, trailing_status::out) is det.
+
+check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, Goals, Result) :-
+ list.map(check_goal_for_trail_mods(SCC, ModuleInfo, VarTypes), Goals,
+ Results),
+ list.foldl(combine_trailing_status, Results, will_not_modify_trail,
+ Result).
+
+%----------------------------------------------------------------------------%
+%
+% Further code to handle higher-order variables
+%
+ % Extract those procedures whose trailing_status has been set to
+ % `conditional'. Fails if one of the procedures in the set
+ % is known to modify the trail or if the trailing status is not
+ % yet been set for one or more of the procedures.
+ %
+ % XXX The latter case probably shouldn't happen but may at the
+ % moment because the construction of the dependency graph doesn't
+ % take higher-order calls into account.
+ %
+:- pred get_conditional_closures(module_info::in, set(pred_proc_id)::in,
+ list(pred_proc_id)::out) is semidet.
+
+get_conditional_closures(ModuleInfo, Closures, Conditionals) :-
+ module_info_get_trailing_info(ModuleInfo, TrailingInfo),
+ set.fold(get_conditional_closure(TrailingInfo), Closures,
+ [], Conditionals).
+
+:- pred get_conditional_closure(trailing_info::in, pred_proc_id::in,
+ list(pred_proc_id)::in, list(pred_proc_id)::out) is semidet.
+
+get_conditional_closure(TrailingInfo, PPId, !Conditionals) :-
+ TrailingInfo ^ elem(PPId) = Status,
+ (
+ Status = conditional,
+ list.cons(PPId, !Conditionals)
+ ;
+ Status = will_not_modify_trail
+ ).
+
+%----------------------------------------------------------------------------%
+
+:- pred combine_trailing_status(trailing_status::in, trailing_status::in,
+ trailing_status::out) is det.
+
+combine_trailing_status(will_not_modify_trail, Y, Y).
+combine_trailing_status(may_modify_trail, _, may_modify_trail).
+combine_trailing_status(conditional, will_not_modify_trail, conditional).
+combine_trailing_status(conditional, conditional, conditional).
+combine_trailing_status(conditional, may_modify_trail, may_modify_trail).
+
+%----------------------------------------------------------------------------%
+%
+% Extra procedures for handling calls
+%
+
+:- pred check_nonrecursive_call(module_info::in, vartypes::in,
+ pred_proc_id::in, prog_vars::in, trailing_status::out) is det.
+
+check_nonrecursive_call(ModuleInfo, VarTypes, PPId, Args, Result) :-
+ module_info_get_trailing_info(ModuleInfo, TrailingInfo),
+ ( map.search(TrailingInfo, PPId, CalleeTrailingStatus) ->
+ (
+ CalleeTrailingStatus = will_not_modify_trail,
+ Result = will_not_modify_trail
+ ;
+ CalleeTrailingStatus = may_modify_trail,
+ Result = may_modify_trail
+ ;
+ CalleeTrailingStatus = conditional,
+ %
+ % This is a call to a polymorphic procedure. We need to make
+ % sure that none of the types involved has a user-defined
+ % equality or comparison predicate that modifies the trail.
+ % XXX Need to handle higher-order args here as well.
+ Result = check_vars(ModuleInfo, VarTypes, Args)
+ )
+ ;
+ % If we do not have any information about the callee procedure then
+ % assume that it modifies the trail.
+ Result = may_modify_trail
+ ).
+
+:- func check_vars(module_info, vartypes, prog_vars) = trailing_status.
+
+check_vars(ModuleInfo, VarTypes, Vars) = Result :-
+ Types = list.map((func(Var) = VarTypes ^ det_elem(Var)), Vars),
+ Result = check_types(ModuleInfo, Types).
+
+%----------------------------------------------------------------------------%
+%
+% Stuff for processing types
+%
+
+% This is used in the analysis of calls to polymorphic procedures.
+%
+% By saying a `type may modify the trail' we mean that tail modification
+% may occur as a result of a unification or comparison involving the type
+% because it has a user-defined equality/comparison predicate that modifies
+% the trail.
+%
+% XXX We don't actually need to examine all the types, just those
+% that are potentially going to be involved in unification/comparisons.
+% (The exception and termination analyses have the same problem.)
+%
+% At the moment we don't keep track of that information so the current
+% procedure is as follows:
+%
+% Examine the functor and then recursively examine the arguments.
+% * If everything will not will_not_modify_trail then the type will not
+% modify the trail.
+%
+% * If at least one of the types may modify the trail then the type will
+% will modify the trail.
+%
+% * If at least one of the types is conditional and none of them throw then
+% the type is conditional.
+
+ % Return the collective trailing status of a list of types.
+ %
+:- func check_types(module_info, list(mer_type)) = trailing_status.
+
+check_types(ModuleInfo, Types) = Status :-
+ list.foldl(check_type(ModuleInfo), Types, will_not_modify_trail, Status).
+
+:- pred check_type(module_info::in, mer_type::in, trailing_status::in,
+ trailing_status::out) is det.
+
+check_type(ModuleInfo, Type, !Status) :-
+ combine_trailing_status(check_type(ModuleInfo, Type), !Status).
+
+ % Return the trailing status of an individual type.
+ %
+:- func check_type(module_info, mer_type) = trailing_status.
+
+check_type(ModuleInfo, Type) = Status :-
+ (
+ ( is_solver_type(ModuleInfo, Type)
+ ; is_existq_type(ModuleInfo, Type))
+ ->
+ % XXX At the moment we just assume that existential
+ % types and solver types may modify the trail.
+ Status = may_modify_trail
+ ;
+ TypeCategory = classify_type(ModuleInfo, Type),
+ Status = check_type_2(ModuleInfo, Type, TypeCategory)
+ ).
+
+:- func check_type_2(module_info, mer_type, type_category) = trailing_status.
+
+check_type_2(_, _, type_cat_int) = will_not_modify_trail.
+check_type_2(_, _, type_cat_char) = will_not_modify_trail.
+check_type_2(_, _, type_cat_string) = will_not_modify_trail.
+check_type_2(_, _, type_cat_float) = will_not_modify_trail.
+check_type_2(_, _, type_cat_higher_order) = will_not_modify_trail.
+check_type_2(_, _, type_cat_type_info) = will_not_modify_trail.
+check_type_2(_, _, type_cat_type_ctor_info) = will_not_modify_trail.
+check_type_2(_, _, type_cat_typeclass_info) = will_not_modify_trail.
+check_type_2(_, _, type_cat_base_typeclass_info) = will_not_modify_trail.
+check_type_2(_, _, type_cat_void) = will_not_modify_trail.
+check_type_2(_, _, type_cat_dummy) = will_not_modify_trail.
+
+check_type_2(_, _, type_cat_variable) = conditional.
+
+check_type_2(ModuleInfo, Type, type_cat_tuple) =
+ check_user_type(ModuleInfo, Type).
+check_type_2(ModuleInfo, Type, type_cat_enum) =
+ check_user_type(ModuleInfo, Type).
+check_type_2(ModuleInfo, Type, type_cat_user_ctor) =
+ check_user_type(ModuleInfo, Type).
+
+:- func check_user_type(module_info, mer_type) = trailing_status.
+
+check_user_type(ModuleInfo, Type) = Status :-
+ ( type_to_ctor_and_args(Type, _TypeCtor, Args) ->
+ (
+ type_has_user_defined_equality_pred(ModuleInfo, Type,
+ _UnifyCompare)
+ ->
+ % XXX We can do better than this by examining
+ % what these preds actually do. Something
+ % similar needs to be sorted out for termination
+ % analysis as well, so we'll wait until that is
+ % done.
+ Status = may_modify_trail
+ ;
+ Status = check_types(ModuleInfo, Args)
+ )
+ ;
+ unexpected(this_file, "Unable to get ctor and args.")
+ ).
+
+%----------------------------------------------------------------------------%
+%
+% Stuff for intermodule optimization
+%
+
+:- pred trailing_analysis.make_opt_int(module_info::in, io::di, io::uo)
+ is det.
+
+trailing_analysis.make_opt_int(ModuleInfo, !IO) :-
+ module_info_get_name(ModuleInfo, ModuleName),
+ module_name_to_file_name(ModuleName, ".opt.tmp", no, OptFileName, !IO),
+ globals.io_lookup_bool_option(verbose, Verbose, !IO),
+ maybe_write_string(Verbose, "% Appending trailing_info pragmas to `", !IO),
+ maybe_write_string(Verbose, OptFileName, !IO),
+ maybe_write_string(Verbose, "'...", !IO),
+ maybe_flush_output(Verbose, !IO),
+ io.open_append(OptFileName, OptFileRes, !IO),
+ (
+ OptFileRes = ok(OptFile),
+ io.set_output_stream(OptFile, OldStream, !IO),
+ module_info_get_trailing_info(ModuleInfo, TrailingInfo),
+ module_info_predids(ModuleInfo, PredIds),
+ list.foldl(write_pragma_trailing_info(ModuleInfo, TrailingInfo),
+ PredIds, !IO),
+ io.set_output_stream(OldStream, _, !IO),
+ io.close_output(OptFile, !IO),
+ maybe_write_string(Verbose, " done.\n", !IO)
+ ;
+ OptFileRes = error(IOError),
+ maybe_write_string(Verbose, " failed!\n", !IO),
+ io.error_message(IOError, IOErrorMessage),
+ io.write_strings(["Error opening file `",
+ OptFileName, "' for output: ", IOErrorMessage], !IO),
+ io.set_exit_status(1, !IO)
+ ).
+
+write_pragma_trailing_info(ModuleInfo, TrailingInfo, PredId, !IO) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_import_status(PredInfo, ImportStatus),
+ (
+ ( ImportStatus = exported
+ ; ImportStatus = opt_exported
+ ),
+ not is_unify_or_compare_pred(PredInfo),
+ module_info_get_type_spec_info(ModuleInfo, TypeSpecInfo),
+ TypeSpecInfo = type_spec_info(_, TypeSpecForcePreds, _, _),
+ not set.member(PredId, TypeSpecForcePreds),
+ %
+ % XXX Writing out pragmas for the automatically generated class
+ % instance methods causes the compiler to abort when it reads them
+ % back in.
+ %
+ pred_info_get_markers(PredInfo, Markers),
+ not check_marker(Markers, class_instance_method),
+ not check_marker(Markers, named_class_instance_method)
+ ->
+ ModuleName = pred_info_module(PredInfo),
+ Name = pred_info_name(PredInfo),
+ Arity = pred_info_orig_arity(PredInfo),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+ ProcIds = pred_info_procids(PredInfo),
+ list.foldl((pred(ProcId::in, !.IO::di, !:IO::uo) is det :-
+ proc_id_to_int(ProcId, ModeNum),
+ (
+ map.search(TrailingInfo, proc(PredId, ProcId), Status)
+ ->
+ mercury_output_pragma_trailing_info(PredOrFunc,
+ qualified(ModuleName, Name), Arity,
+ ModeNum, Status, !IO)
+ ;
+ true
+ )), ProcIds, !IO)
+ ;
+ true
+ ).
+
+%----------------------------------------------------------------------------%
+%
+% Code for printing out debugging traces
+%
+
+:- pred dump_trail_usage_debug_info(module_info::in, scc::in,
+ trailing_status::in, io::di, io::uo) is det.
+
+dump_trail_usage_debug_info(ModuleInfo, SCC, Status, !IO) :-
+ io.write_string("SCC: ", !IO),
+ io.write(Status, !IO),
+ io.nl(!IO),
+ output_proc_names(ModuleInfo, SCC, !IO),
+ io.nl(!IO).
+
+:- pred output_proc_names(module_info::in, scc::in, io::di, io::uo) is det.
+
+output_proc_names(ModuleInfo, SCC, !IO) :-
+ list.foldl(output_proc_name(ModuleInfo), SCC, !IO).
+
+:- pred output_proc_name(module_info::in, pred_proc_id::in,
+ io::di, io::uo) is det.
+output_proc_name(Moduleinfo, PPId, !IO) :-
+ Pieces = describe_one_proc_name(Moduleinfo, should_module_qualify, PPId),
+ Str = error_pieces_to_string(Pieces),
+ io.format("\t%s\n", [s(Str)], !IO).
+
+%----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "trailing_analysis.m".
+
+%----------------------------------------------------------------------------%
+:- end_module trailing_analysis.
+%----------------------------------------------------------------------------%
Index: compiler/trans_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/trans_opt.m,v
retrieving revision 1.32
diff -u -r1.32 trans_opt.m
--- compiler/trans_opt.m 28 Oct 2005 02:10:40 -0000 1.32
+++ compiler/trans_opt.m 3 Nov 2005 02:50:23 -0000
@@ -34,13 +34,15 @@
% The .trans_opt file includes:
% :- pragma termination_info declarations for all exported preds
% :- pragma exceptions declartions for all exported preds
+% :- pragma trailing_info declarations for all exported preds.
+%
% All these items should be module qualified.
% Constructors should be explicitly type qualified.
%
% Note that the .trans_opt file does not (yet) include clauses, `pragma
% foreign_proc' declarations, or any of the other information that would be
% needed for inlining or other optimizations; currently it is only used
-% for termination analysis and exception analysis.
+% for termination analysis, exception and trail usage analysis.
%
% This module also contains predicates to read in the .trans_opt files.
%
@@ -87,10 +89,11 @@
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_out.
+:- import_module transform_hlds.exception_analysis.
:- import_module transform_hlds.intermod.
:- import_module transform_hlds.term_constr_main.
:- import_module transform_hlds.termination.
-:- import_module transform_hlds.exception_analysis.
+:- import_module transform_hlds.trailing_analysis.
:- import_module list.
:- import_module map.
@@ -143,6 +146,11 @@
exception_analysis__write_pragma_exceptions(Module, ExceptionInfo),
PredIds, !IO),
+ module_info_get_trailing_info(Module, TrailingInfo),
+ list__foldl(
+ write_pragma_trailing_info(Module, TrailingInfo),
+ PredIds, !IO),
+
io__set_output_stream(OldStream, _, !IO),
io__close_output(Stream, !IO),
Index: compiler/transform_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/transform_hlds.m,v
retrieving revision 1.19
diff -u -r1.19 transform_hlds.m
--- compiler/transform_hlds.m 17 Jun 2005 10:13:54 -0000 1.19
+++ compiler/transform_hlds.m 3 Nov 2005 02:50:23 -0000
@@ -55,6 +55,7 @@
:- include_module post_term_analysis.
:- include_module exception_analysis.
+:- include_module trailing_analysis.
% Optimizations (HLDS -> HLDS)
:- include_module higher_order.
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list