[m-rev.] diff: trail usage analysis
Julien Fischer
juliensf at cs.mu.OZ.AU
Mon Oct 24 18:31:43 AEST 2005
I don't intend to commit this at the moment (review comments are still welcome
though). I'm posting it because Zoltan was interested in trying a similar
idea to try and reduce the overhead of minimal model tabling.
(This diff is also available at /home/mercury/juliensf/tmp/TrailUsagePatch.1).
Some preliminary results with the trail usage analysis:
library:
will_not_modify_trail : 409 (10.8%)
conditional : 625 (16.6%)
may_modify_trail : 2740 (72.6%)
---------------------
Total procedures : 3774
compiler:
will_not_modify_trail : 1740 (38.2%)
conditional : 35 (0.8%)
may_modify_trail : 2779 (61.0%)
--------------------
Total procedures : 4556
The above figures were obtained by grepping the .trans_opt files, so it's
not all of the procedures in a program, just those that happen to be
opt_exported.
I would expected the percentages of `will_not_modify_trail' and `conditional'
procedures to increase for the standard library since (a) the foreign_procs
haven't yet been annotated with any trail usage information and (b) all of
the procedure that have higher-order arguments are currently marked as
`may_modify_trail'. For the compiler it's unlikely the number of
`conditional' procedures will rise, since there aren't that many
polymorphic procedures to begin with.
My initial attempt to use this information in a trailing grade didn't use
intermodule-optimization and essentially made no difference (the
mercury_compile executable was fractionally smaller.) I've since fixed
a bug with the trailing_info pragmas so I'll rerun the experiment with
intermodule-optimization enabled and see if that makes a difference.
Estimated hours taken: 20
Branches: main
Add the initial support for trail usage analysis. The idea is to reduce
the overhead of trailing by working out what parts of a program cannot
modify the trail. The code generators can then omit the calls to the
trailing primitives where they are not needed. (That's the basic
idea, supporting separate compilation makes it a bit more complicated than
that.)
This diff adds the first part, a bottom-up analysis that annotates the HLDS
with information about which procedures do not modify the trail. The analysis
is similar to that carried out by the exception analysis, although the
trail usage analysis doesn't currently handle higher-order calls.
To support this we introduce two new foreign proc attributes,
`may_modify_trail' and `will_not_modify_trail' that can be used to annotate
foreign procs with trail usage information.
This diff doesn't include any of the changes to the code generators. That
will be a separate change if it turns out that this sort of thing is
worthwhile.
TODO:
- modify the code generators
- support analysis of higher-order calls
- improved analysis of polymorphism (see exception_analysis.m)
- document the new options
compiler/trailing_analysis.m:
New module. Implements the trail usage analysis.
compiler/add_pragma.m:
Handle the new trailing_info pragmas.
compiler/goal_form.m:
Add a predicate goal_cannot_modify_trail/2 that tests if a
goal may modify the trail.
compiler/hlds_module.m:
Add a slot to the HLDS that stores the results of the
trail usage analysis.
compiler/mercury_compile.m:
Run the trail usage analysis if `--analyse-trail-usage' is
specified.
compiler/mercury_to_mercury.m:
Output trailing_info pragma in HLDS dumps.
compiler/options.m:
Add the `--analyse-trail-usage' option.
Unrelated change: indent the termination2 options correctly.
compiler/prog_data.m:
Add an item for trailing_info pragmas.
Support will_not_modify_trail/may_modify_trail as foreign
proc attributes.
compiler/modules.m:
Handle trailing_info pragmas.
compiler/prog_io_pragma.m:
Parse trailing_info pragmas.
compiler/trans_opt.m:
Write trailing_info pragmas to `.trans_opt' files.
compiler/transform_hlds.m:
Include the trailing_analysis module.
Julien.
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.14
diff -u -r1.14 add_pragma.m
--- compiler/add_pragma.m 24 Oct 2005 04:13:54 -0000 1.14
+++ compiler/add_pragma.m 24 Oct 2005 04:19:59 -0000
@@ -234,6 +234,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(_, _, _, _, _, _, _, _)
;
@@ -574,6 +585,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/goal_form.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_form.m,v
retrieving revision 1.18
diff -u -r1.18 goal_form.m
--- compiler/goal_form.m 30 Sep 2005 08:08:20 -0000 1.18
+++ compiler/goal_form.m 21 Oct 2005 07:24:18 -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.121
diff -u -r1.121 hlds_module.m
--- compiler/hlds_module.m 24 Oct 2005 04:14:03 -0000 1.121
+++ compiler/hlds_module.m 24 Oct 2005 04:20:01 -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.
@@ -645,9 +657,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.
@@ -714,6 +731,7 @@
set__init(StratPreds),
map__init(UnusedArgInfo),
map__init(ExceptionInfo),
+ map__init(TrailingInfo),
set__init(TypeSpecPreds),
set__init(TypeSpecForcePreds),
@@ -737,7 +755,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),
@@ -811,6 +829,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).
@@ -918,6 +937,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.355
diff -u -r1.355 mercury_compile.m
--- compiler/mercury_compile.m 24 Oct 2005 04:14:11 -0000 1.355
+++ compiler/mercury_compile.m 24 Oct 2005 04:20:02 -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.
@@ -2068,6 +2069,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),
@@ -2081,6 +2084,7 @@
; Termination = yes
; Termination2 = yes
; ExceptionAnalysis = yes
+ ; TrailingAnalysis = yes
)
->
frontend_pass_by_phases(!HLDS, FoundModeError, !DumpInfo, !IO),
@@ -2119,6 +2123,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)
@@ -2183,6 +2193,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,
@@ -2296,6 +2308,10 @@
maybe_termination2(Verbose, Stats, !HLDS, !IO),
maybe_dump_hlds(!.HLDS, 121, "termination2", !DumpInfo, !IO),
+
+ % XXX Maybe this should be done later?
+ 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),
@@ -2928,6 +2944,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.
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.271
diff -u -r1.271 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 24 Oct 2005 04:14:12 -0000 1.271
+++ compiler/mercury_to_mercury.m 24 Oct 2005 04:20:02 -0000
@@ -155,6 +155,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.
@@ -596,6 +599,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)
;
@@ -3279,6 +3287,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.117
diff -u -r1.117 module_qual.m
--- compiler/module_qual.m 24 Oct 2005 04:14:19 -0000 1.117
+++ compiler/module_qual.m 24 Oct 2005 04:20:03 -0000
@@ -1080,6 +1080,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.351
diff -u -r1.351 modules.m
--- compiler/modules.m 24 Oct 2005 04:14:19 -0000 1.351
+++ compiler/modules.m 24 Oct 2005 04:20:04 -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).
@@ -7708,7 +7709,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
@@ -7820,6 +7822,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.470
diff -u -r1.470 options.m
--- compiler/options.m 17 Oct 2005 07:43:24 -0000 1.470
+++ compiler/options.m 21 Oct 2005 06:45:01 -0000
@@ -521,15 +521,16 @@
% 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
; untuple
; tuple
; tuple_trace_counts_file
@@ -1141,7 +1142,8 @@
% 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)
]).
option_defaults_2(optimization_option, [
% Optimization options
@@ -1937,6 +1939,7 @@
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("untuple", untuple).
long_option("tuple", tuple).
long_option("tuple-trace-counts-file", tuple_trace_counts_file).
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.143
diff -u -r1.143 prog_data.m
--- compiler/prog_data.m 24 Oct 2005 04:14:22 -0000 1.143
+++ compiler/prog_data.m 24 Oct 2005 04:43:22 -0000
@@ -457,6 +457,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)
%
@@ -849,6 +859,16 @@
%-----------------------------------------------------------------------------%
%
+% Stuff for the trailing analysis
+%
+
+:- type trailing_status
+ ---> may_modify_trail
+ ; will_not_modify_trail
+ ; conditional.
+
+%-----------------------------------------------------------------------------%
+%
% Stuff for the `type_spec' pragma
%
@@ -1094,6 +1114,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.
@@ -1133,6 +1154,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.
@@ -1162,6 +1187,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
@@ -1976,6 +2005,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)
).
@@ -1983,7 +2013,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.
@@ -2003,6 +2033,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
@@ -2010,7 +2042,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"
@@ -2075,9 +2107,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.91
diff -u -r1.91 prog_io_pragma.m
--- compiler/prog_io_pragma.m 24 Oct 2005 04:14:24 -0000 1.91
+++ compiler/prog_io_pragma.m 24 Oct 2005 04:20:04 -0000
@@ -1216,6 +1216,44 @@
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 +1350,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 +1387,8 @@
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 +1435,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 +1507,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 +1532,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.
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.28
diff -u -r1.28 recompilation.version.m
--- compiler/recompilation.version.m 24 Oct 2005 04:14:26 -0000 1.28
+++ compiler/recompilation.version.m 24 Oct 2005 04:23:42 -0000
@@ -575,7 +575,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 24 Oct 2005 07:12:50 -0000
@@ -0,0 +1,680 @@
+%-----------------------------------------------------------------------------%
+% 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 an experimental 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.
+%
+% 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:
+% - more or less the same stuff on the todo list in exception_analysis.m.
+% XXX
+% - we probably shouldn't just copy what the exception analysis does
+% for existential types - need to look into this a bit more.
+%
+%----------------------------------------------------------------------------%
+
+:- 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.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.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),
+ list.foldl(process_scc, SCCs, !ModuleInfo),
+ globals.io_lookup_bool_option(make_optimization_interface,
+ MakeOptInt, !IO),
+ (
+ MakeOptInt = yes,
+ trailing_analysis.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
+ % Trailing status for the body of this procedure
+ % plus any information about (mutually-)recursive
+ % calls.
+ ).
+
+:- pred process_scc(scc::in, module_info::in, module_info::out) is det.
+
+process_scc(SCC, !ModuleInfo) :-
+ 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),
+ %
+ % 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 analysis of 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),
+ Result0 = proc_result(PPId, will_not_modify_trail),
+ check_goal_for_trail_mods(SCC, ModuleInfo, VarTypes, Body, Result0,
+ Result),
+ list.cons(Result, !Results).
+
+%----------------------------------------------------------------------------%
+%
+% Perform trail analysis of a goal
+%
+
+:- pred check_goal_for_trail_mods(scc::in, module_info::in, vartypes::in,
+ hlds_goal::in, proc_result::in, proc_result::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, proc_result::in, proc_result::out)
+ is det.
+
+check_goal_for_trail_mods_2(_, _, _, Goal, _, !Result) :-
+ 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),
+ combine_trailing_status(TrailingStatus, !.Result ^ status,
+ NewTypeStatus),
+ !:Result = !.Result ^ status := NewTypeStatus
+ ;
+ pred_info_is_builtin(CallPredInfo)
+ ->
+ % XXX Are there any builtins that modify the trail?
+ true
+ ;
+ % 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
+ )
+ )
+ ->
+ % For unification/comparison the trail usage depends upon
+ % the type soft the arguments. In particular whether some
+ % component of the the type has a user-defined equality
+ % or comparison predicate that modifies the trail.
+ check_vars(ModuleInfo, VarTypes, CallArgs, !Result)
+ ;
+ 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, _),
+ (
+ Details = higher_order(Var, _, _, _),
+ ClosureValueMap = goal_info_get_ho_values(GoalInfo),
+ ( ClosureValues = ClosureValueMap ^ elem(Var) ->
+ (
+ get_conditional_closures(ModuleInfo, ClosureValues,
+ Conditional)
+ ->
+ (
+ Conditional = []
+ % The possible values of the higher-order variable
+ % are all procedures that are known not to modify
+ % the trail.
+ ;
+ Conditional = [_|_],
+ %
+ % For 'conditional' procedures we need to make sure
+ % that if any type variables are bound at the
+ % generic_call site, then this does not cause the
+ % closure to modify the trail (because of a
+ % user-defined equality or comparison predicate that
+ % modifies the trail).
+ %
+ % If we can resolve all of the polymorphism at this
+ % generic_call site, then we can reach a definite
+ % conclusion about it.
+ %
+ % If we cannot do so, then we propagate the
+ % 'conditional' status to the current predicate
+ % if all the type variables involved are
+ % universally quantified, or mark it as modifying
+ % the trail if some of them are existentially
+ % quantified.
+ %
+ % XXX This is too conservative but we don't currently
+ % perform a fine-grained enough analysis of where
+ % out-of-line unifications/comparisons may occur to be
+ % able to do better.
+ %
+ check_vars(ModuleInfo, VarTypes, Args, !Result)
+ )
+ ;
+ !:Result = !.Result ^ status := may_modify_trail
+ )
+ ;
+ !:Result = !.Result ^ status := may_modify_trail
+ )
+ ;
+ % XXX We could do better with class methods.
+ Details = class_method(_, _, _, _),
+ !:Result = !.Result ^ status := may_modify_trail
+ ;
+ Details = cast(_)
+ ;
+ % XXX I'm not sure what the correct thing to do for
+ % aditi builtins is.
+ Details = aditi_builtin(_, _),
+ !:Result = !.Result ^ status := 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, _,
+ !Result) :-
+ Goal = scope(_, ScopeGoal),
+ check_goal_for_trail_mods(SCC, ModuleInfo, VarTypes, ScopeGoal, !Result).
+check_goal_for_trail_mods_2(_, _, _, Goal, _, !Result) :-
+ Goal = foreign_proc(Attributes, _, _, _, _, _),
+ ( may_modify_trail(Attributes) = may_modify_trail ->
+ !:Result = !.Result ^ status := may_modify_trail
+ ;
+ true
+ ).
+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],
+ !Result).
+check_goal_for_trail_mods_2(SCC, ModuleInfo, VarTypes, disj(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, conj(Goals), _,
+ !Result) :-
+ check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, Goals, !Result).
+
+:- pred check_goals_for_trail_mods(scc::in, module_info::in, vartypes::in,
+ hlds_goals::in, proc_result::in, proc_result::out) is det.
+
+check_goals_for_trail_mods(_, _, _, [], !Result).
+check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, [ Goal | Goals ],
+ !Result) :-
+ check_goal_for_trail_mods(SCC, ModuleInfo, VarTypes, Goal, !Result),
+ %
+ % We can stop search once we have found a goal that does modify the trail.
+ %
+ ( if !.Result ^ status = may_modify_trail
+ then true
+ else check_goals_for_trail_mods(SCC, ModuleInfo, VarTypes, Goals,
+ !Result)
+ ).
+
+%----------------------------------------------------------------------------%
+%
+% Further code to handle higher-order variables
+%
+
+ % Extract those procedures whose trailing_stauts 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 update_proc_result(trailing_status::in, proc_result::in,
+ proc_result::out) is det.
+
+update_proc_result(CurrentStatus, !Result) :-
+ OldStatus = !.Result ^ status,
+ combine_trailing_status(CurrentStatus, OldStatus, NewStatus),
+ !:Result = !.Result ^ status := NewStatus.
+
+:- 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, proc_result::in,
+ proc_result::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
+ ;
+ CalleeTrailingStatus = may_modify_trail,
+ update_proc_result(may_modify_trail, !Result)
+ ;
+ CalleeTrailingStatus = conditional,
+ %
+ % This is a call to a polymorphic procedure. We need to make sure
+ % that none of the types involved could have a user-defined
+ % equality or comparison predicate that modifies the trail.
+ %
+ check_vars(ModuleInfo, VarTypes, Args, !Result)
+ )
+ ;
+ % If we do not have any information about the callee procedure then
+ % assume that it modifies the trail.
+ update_proc_result(may_modify_trail, !Result)
+ ).
+
+:- pred check_vars(module_info::in, vartypes::in, prog_vars::in,
+ proc_result::in, proc_result::out) is det.
+
+check_vars(ModuleInfo, VarTypes, Vars, !Result) :-
+ Types = list.map((func(Var) = VarTypes ^ det_elem(Var)), Vars),
+ TypeStatus = check_types(ModuleInfo, Types),
+ (
+ TypeStatus = will_not_modify_trail
+ ;
+ TypeStatus = may_modify_trail,
+ update_proc_result(may_modify_trail, !Result)
+ ;
+ TypeStatus = conditional,
+ update_proc_result(conditional, !Result)
+ ).
+
+%----------------------------------------------------------------------------%
+%
+% 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(_, _, int_type) = will_not_modify_trail.
+check_type_2(_, _, char_type) = will_not_modify_trail.
+check_type_2(_, _, str_type) = will_not_modify_trail.
+check_type_2(_, _, float_type) = will_not_modify_trail.
+check_type_2(_, _, higher_order_type) = will_not_modify_trail.
+check_type_2(_, _, type_info_type) = will_not_modify_trail.
+check_type_2(_, _, type_ctor_info_type) = will_not_modify_trail.
+check_type_2(_, _, typeclass_info_type) = will_not_modify_trail.
+check_type_2(_, _, base_typeclass_info_type) = will_not_modify_trail.
+check_type_2(_, _, void_type) = will_not_modify_trail.
+check_type_2(_, _, dummy_type) = will_not_modify_trail.
+
+check_type_2(_, _, variable_type) = conditional.
+
+check_type_2(ModuleInfo, Type, tuple_type) = check_user_type(ModuleInfo, Type).
+check_type_2(ModuleInfo, Type, enum_type) = check_user_type(ModuleInfo, Type).
+check_type_2(ModuleInfo, Type, user_ctor_type) =
+ 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
+ ).
+
+%----------------------------------------------------------------------------%
+
+:- 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.31
diff -u -r1.31 trans_opt.m
--- compiler/trans_opt.m 19 Oct 2005 05:39:04 -0000 1.31
+++ compiler/trans_opt.m 24 Oct 2005 03:44:50 -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.
%
@@ -91,6 +93,7 @@
:- 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 6 Oct 2005 05:17:26 -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