[m-rev.] for review: Add new require_tail_recursion pragma.
Paul Bone
paul at bone.id.au
Mon Dec 7 16:36:10 AEDT 2015
For review by Zoltan
This is the combination of my previous two patches, revised based on
feedback to the previous patch.
----
Add new require_tail_recursion pragma.
This patch allows the pragma to be parsed, and records the information from
the pragma in the proc_info structure for the relevant procedures.
The patch uses the pragma for the MLDS backend. However because mutual
recursion is not yet supported on the MLDS backend, mutually recursive calls
are ignored by the pragma.
The patch also documents the pragma in the reference manual, this
documentation is commented out until it is implemented for both LLDS and
MLDS backends.
The patch does not implement the SCC feature discussed on the mailing list.
That can be added later.
compiler/prog_data.m:
compiler/prog_item.m:
Add new require_tail_recursion pragma.
compiler/prog_io_pragma.m:
Parse the new pragma.
Remove the arity_and_modes type and use pred_name_arity_mpf_mmode
type from prog_item.m
compiler/parse_tree_out_pragma.m:
Support pretty printing the new pragma.
compiler/hlds_pred.m:
Add require_tailrec_info to the proc_info structure.
compiler/add_pragma.m:
Add information from the pragma to the proc_info structure after
parsing.
compiler/compiler_util.m:
Add a general warning_or_error type.
compiler/mlds.m:
Add require_tailrec_info to MLDS functions.
compiler/ml_proc_gen.m:
Copy the require_tailrec_info information from the HLDS to the MLDS.
compiler/ml_tailcall.m:
Generate errors and warnings with respect to the require_tail_recursion
pragma.
compiler/mercury_compile.m:
compiler/mercury_compile_mlds_back_end.m:
Return errors from the MLDS tailcall optimisation pass.
compiler/add_pragma.m:
compiler/comp_unit_interface.m:
compiler/equiv_type.m:
compiler/get_dependencies.m:
compiler/item_util.m:
compiler/make_hlds_separate_items.m:
compiler/module_qual.qual_errors.m:
compiler/module_qual.qualify_items.m:
compiler/prog_item_stats.m:
compiler/recompilation.version.m:
compiler/write_module_interface_files.m:
Conform to changes in prog_item.m.
compiler/ml_code_util.m:
compiler/ml_elim_nested.m:
compiler/ml_optimize.m:
compiler/ml_type_gen.m:
compiler/ml_util.m:
compiler/mlds_to_c.m:
compiler/mlds_to_cs.m:
compiler/mlds_to_java.m:
Conform to changes in mlds.m.
doc/reference_manual.texi
Document the require_tail_recursion pragma
tests/invalid/Mercury.options:
tests/invalid/Mmakefile:
tests/invalid/require_tail_recursion.err_exp:
tests/invalid/require_tail_recursion.m:
Add require_tail_recursion test case
---
compiler/add_pragma.m | 108 +++++++++++
compiler/comp_unit_interface.m | 1 +
compiler/compiler_util.m | 29 +++
compiler/equiv_type.m | 1 +
compiler/get_dependencies.m | 1 +
compiler/hlds_pred.m | 17 ++
compiler/item_util.m | 1 +
compiler/make_hlds_separate_items.m | 1 +
compiler/mercury_compile.m | 21 ++-
compiler/mercury_compile_mlds_back_end.m | 14 +-
compiler/ml_code_util.m | 4 +-
compiler/ml_elim_nested.m | 22 ++-
compiler/ml_optimize.m | 10 +-
compiler/ml_proc_gen.m | 4 +-
compiler/ml_tailcall.m | 233 ++++++++++++++++--------
compiler/ml_type_gen.m | 4 +-
compiler/ml_util.m | 6 +-
compiler/mlds.m | 18 +-
compiler/mlds_to_c.m | 14 +-
compiler/mlds_to_cs.m | 36 ++--
compiler/mlds_to_java.m | 44 ++---
compiler/module_qual.qual_errors.m | 3 +
compiler/module_qual.qualify_items.m | 1 +
compiler/parse_tree_out_pragma.m | 67 +++++++
compiler/prog_data.m | 31 ++++
compiler/prog_io_pragma.m | 260 +++++++++++++++++++++++++--
compiler/prog_item.m | 30 ++++
compiler/prog_item_stats.m | 1 +
compiler/recompilation.version.m | 1 +
compiler/write_module_interface_files.m | 1 +
doc/reference_manual.texi | 100 +++++++++++
tests/invalid/Mercury.options | 3 +
tests/invalid/Mmakefile | 1 +
tests/invalid/require_tail_recursion.err_exp | 86 +++++++++
tests/invalid/require_tail_recursion.m | 90 ++++++++++
35 files changed, 1086 insertions(+), 178 deletions(-)
create mode 100644 tests/invalid/require_tail_recursion.err_exp
create mode 100644 tests/invalid/require_tail_recursion.m
diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m
index ecc5cca..7eaa560 100644
--- a/compiler/add_pragma.m
+++ b/compiler/add_pragma.m
@@ -35,6 +35,7 @@
; pragma_mm_tabling_info(ground)
; pragma_obsolete(ground)
; pragma_no_detism_warning(ground)
+ ; pragma_require_tail_recursion(ground)
; pragma_promise_eqv_clauses(ground)
; pragma_promise_pure(ground)
; pragma_promise_semipure(ground)
@@ -112,6 +113,7 @@
:- import_module int.
:- import_module io.
:- import_module map.
+:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module varset.
@@ -312,6 +314,10 @@ add_pass_2_pragma(SectionItem, !ModuleInfo, !Specs) :-
add_pred_marker("no_determinism_warning", Name, Arity, PredStatus,
Context, marker_no_detism_warning, [], !ModuleInfo, !Specs)
;
+ Pragma = pragma_require_tail_recursion(TailrecWarningPragma),
+ add_pragma_require_tail_recursion(TailrecWarningPragma, Context,
+ !ModuleInfo, !Specs)
+ ;
Pragma = pragma_promise_eqv_clauses(PredNameArity),
PredNameArity = pred_name_arity(Name, Arity),
item_mercury_status_to_pred_status(ItemMercuryStatus, PredStatus),
@@ -536,6 +542,108 @@ add_pragma_mm_tabling_info(MMTablingInfo, _Context, !ModuleInfo, !Specs) :-
%-----------------------------------------------------------------------------%
+:- pred add_pragma_require_tail_recursion(
+ pragma_info_require_tail_recursion::in, prog_context::in,
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+add_pragma_require_tail_recursion(Pragma, Context, !ModuleInfo, !Specs) :-
+ Pragma ^ rtr_proc_id =
+ pred_name_arity_mpf_mmode(Name, Arity, _MaybePF, MaybeMode),
+ get_matching_pred_ids(!.ModuleInfo, Name, Arity, PredIds),
+ (
+ PredIds = [],
+ Pieces = [pragma_decl("require_tail_recursion"), words("pragma")],
+ undefined_pred_or_func_error(Name, Arity, Context, Pieces, !Specs)
+ ;
+ PredIds = [PredId],
+ NameAndArity = Name / Arity,
+
+ module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
+ pred_info_get_proc_table(PredInfo0, Procs0),
+ map.to_assoc_list(Procs0, Procs),
+ (
+ MaybeMode = yes(Mode),
+ % Choose the matching proc.
+ ( if
+ % We have to take inst variables into account (two free
+ % variables need to be unified, not just compared) when
+ % searching for the matching procedure.
+ %
+ % I looked up how to do this and found an example in
+ % add_pragma_foreign_proc/8 in add_foreign_proc.m:342 It
+ % also contained thsi comment which may be relevant:
+ %
+ % XXX We should probably also check that each pair in the
+ % renaming has the same name. See the comment in
+ % add_foreign_proc.
+ %
+ get_procedure_matching_declmodes_with_renaming(Procs,
+ Mode, !.ModuleInfo, ProcId)
+ then
+ map.lookup(Procs0, ProcId, Proc),
+ add_pragma_require_tail_recursion_proc(
+ Pragma ^ rtr_require_tailrec, Context,
+ NameAndArity, ProcId - Proc, PredInfo0, PredInfo, !Specs)
+ else
+ Pieces = [words("Error: no such mode for"),
+ sym_name_and_arity(NameAndArity), words("in"),
+ pragma_decl("require_tail_recursion"),
+ words("pragma.")],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ PredInfo = PredInfo0,
+ !:Specs = [Spec | !.Specs]
+ )
+ ;
+ MaybeMode = no,
+ list.foldl2(add_pragma_require_tail_recursion_proc(
+ Pragma ^ rtr_require_tailrec, Context, NameAndArity),
+ Procs, PredInfo0, PredInfo, !Specs)
+ ),
+ module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
+ ;
+ PredIds = [_, _ | _],
+ Pieces = [words("Error: ambiguous predicate or function in"),
+ pragma_decl("require_tail_recursion"), words("pragma.")],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
+ ).
+
+:- pred add_pragma_require_tail_recursion_proc(
+ require_tail_recursion::in, prog_context::in,
+ sym_name_and_arity::in, pair(proc_id, proc_info)::in,
+ pred_info::in, pred_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+add_pragma_require_tail_recursion_proc(RequireTailrec, Context,
+ SymNameAndArity, ProcId - ProcInfo0, !PredInfo, !Specs) :-
+ proc_info_get_maybe_require_tailrec_info(ProcInfo0,
+ MaybeRequireTailrecOrig),
+ (
+ MaybeRequireTailrecOrig = yes(RequireTailrecOrig),
+ Parts1 = [words("Error: conflicting"),
+ pragma_decl("require_tail_recursion"), words("pragmas for"),
+ sym_name_and_arity(SymNameAndArity),
+ words("or one of its modes.")],
+ Parts2 = [words("Earlier pragma is here.")],
+ ( RequireTailrecOrig = suppress_tailrec_warnings(ContextOrig)
+ ; RequireTailrecOrig = enable_tailrec_warnings(_, _, ContextOrig)
+ ),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [simple_msg(Context, [always(Parts1)]),
+ simple_msg(ContextOrig, [always(Parts2)])]),
+ !:Specs = [Spec | !.Specs]
+ ;
+ MaybeRequireTailrecOrig = no,
+ proc_info_set_require_tailrec_info(RequireTailrec, ProcInfo0, ProcInfo),
+ pred_info_set_proc_info(ProcId, ProcInfo, !PredInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
% add_pred_marker(PragmaName, Name, Arity, Status,
% Context, Marker, ConflictMarkers, !ModuleInfo, !Specs):
%
diff --git a/compiler/comp_unit_interface.m b/compiler/comp_unit_interface.m
index 1d81594..763428c 100644
--- a/compiler/comp_unit_interface.m
+++ b/compiler/comp_unit_interface.m
@@ -302,6 +302,7 @@ include_in_int_file_implementation(Item) = MaybeIFileItem :-
; Pragma = pragma_mm_tabling_info(_)
; Pragma = pragma_obsolete(_)
; Pragma = pragma_no_detism_warning(_)
+ ; Pragma = pragma_require_tail_recursion(_)
; Pragma = pragma_oisu(_)
; Pragma = pragma_tabled(_)
; Pragma = pragma_fact_table(_)
diff --git a/compiler/compiler_util.m b/compiler/compiler_util.m
index 2c8758d..731a86b 100644
--- a/compiler/compiler_util.m
+++ b/compiler/compiler_util.m
@@ -22,6 +22,27 @@
:- import_module io.
:- import_module list.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%
+
+ % This type is useful when defining options and behaviours that may
+ % raise either an error or a warning. See
+ % pragma_require_tail_recursion.
+ %
+:- type warning_or_error
+ ---> we_warning
+ ; we_error.
+
+ % warning_or_error_string(we_warning, "warn").
+ % warning_or_error_string(we_error, "error").
+ %
+:- pred warning_or_error_string(warning_or_error, string).
+:- mode warning_or_error_string(in, out) is det.
+:- mode warning_or_error_string(out, in) is semidet.
+
+:- pred warning_or_error_severity(warning_or_error::in, error_severity::out)
+ is det.
%-----------------------------------------------------------------------------%
@@ -61,6 +82,14 @@
%-----------------------------------------------------------------------------%
+warning_or_error_string(we_warning, "warn").
+warning_or_error_string(we_error, "error").
+
+warning_or_error_severity(we_warning, severity_warning).
+warning_or_error_severity(we_error, severity_error).
+
+%-----------------------------------------------------------------------------%
+
add_error(Phase, Pieces, !Specs) :-
Msg = error_msg(no, do_not_treat_as_first, 0, [always(Pieces)]),
Spec = error_spec(severity_error, Phase, [Msg]),
diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m
index 7e0353d..24a7ad6 100644
--- a/compiler/equiv_type.m
+++ b/compiler/equiv_type.m
@@ -681,6 +681,7 @@ replace_in_pragma_info(ModuleName, MaybeRecord, TypeEqvMap, _InstEqvMap,
; Pragma0 = pragma_termination_info(_)
; Pragma0 = pragma_trailing_info(_)
; Pragma0 = pragma_unused_args(_)
+ ; Pragma0 = pragma_require_tail_recursion(_)
),
Pragma = Pragma0
),
diff --git a/compiler/get_dependencies.m b/compiler/get_dependencies.m
index f3bc96d..9cb4506 100644
--- a/compiler/get_dependencies.m
+++ b/compiler/get_dependencies.m
@@ -463,6 +463,7 @@ gather_implicit_import_needs_in_items([Item | Items], !ImplicitImportNeeds) :-
; Pragma = pragma_structure_sharing(_)
; Pragma = pragma_structure_reuse(_)
; Pragma = pragma_require_feature_set(_)
+ ; Pragma = pragma_require_tail_recursion(_)
)
)
;
diff --git a/compiler/hlds_pred.m b/compiler/hlds_pred.m
index fd1d645..2fe6d16 100644
--- a/compiler/hlds_pred.m
+++ b/compiler/hlds_pred.m
@@ -2197,6 +2197,8 @@ attribute_list_to_attributes(Attributes, AttributeSet) :-
has_tail_call_event::out) is det.
:- pred proc_info_get_oisu_kind_fors(proc_info::in,
list(oisu_pred_kind_for)::out) is det.
+:- pred proc_info_get_maybe_require_tailrec_info(proc_info::in,
+ maybe(require_tail_recursion)::out) is det.
:- pred proc_info_get_reg_r_headvars(proc_info::in,
set_of_progvar::out) is det.
:- pred proc_info_get_maybe_arg_info(proc_info::in,
@@ -2281,6 +2283,8 @@ attribute_list_to_attributes(Attributes, AttributeSet) :-
proc_info::in, proc_info::out) is det.
:- pred proc_info_set_oisu_kind_fors(list(oisu_pred_kind_for)::in,
proc_info::in, proc_info::out) is det.
+:- pred proc_info_set_require_tailrec_info(require_tail_recursion::in,
+ proc_info::in, proc_info::out) is det.
:- pred proc_info_set_reg_r_headvars(set_of_progvar::in,
proc_info::in, proc_info::out) is det.
:- pred proc_info_set_arg_info(list(arg_info)::in,
@@ -2607,6 +2611,11 @@ attribute_list_to_attributes(Attributes, AttributeSet) :-
% for the each of the types in those pragmas.
psi_oisu_kind_fors :: list(oisu_pred_kind_for),
+ % Has the user requested (via a require_tail_recursion
+ % pragma) that we suppress or enable warnings about tail
+ % recursion for this procedure?
+ psi_maybe_require_tailrec :: maybe(require_tail_recursion),
+
%-----------------------------------------------------------%
% Information needed by the LLDS code generator.
%-----------------------------------------------------------%
@@ -2847,6 +2856,7 @@ proc_info_init(MainContext, Arity, Types, DeclaredModes, Modes, MaybeArgLives,
HasUserEvent = has_no_user_event,
HasTailCallEvent = has_no_tail_call_event,
OisuKinds = [],
+ MaybeRequireTailRecursion = no,
set_of_var.init(RegR_HeadVars),
MaybeArgPassInfo = no `with_type` maybe(list(arg_info)),
MaybeSpecialReturn = no `with_type` maybe(special_proc_return),
@@ -2880,6 +2890,7 @@ proc_info_init(MainContext, Arity, Types, DeclaredModes, Modes, MaybeArgLives,
HasUserEvent,
HasTailCallEvent,
OisuKinds,
+ MaybeRequireTailRecursion,
RegR_HeadVars,
MaybeArgPassInfo,
MaybeSpecialReturn,
@@ -2971,6 +2982,7 @@ proc_info_create_with_declared_detism(MainContext, VarSet, VarTypes, HeadVars,
HasUserEvent = has_no_user_event,
HasTailCallEvent = has_no_tail_call_event,
OisuKinds = [],
+ MaybeRequireTailRecursion = no,
set_of_var.init(RegR_HeadVars),
MaybeArgPassInfo = no `with_type` maybe(list(arg_info)),
MaybeSpecialReturn = no `with_type` maybe(special_proc_return),
@@ -3004,6 +3016,7 @@ proc_info_create_with_declared_detism(MainContext, VarSet, VarTypes, HeadVars,
HasUserEvent,
HasTailCallEvent,
OisuKinds,
+ MaybeRequireTailRecursion,
RegR_HeadVars,
MaybeArgPassInfo,
MaybeSpecialReturn,
@@ -3113,6 +3126,8 @@ proc_info_get_has_user_event(PI, X) :-
X = PI ^ proc_sub_info ^ psi_proc_has_user_event.
proc_info_get_has_tail_call_event(PI, X) :-
X = PI ^ proc_sub_info ^ psi_proc_has_tail_call_event.
+proc_info_get_maybe_require_tailrec_info(PI, X) :-
+ X = PI ^ proc_sub_info ^ psi_maybe_require_tailrec.
proc_info_get_oisu_kind_fors(PI, X) :-
X = PI ^ proc_sub_info ^ psi_oisu_kind_fors.
proc_info_get_reg_r_headvars(PI, X) :-
@@ -3199,6 +3214,8 @@ proc_info_set_has_tail_call_event(X, !PI) :-
!PI ^ proc_sub_info ^ psi_proc_has_tail_call_event := X.
proc_info_set_oisu_kind_fors(X, !PI) :-
!PI ^ proc_sub_info ^ psi_oisu_kind_fors := X.
+proc_info_set_require_tailrec_info(X, !PI) :-
+ !PI ^ proc_sub_info ^ psi_maybe_require_tailrec := yes(X).
proc_info_set_reg_r_headvars(X, !PI) :-
!PI ^ proc_sub_info ^ psi_reg_r_headvars := X.
proc_info_set_arg_info(X, !PI) :-
diff --git a/compiler/item_util.m b/compiler/item_util.m
index a1413a9..719328d 100644
--- a/compiler/item_util.m
+++ b/compiler/item_util.m
@@ -251,6 +251,7 @@ item_needs_foreign_imports(Item) = Langs :-
; Pragma = pragma_mm_tabling_info(_)
; Pragma = pragma_obsolete(_)
; Pragma = pragma_no_detism_warning(_)
+ ; Pragma = pragma_require_tail_recursion(_)
; Pragma = pragma_oisu(_)
; Pragma = pragma_tabled(_)
; Pragma = pragma_fact_table(_)
diff --git a/compiler/make_hlds_separate_items.m b/compiler/make_hlds_separate_items.m
index 3b4eb32..7c5a8e1 100644
--- a/compiler/make_hlds_separate_items.m
+++ b/compiler/make_hlds_separate_items.m
@@ -420,6 +420,7 @@ separate_items([Item | Items], SectionInfo,
; PragmaType = pragma_mm_tabling_info(_)
; PragmaType = pragma_obsolete(_)
; PragmaType = pragma_no_detism_warning(_)
+ ; PragmaType = pragma_require_tail_recursion(_)
; PragmaType = pragma_promise_eqv_clauses(_)
; PragmaType = pragma_promise_pure(_)
diff --git a/compiler/mercury_compile.m b/compiler/mercury_compile.m
index ac98098..311379e 100644
--- a/compiler/mercury_compile.m
+++ b/compiler/mercury_compile.m
@@ -1580,7 +1580,7 @@ process_augmented_module(Globals, OpModeAugment, ModuleAndImports,
HLDS21, HLDS22, !IO),
after_front_end_passes(Globals, OpModeCodeGen, NestedSubModules,
FindTimestampFiles, MaybeTimestampMap, HLDS22,
- !.Specs, ExtraObjFiles, !DumpInfo, !IO)
+ ExtraObjFiles, !Specs, !DumpInfo, !IO)
)
else
% If the number of errors is > 0, make sure that the compiler
@@ -2103,12 +2103,12 @@ prepare_for_intermodule_analysis(Globals, Verbose, Stats, !HLDS, !IO) :-
set(module_name)::in,
find_timestamp_file_names::in(find_timestamp_file_names),
maybe(module_timestamp_map)::in, module_info::in,
- list(error_spec)::in, list(string)::out, dump_info::in, dump_info::out,
- io::di, io::uo) is det.
+ list(string)::out, list(error_spec)::in, list(error_spec)::out,
+ dump_info::in, dump_info::out, io::di, io::uo) is det.
after_front_end_passes(Globals, OpModeCodeGen, NestedSubModules,
FindTimestampFiles, MaybeTimestampMap, !.HLDS,
- Specs, ExtraObjFiles, !DumpInfo, !IO) :-
+ ExtraObjFiles, !Specs, !DumpInfo, !IO) :-
globals.lookup_bool_option(Globals, verbose, Verbose),
globals.lookup_bool_option(Globals, statistics, Stats),
maybe_output_prof_call_graph(Verbose, Stats, !HLDS, !IO),
@@ -2129,10 +2129,10 @@ after_front_end_passes(Globals, OpModeCodeGen, NestedSubModules,
globals.lookup_bool_option(Globals, halt_at_warn, HaltAtWarn),
(
HaltAtWarn = no,
- FrontEndErrors = contains_errors(Globals, Specs)
+ FrontEndErrors = contains_errors(Globals, !.Specs)
;
HaltAtWarn = yes,
- FrontEndErrors = contains_errors_and_or_warnings(Globals, Specs)
+ FrontEndErrors = contains_errors_and_or_warnings(Globals, !.Specs)
),
module_info_get_num_errors(!.HLDS, NumErrors),
( if
@@ -2141,13 +2141,15 @@ after_front_end_passes(Globals, OpModeCodeGen, NestedSubModules,
then
(
Target = target_csharp,
- mlds_backend(!.HLDS, _, MLDS, !DumpInfo, !IO),
+ mlds_backend(!.HLDS, _, MLDS, NewSpecs, !DumpInfo, !IO),
+ !:Specs = NewSpecs ++ !.Specs,
% mlds_to_csharp never goes beyond generating C# code.
mlds_to_csharp(!.HLDS, MLDS, Succeeded, !IO),
ExtraObjFiles = []
;
Target = target_java,
- mlds_backend(!.HLDS, _, MLDS, !DumpInfo, !IO),
+ mlds_backend(!.HLDS, _, MLDS, NewSpecs, !DumpInfo, !IO),
+ !:Specs = NewSpecs ++ !.Specs,
mlds_to_java(!.HLDS, MLDS, TargetCodeSucceeded, !IO),
(
OpModeCodeGen = opmcg_target_code_only,
@@ -2179,7 +2181,8 @@ after_front_end_passes(Globals, OpModeCodeGen, NestedSubModules,
export.produce_header_file(!.HLDS, ExportDecls, ModuleName, !IO),
(
HighLevelCode = yes,
- mlds_backend(!.HLDS, _, MLDS, !DumpInfo, !IO),
+ mlds_backend(!.HLDS, _, MLDS, NewSpecs, !DumpInfo, !IO),
+ !:Specs = NewSpecs ++ !.Specs,
mlds_to_high_level_c(Globals, MLDS, TargetCodeSucceeded, !IO),
(
OpModeCodeGen = opmcg_target_code_only,
diff --git a/compiler/mercury_compile_mlds_back_end.m b/compiler/mercury_compile_mlds_back_end.m
index 275370c..3d622b9 100644
--- a/compiler/mercury_compile_mlds_back_end.m
+++ b/compiler/mercury_compile_mlds_back_end.m
@@ -24,17 +24,20 @@
:- import_module ml_backend.
:- import_module ml_backend.mlds.
:- import_module parse_tree.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module io.
+:- import_module list.
% Return `yes' iff this module defines the main/2 entry point.
%
:- func mlds_has_main(mlds) = has_main.
:- pred mlds_backend(module_info::in, module_info::out, mlds::out,
- dump_info::in, dump_info::out, io::di, io::uo) is det.
+ list(error_spec)::out, dump_info::in, dump_info::out, io::di, io::uo)
+ is det.
:- pred maybe_mark_static_terms(bool::in, bool::in,
module_info::in, module_info::out, io::di, io::uo) is det.
@@ -71,13 +74,11 @@
:- import_module ml_backend.mlds_to_java. % MLDS -> Java
:- import_module ml_backend.mlds_to_cs. % MLDS -> C#
:- import_module ml_backend.ml_util. % MLDS utility predicates
-:- import_module parse_tree.error_util.
:- import_module parse_tree.file_names.
:- import_module top_level.mercury_compile_front_end.
:- import_module top_level.mercury_compile_llds_back_end.
:- import_module getopt_io.
-:- import_module list.
:- import_module pprint.
:- import_module require.
:- import_module string.
@@ -96,7 +97,7 @@ mlds_has_main(MLDS) =
%---------------------------------------------------------------------------%
-mlds_backend(!HLDS, !:MLDS, !DumpInfo, !IO) :-
+mlds_backend(!HLDS, !:MLDS, Specs, !DumpInfo, !IO) :-
module_info_get_globals(!.HLDS, Globals),
globals.lookup_bool_option(Globals, verbose, Verbose),
globals.lookup_bool_option(Globals, statistics, Stats),
@@ -147,10 +148,11 @@ mlds_backend(!HLDS, !:MLDS, !DumpInfo, !IO) :-
(
OptimizeTailCalls = yes,
maybe_write_string(Verbose, "% Detecting tail calls...\n", !IO),
- ml_mark_tailcalls(Globals, !MLDS, !IO),
+ ml_mark_tailcalls(Globals, Specs, !MLDS),
maybe_write_string(Verbose, "% done.\n", !IO)
;
- OptimizeTailCalls = no
+ OptimizeTailCalls = no,
+ Specs = []
),
maybe_report_stats(Stats, !IO),
maybe_dump_mlds(Globals, !.MLDS, 20, "tailcalls", !IO),
diff --git a/compiler/ml_code_util.m b/compiler/ml_code_util.m
index 8de807b..15bdc3c 100644
--- a/compiler/ml_code_util.m
+++ b/compiler/ml_code_util.m
@@ -744,7 +744,7 @@ ml_gen_label_func(Info, FuncLabel, FuncParams, Context, Statement, Func) :-
Attributes = [],
EnvVarNames = set.init,
FuncDefn = mlds_function(MaybePredProcId, FuncParams,
- body_defined_here(Statement), Attributes, EnvVarNames),
+ body_defined_here(Statement), Attributes, EnvVarNames, no),
Func = mlds_defn(FuncName, mlds_make_context(Context), DeclFlags,
FuncDefn).
@@ -1971,7 +1971,7 @@ ml_gen_call_current_success_cont_indirectly(Context, Statement, !Info) :-
( if
Defn = mlds_defn(EntityName, _, _, EntityDefn),
EntityName = entity_function(PredLabel, ProcId, yes(SeqNum), _),
- EntityDefn = mlds_function(_, _, body_defined_here(_), _, _)
+ EntityDefn = mlds_function(_, _, body_defined_here(_), _, _, _)
then
% We call the proxy function.
ProcLabel = mlds_proc_label(PredLabel, ProcId),
diff --git a/compiler/ml_elim_nested.m b/compiler/ml_elim_nested.m
index 525f907..aad2ec2 100644
--- a/compiler/ml_elim_nested.m
+++ b/compiler/ml_elim_nested.m
@@ -521,7 +521,8 @@ ml_elim_nested_defns(Action, ModuleName, Globals, OuterVars, Defn0, Defns) :-
Defn0 = mlds_defn(Name, Context, Flags, DefnBody0),
( if
DefnBody0 = mlds_function(PredProcId, Params0,
- body_defined_here(FuncBody0), Attributes, EnvVarNames),
+ body_defined_here(FuncBody0), Attributes, EnvVarNames,
+ MaybeRequiretailrecInfo),
% Don't add GC tracing code to the gc_trace/1 primitive!
% (Doing so would just slow things down unnecessarily.)
not (
@@ -658,7 +659,8 @@ ml_elim_nested_defns(Action, ModuleName, Globals, OuterVars, Defn0, Defns) :-
),
Params = mlds_func_params(Arguments, RetValues),
DefnBody = mlds_function(PredProcId, Params,
- body_defined_here(FuncBody), Attributes, EnvVarNames),
+ body_defined_here(FuncBody), Attributes, EnvVarNames,
+ MaybeRequiretailrecInfo),
Defn = mlds_defn(Name, Context, Flags, DefnBody),
Defns = list.append(HoistedDefns, [Defn])
else
@@ -1043,7 +1045,7 @@ gen_gc_trace_func(FuncName, PredModule, FramePointerDecl, GCTraceStatements,
Attributes = [],
EnvVarNames = set.init,
FuncDefn = mlds_function(MaybePredProcId, FuncParams,
- body_defined_here(Statement), Attributes, EnvVarNames),
+ body_defined_here(Statement), Attributes, EnvVarNames, no),
GCTraceFuncDefn = mlds_defn(GCTraceFuncName, Context, DeclFlags,
FuncDefn).
@@ -1128,7 +1130,8 @@ ml_insert_init_env(Action, TypeName, ModuleName, Globals, Defn0, Defn,
Defn0 = mlds_defn(Name, Context, Flags, DefnBody0),
( if
DefnBody0 = mlds_function(PredProcId, Params,
- body_defined_here(FuncBody0), Attributes, EnvVarNames),
+ body_defined_here(FuncBody0), Attributes, EnvVarNames,
+ MaybeRequiretailrecInfo),
statement_contains_var(FuncBody0, qual(ModuleName, module_qual,
mlds_data_var(mlds_var_name("env_ptr", no)))) = yes
then
@@ -1146,7 +1149,8 @@ ml_insert_init_env(Action, TypeName, ModuleName, Globals, Defn0, Defn,
FuncBody = statement(ml_stmt_block([EnvPtrDecl],
[InitEnvPtr, FuncBody0]), Context),
DefnBody = mlds_function(PredProcId, Params,
- body_defined_here(FuncBody), Attributes, EnvVarNames),
+ body_defined_here(FuncBody), Attributes, EnvVarNames,
+ MaybeRequiretailrecInfo),
Defn = mlds_defn(Name, Context, Flags, DefnBody),
Init = yes
else
@@ -1605,7 +1609,7 @@ flatten_nested_defn(Action, Defn0, FollowingDefns, FollowingStatements,
Defn0 = mlds_defn(Name, Context, Flags0, DefnBody0),
(
DefnBody0 = mlds_function(PredProcId, Params, FuncBody0, Attributes,
- EnvVarNames),
+ EnvVarNames, MaybeRequiretailrecInfo),
% Recursively flatten the nested function.
flatten_function_body(Action, FuncBody0, FuncBody, !Info),
@@ -1621,7 +1625,7 @@ flatten_nested_defn(Action, Defn0, FollowingDefns, FollowingStatements,
Flags = Flags0
),
DefnBody = mlds_function(PredProcId, Params, FuncBody, Attributes,
- EnvVarNames),
+ EnvVarNames, MaybeRequiretailrecInfo),
Defn = mlds_defn(Name, Context, Flags, DefnBody),
(
Action = hoist_nested_funcs,
@@ -1744,7 +1748,7 @@ ml_need_to_hoist(ModuleName, DataName, FollowingDefns, FollowingStatements) :-
mlds_defn::in) is semidet.
ml_need_to_hoist_defn(QualDataName, FollowingDefn) :-
- FollowingDefn = mlds_defn(_, _, _, mlds_function(_, _, _, _, _)),
+ FollowingDefn = mlds_defn(_, _, _, mlds_function(_, _, _, _, _, _)),
defn_contains_var(FollowingDefn, QualDataName) = yes.
%-----------------------------------------------------------------------------%
@@ -2319,7 +2323,7 @@ defn_contains_matching_defn(Filter, Defn) :-
Defn = mlds_defn(_Name, _Context, _Flags, DefnBody),
(
DefnBody = mlds_function(_PredProcId, _Params, FunctionBody,
- _Attrs, _EnvVarNames),
+ _Attrs, _EnvVarNames, _MaybeRequiretailrecInfo),
FunctionBody = body_defined_here(Statement),
statement_contains_matching_defn(Filter, Statement)
;
diff --git a/compiler/ml_optimize.m b/compiler/ml_optimize.m
index 617c3bc..624f5a2 100644
--- a/compiler/ml_optimize.m
+++ b/compiler/ml_optimize.m
@@ -92,14 +92,14 @@ optimize_in_defn(ModuleName, Globals, Defn0, Defn) :-
Defn0 = mlds_defn(Name, Context, Flags, DefnBody0),
(
DefnBody0 = mlds_function(PredProcId, Params, FuncBody0, Attributes,
- EnvVarNames),
+ EnvVarNames, MaybeRequireTailrecInfo),
OptInfo = opt_info(Globals, ModuleName, Name, Params, Context),
optimize_func(OptInfo, FuncBody0, FuncBody1),
optimize_in_function_body(OptInfo, FuncBody1, FuncBody),
DefnBody = mlds_function(PredProcId, Params, FuncBody, Attributes,
- EnvVarNames),
+ EnvVarNames, MaybeRequireTailrecInfo),
Defn = mlds_defn(Name, Context, Flags, DefnBody)
;
DefnBody0 = mlds_data(_, _, _),
@@ -1208,9 +1208,11 @@ eliminate_var_in_defn(Defn0, Defn, !VarElimInfo) :-
% in the containing scope.
DefnBody = DefnBody0
;
- DefnBody0 = mlds_function(Id, Params, Body0, Attributes, EnvVarNames),
+ DefnBody0 = mlds_function(Id, Params, Body0, Attributes,
+ EnvVarNames, MaybeRequireTailrecInfo),
eliminate_var_in_function_body(Body0, Body, !VarElimInfo),
- DefnBody = mlds_function(Id, Params, Body, Attributes, EnvVarNames)
+ DefnBody = mlds_function(Id, Params, Body, Attributes,
+ EnvVarNames, MaybeRequireTailrecInfo)
),
Defn = mlds_defn(Name, Context, Flags, DefnBody).
diff --git a/compiler/ml_proc_gen.m b/compiler/ml_proc_gen.m
index 82508cc..e5a7ad5 100644
--- a/compiler/ml_proc_gen.m
+++ b/compiler/ml_proc_gen.m
@@ -472,12 +472,14 @@ ml_gen_proc(!ModuleInfo, ConstStructMap, PredId, ProcId,
MLDS_ProcContext = mlds_make_context(ProcContext),
DeclFlags = ml_gen_proc_decl_flags(!.ModuleInfo, PredId, ProcId),
MaybePredProcId = yes(proc(PredId, ProcId)),
+ proc_info_get_maybe_require_tailrec_info(ProcInfo0,
+ MaybeRequireTailrecInfo),
pred_info_get_attributes(PredInfo, Attributes),
attributes_to_attribute_list(Attributes, AttributeList),
MLDS_Attributes =
attributes_to_mlds_attributes(!.ModuleInfo, AttributeList),
EntityBody = mlds_function(MaybePredProcId, MLDS_Params,
- FunctionBody, MLDS_Attributes, EnvVarNames),
+ FunctionBody, MLDS_Attributes, EnvVarNames, MaybeRequireTailrecInfo),
ProcDefn = mlds_defn(EntityName, MLDS_ProcContext, DeclFlags, EntityBody),
!:Defns = ExtraDefns ++ [ProcDefn | !.Defns].
diff --git a/compiler/ml_tailcall.m b/compiler/ml_tailcall.m
index 2345530..1618907 100644
--- a/compiler/ml_tailcall.m
+++ b/compiler/ml_tailcall.m
@@ -54,10 +54,12 @@
:- interface.
:- import_module ml_backend.mlds.
+:- import_module parse_tree.
+:- import_module parse_tree.error_util.
:- import_module libs.
:- import_module libs.globals.
-:- import_module io.
+:- import_module list.
%-----------------------------------------------------------------------------%
@@ -65,8 +67,8 @@
%
% If enabled, warn for calls that "look like" tail calls, but aren't.
%
-:- pred ml_mark_tailcalls(globals::in, mlds::in, mlds::out,
- io::di, io::uo) is det.
+:- pred ml_mark_tailcalls(globals::in, list(error_spec)::out,
+ mlds::in, mlds::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -75,36 +77,36 @@
:- import_module hlds.
:- import_module hlds.hlds_pred.
+:- import_module libs.compiler_util.
:- import_module libs.options.
:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module ml_backend.ml_util.
-:- import_module parse_tree.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module int.
-:- import_module list.
:- import_module maybe.
-
+:- import_module require.
:- import_module string.
%-----------------------------------------------------------------------------%
-ml_mark_tailcalls(Globals, !MLDS, !IO) :-
+ml_mark_tailcalls(Globals, Specs, !MLDS) :-
Defns0 = !.MLDS ^ mlds_defns,
ModuleName = mercury_module_name_to_mlds(!.MLDS ^ mlds_name),
- mark_tailcalls_in_defns(ModuleName, Warnings, Defns0, Defns),
- !MLDS ^ mlds_defns := Defns,
globals.lookup_bool_option(Globals, warn_non_tail_recursion,
- WarnTailCalls),
+ WarnTailCallsBool),
(
- WarnTailCalls = yes,
- list.foldl(report_nontailcall_warning(Globals), Warnings, !IO)
+ WarnTailCallsBool = yes,
+ WarnTailCalls = warn_tail_calls
;
- WarnTailCalls = no
- ).
+ WarnTailCallsBool = no,
+ WarnTailCalls = do_not_warn_tail_calls
+ ),
+ mark_tailcalls_in_defns(ModuleName, WarnTailCalls, Specs,
+ Defns0, Defns),
+ !MLDS ^ mlds_defns := Defns.
%-----------------------------------------------------------------------------%
@@ -151,9 +153,15 @@ not_at_tail(not_at_tail_have_not_seen_reccall,
---> tailcall_info(
tci_module_name :: mlds_module_name,
tci_function_name :: mlds_entity_name,
- tci_locals :: locals
+ tci_locals :: locals,
+ tci_warn_tail_calls :: warn_tail_calls,
+ tci_maybe_require_tailrec :: maybe(require_tail_recursion)
).
+:- type warn_tail_calls
+ ---> warn_tail_calls
+ ; do_not_warn_tail_calls.
+
%-----------------------------------------------------------------------------%
% mark_tailcalls_in_defns:
@@ -177,20 +185,22 @@ not_at_tail(not_at_tail_have_not_seen_reccall,
% at the current point.
:- pred mark_tailcalls_in_defns(mlds_module_name::in,
- list(tailcall_warning)::out, list(mlds_defn)::in, list(mlds_defn)::out)
- is det.
+ warn_tail_calls::in, list(error_spec)::out,
+ list(mlds_defn)::in, list(mlds_defn)::out) is det.
-mark_tailcalls_in_defns(ModuleName, condense(Warnings), Defns0, Defns) :-
- list.map2(mark_tailcalls_in_defn(ModuleName), Defns0, Defns, Warnings).
+mark_tailcalls_in_defns(ModuleName, WarnTailCalls, condense(Warnings),
+ Defns0, Defns) :-
+ list.map2(mark_tailcalls_in_defn(ModuleName, WarnTailCalls),
+ Defns0, Defns, Warnings).
-:- pred mark_tailcalls_in_defn(mlds_module_name::in,
- mlds_defn::in, mlds_defn::out, list(tailcall_warning)::out) is det.
+:- pred mark_tailcalls_in_defn(mlds_module_name::in, warn_tail_calls::in,
+ mlds_defn::in, mlds_defn::out, list(error_spec)::out) is det.
-mark_tailcalls_in_defn(ModuleName, Defn0, Defn, Warnings) :-
+mark_tailcalls_in_defn(ModuleName, WarnTailCalls, Defn0, Defn, Warnings) :-
Defn0 = mlds_defn(Name, Context, Flags, DefnBody0),
(
DefnBody0 = mlds_function(PredProcId, Params, FuncBody0, Attributes,
- EnvVarNames),
+ EnvVarNames, MaybeRequireTailrecInfo),
% Compute the initial values of the `Locals' and `AtTail' arguments.
Params = mlds_func_params(Args, RetTypes),
Locals = [local_params(Args)],
@@ -201,11 +211,12 @@ mark_tailcalls_in_defn(ModuleName, Defn0, Defn, Warnings) :-
RetTypes = [_ | _],
AtTail = not_at_tail_have_not_seen_reccall
),
- TCallInfo = tailcall_info(ModuleName, Name, Locals),
+ TCallInfo = tailcall_info(ModuleName, Name, Locals,
+ WarnTailCalls, MaybeRequireTailrecInfo),
mark_tailcalls_in_function_body(TCallInfo, AtTail, Warnings,
FuncBody0, FuncBody),
DefnBody = mlds_function(PredProcId, Params, FuncBody, Attributes,
- EnvVarNames),
+ EnvVarNames, MaybeRequireTailrecInfo),
Defn = mlds_defn(Name, Context, Flags, DefnBody)
;
DefnBody0 = mlds_data(_, _, _),
@@ -215,9 +226,9 @@ mark_tailcalls_in_defn(ModuleName, Defn0, Defn, Warnings) :-
DefnBody0 = mlds_class(ClassDefn0),
ClassDefn0 = mlds_class_defn(Kind, Imports, BaseClasses, Implements,
TypeParams, CtorDefns0, MemberDefns0),
- mark_tailcalls_in_defns(ModuleName, CtorWarnings,
+ mark_tailcalls_in_defns(ModuleName, WarnTailCalls, CtorWarnings,
CtorDefns0, CtorDefns),
- mark_tailcalls_in_defns(ModuleName, MemberWarnings,
+ mark_tailcalls_in_defns(ModuleName, WarnTailCalls, MemberWarnings,
MemberDefns0, MemberDefns),
Warnings = CtorWarnings ++ MemberWarnings,
ClassDefn = mlds_class_defn(Kind, Imports, BaseClasses, Implements,
@@ -227,7 +238,7 @@ mark_tailcalls_in_defn(ModuleName, Defn0, Defn, Warnings) :-
).
:- pred mark_tailcalls_in_function_body(tailcall_info::in, at_tail::in,
- list(tailcall_warning)::out,
+ list(error_spec)::out,
mlds_function_body::in, mlds_function_body::out) is det.
mark_tailcalls_in_function_body(TCallInfo, AtTail, Warnings, Body0, Body) :-
@@ -243,7 +254,7 @@ mark_tailcalls_in_function_body(TCallInfo, AtTail, Warnings, Body0, Body) :-
).
:- pred mark_tailcalls_in_maybe_statement(tailcall_info::in,
- list(tailcall_warning)::out, at_tail::in, at_tail::out,
+ list(error_spec)::out, at_tail::in, at_tail::out,
maybe(statement)::in, maybe(statement)::out) is det.
mark_tailcalls_in_maybe_statement(_, [], !AtTail, no, no).
@@ -253,7 +264,7 @@ mark_tailcalls_in_maybe_statement(TCallInfo, Warnings, !AtTail,
!AtTail, Statement0, Statement).
:- pred mark_tailcalls_in_statements(tailcall_info::in,
- list(tailcall_warning)::out, at_tail::in, at_tail::out,
+ list(error_spec)::out, at_tail::in, at_tail::out,
list(statement)::in, list(statement)::out) is det.
mark_tailcalls_in_statements(_, [], !AtTail, [], []).
@@ -265,7 +276,7 @@ mark_tailcalls_in_statements(TCallInfo, FirstWarnings ++ RestWarnings,
First0, First).
:- pred mark_tailcalls_in_statement(tailcall_info::in,
- list(tailcall_warning)::out,
+ list(error_spec)::out,
at_tail::in, at_tail::out, statement::in, statement::out) is det.
mark_tailcalls_in_statement(TCallInfo, Warnings, !AtTail, !Statement) :-
@@ -274,7 +285,7 @@ mark_tailcalls_in_statement(TCallInfo, Warnings, !AtTail, !Statement) :-
!:Statement = statement(Stmt, Context).
:- pred mark_tailcalls_in_stmt(tailcall_info::in, mlds_context::in,
- list(tailcall_warning)::out, at_tail::in, at_tail::out,
+ list(error_spec)::out, at_tail::in, at_tail::out,
mlds_stmt::in, mlds_stmt::out) is det.
mark_tailcalls_in_stmt(TCallInfo, Context, Warnings,
@@ -288,7 +299,8 @@ mark_tailcalls_in_stmt(TCallInfo, Context, Warnings,
% statements in that block. The statement list will be in a tail
% position iff the block is in a tail position.
ModuleName = TCallInfo ^ tci_module_name,
- mark_tailcalls_in_defns(ModuleName, DefnsWarnings, Defns0, Defns),
+ mark_tailcalls_in_defns(ModuleName, TCallInfo ^ tci_warn_tail_calls,
+ DefnsWarnings, Defns0, Defns),
Locals = TCallInfo ^ tci_locals,
NewTCallInfo = TCallInfo ^ tci_locals := [local_defns(Defns) | Locals],
mark_tailcalls_in_statements(NewTCallInfo, StatementsWarnings,
@@ -389,7 +401,7 @@ mark_tailcalls_in_stmt(TCallInfo, Context, Warnings,
---> ml_stmt_call(ground, ground, ground, ground, ground, ground).
:- pred mark_tailcalls_in_stmt_call(tailcall_info::in, mlds_context::in,
- list(tailcall_warning)::out, at_tail::in, at_tail::out,
+ list(error_spec)::out, at_tail::in, at_tail::out,
mlds_stmt::in(ml_stmt_call), mlds_stmt::out) is det.
mark_tailcalls_in_stmt_call(TCallInfo, Context, Warnings,
@@ -439,14 +451,7 @@ mark_tailcalls_in_stmt_call(TCallInfo, Context, Warnings,
% If so, a warning may be useful.
AtTailAfter = at_tail(_)
),
- (
- CodeAddr = code_addr_proc(QualProcLabel, _Sig)
- ;
- CodeAddr = code_addr_internal(QualProcLabel, _SeqNum, _Sig)
- ),
- QualProcLabel = qual(_, _, ProcLabel),
- ProcLabel = mlds_proc_label(PredLabel, ProcId),
- Warnings = [tailcall_warning(PredLabel, ProcId, Context)]
+ maybe_warn_tailcalls(TCallInfo, CodeAddr, Context, Warnings)
),
Stmt = Stmt0,
AtTailBefore = not_at_tail_seen_reccall
@@ -458,7 +463,7 @@ mark_tailcalls_in_stmt_call(TCallInfo, Context, Warnings,
not_at_tail(AtTailAfter, AtTailBefore)
).
-:- pred mark_tailcalls_in_cases(tailcall_info::in, list(tailcall_warning)::out,
+:- pred mark_tailcalls_in_cases(tailcall_info::in, list(error_spec)::out,
at_tail::in, list(at_tail)::out,
list(mlds_switch_case)::in, list(mlds_switch_case)::out) is det.
@@ -471,7 +476,7 @@ mark_tailcalls_in_cases(TCallInfo, CaseWarnings ++ CasesWarnings,
mark_tailcalls_in_cases(TCallInfo, CasesWarnings,
AtTailAfter, AtTailBefores, Cases0, Cases).
-:- pred mark_tailcalls_in_case(tailcall_info::in, list(tailcall_warning)::out,
+:- pred mark_tailcalls_in_case(tailcall_info::in, list(error_spec)::out,
at_tail::in, at_tail::out, mlds_switch_case::in, mlds_switch_case::out)
is det.
@@ -483,7 +488,7 @@ mark_tailcalls_in_case(TCallInfo, Warnings, AtTailAfter, AtTailBefore,
Case = mlds_switch_case(FirstCond, LaterConds, Statement).
:- pred mark_tailcalls_in_default(tailcall_info::in,
- list(tailcall_warning)::out, at_tail::in, at_tail::out,
+ list(error_spec)::out, at_tail::in, at_tail::out,
mlds_switch_default::in, mlds_switch_default::out) is det.
mark_tailcalls_in_default(TCallInfo, Warnings, AtTailAfter, AtTailBefore,
@@ -504,6 +509,112 @@ mark_tailcalls_in_default(TCallInfo, Warnings, AtTailAfter, AtTailBefore,
%-----------------------------------------------------------------------------%
+:- pred maybe_warn_tailcalls(tailcall_info::in, mlds_code_addr::in,
+ mlds_context::in, list(error_spec)::out) is det.
+
+maybe_warn_tailcalls(TCallInfo, CodeAddr, Context, Specs) :-
+ WarnTailCalls = TCallInfo ^ tci_warn_tail_calls,
+ MaybeRequireTailrecInfo = TCallInfo ^ tci_maybe_require_tailrec,
+ ( if
+ % Trivially reject the common case
+ WarnTailCalls = do_not_warn_tail_calls,
+ MaybeRequireTailrecInfo = no
+ then
+ Specs = []
+ else if
+ require_complete_switch [WarnTailCalls]
+ (
+ WarnTailCalls = do_not_warn_tail_calls,
+
+ % We always warn/error if the pragma says so.
+ MaybeRequireTailrecInfo = yes(RequireTailrecInfo),
+ RequireTailrecInfo = enable_tailrec_warnings(WarnOrError,
+ TailrecType, _)
+ ;
+ WarnTailCalls = warn_tail_calls,
+
+ % if warnings are enabled then we check the pragma. We check
+ % that it doesn't disable warnings and also determine whether
+ % this should be a warning or error.
+ require_complete_switch [MaybeRequireTailrecInfo]
+ (
+ MaybeRequireTailrecInfo = no,
+ % Choose some defaults.
+ WarnOrError = we_warning,
+ TailrecType = require_any_tail_recursion
+ ;
+ MaybeRequireTailrecInfo = yes(RequireTailrecInfo),
+ require_complete_switch [RequireTailrecInfo]
+ (
+ RequireTailrecInfo =
+ enable_tailrec_warnings(WarnOrError, TailrecType, _)
+ ;
+ RequireTailrecInfo = suppress_tailrec_warnings(_),
+ false
+ )
+ )
+ ),
+ require_complete_switch [TailrecType]
+ (
+ TailrecType = require_any_tail_recursion
+ ;
+ TailrecType = require_direct_tail_recursion
+ % XXX: Currently this has no effect since all tailcalls on MLDS
+ % are direct tail calls.
+ )
+ then
+ (
+ CodeAddr = code_addr_proc(QualProcLabel, _Sig)
+ ;
+ CodeAddr = code_addr_internal(QualProcLabel,
+ _SeqNum, _Sig)
+ ),
+ QualProcLabel = qual(_, _, ProcLabel),
+ ProcLabel = mlds_proc_label(PredLabel, ProcId),
+ ( if PredLabel = mlds_special_pred_label(_, _, _, _) then
+ % Don't warn about special preds.
+ Specs = []
+ else
+ report_nontailcall(WarnOrError, PredLabel, ProcId, Context, Specs)
+ )
+ else
+ Specs = []
+ ).
+
+:- pred report_nontailcall(warning_or_error::in, mlds_pred_label::in,
+ proc_id::in, mlds_context::in, list(error_spec)::out) is det.
+
+report_nontailcall(WarnOrError, PredLabel, ProcId, Context, Specs) :-
+ (
+ PredLabel = mlds_user_pred_label(PredOrFunc, _MaybeModule, Name, Arity,
+ _CodeModel, _NonOutputFunc),
+ SimpleCallId = simple_call_id(PredOrFunc, unqualified(Name), Arity),
+ proc_id_to_int(ProcId, ProcNumber0),
+ ProcNumber = ProcNumber0 + 1,
+ (
+ WarnOrError = we_warning,
+ WarnOrErrorWords = words("warning:")
+ ;
+ WarnOrError = we_error,
+ WarnOrErrorWords = words("error:")
+ ),
+ Pieces =
+ [words("In mode number"), int_fixed(ProcNumber),
+ words("of"), simple_call(SimpleCallId), suffix(":"), nl,
+ WarnOrErrorWords,
+ words("recursive call is not tail recursive."), nl],
+ Msg = simple_msg(mlds_get_prog_context(Context), [always(Pieces)]),
+ warning_or_error_severity(WarnOrError, Severity),
+ Specs = [error_spec(Severity, phase_code_gen, [Msg])]
+ ;
+ PredLabel = mlds_special_pred_label(_, _, _, _),
+ % This case is tested for when deciding weather to create an error
+ % or warning.
+ unexpected($file, $pred, "mlds_special_pred_label")
+ ).
+
+%-----------------------------------------------------------------------------%
+
% match_return_vals(Rvals, Lvals):
% match_return_val(Rval, Lval):
% Check that the Lval(s) returned by a call match
@@ -749,36 +860,6 @@ locals_member(Name, LocalsList) :-
%-----------------------------------------------------------------------------%
-:- type tailcall_warning
- ---> tailcall_warning(
- mlds_pred_label,
- proc_id,
- mlds_context
- ).
-
-:- pred report_nontailcall_warning(globals::in, tailcall_warning::in,
- io::di, io::uo) is det.
-
-report_nontailcall_warning(Globals, Warning, !IO) :-
- Warning = tailcall_warning(PredLabel, ProcId, Context),
- (
- PredLabel = mlds_user_pred_label(PredOrFunc, _MaybeModule, Name, Arity,
- _CodeModel, _NonOutputFunc),
- SimpleCallId = simple_call_id(PredOrFunc, unqualified(Name), Arity),
- proc_id_to_int(ProcId, ProcNumber0),
- ProcNumber = ProcNumber0 + 1,
- Pieces =
- [words("In mode number"), int_fixed(ProcNumber),
- words("of"), simple_call(SimpleCallId), suffix(":"), nl,
- words("warning: recursive call is not tail recursive."), nl],
- Msg = simple_msg(mlds_get_prog_context(Context), [always(Pieces)]),
- Spec = error_spec(severity_warning, phase_code_gen, [Msg]),
- write_error_spec(Spec, Globals, 0, _NumWarnings, 0, _NumErrors, !IO)
- ;
- PredLabel = mlds_special_pred_label(_, _, _, _)
- % Don't warn about these.
- ).
-
%-----------------------------------------------------------------------------%
:- end_module ml_backend.ml_tailcall.
%-----------------------------------------------------------------------------%
diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m
index c1854ea..f7a89e2 100644
--- a/compiler/ml_type_gen.m
+++ b/compiler/ml_type_gen.m
@@ -931,7 +931,7 @@ ml_gen_constructor_function(Target, BaseClassId, ClassType, ClassQualifier,
Attributes = [],
EnvVarNames = set.init,
Ctor = mlds_function(no, mlds_func_params(Args, ReturnValues),
- body_defined_here(Stmt), Attributes, EnvVarNames),
+ body_defined_here(Stmt), Attributes, EnvVarNames, no),
CtorFlags = init_decl_flags(acc_public, per_instance, non_virtual,
overridable, modifiable, concrete),
@@ -964,7 +964,7 @@ gen_init_field(Target, BaseClassId, ClassType, ClassQualifier, Member) =
Defn = mlds_data(Type0, _Init, _GCStatement),
Type = Type0
;
- ( Defn = mlds_function(_, _, _, _, _)
+ ( Defn = mlds_function(_, _, _, _, _, _)
; Defn = mlds_class(_)
),
unexpected($module, $pred, "non-data member")
diff --git a/compiler/ml_util.m b/compiler/ml_util.m
index 847e637..b6ce9fe 100644
--- a/compiler/ml_util.m
+++ b/compiler/ml_util.m
@@ -676,7 +676,7 @@ has_foreign_languages(Statement, Langs) :-
defn_contains_foreign_code(NativeTargetLang, Defn) :-
Defn = mlds_defn(_Name, _Context, _Flags, Body),
- Body = mlds_function(_, _, body_defined_here(FunctionBody), _, _),
+ Body = mlds_function(_, _, body_defined_here(FunctionBody), _, _, _),
statement_contains_statement(FunctionBody, Statement),
Statement = statement(Stmt, _),
(
@@ -688,7 +688,7 @@ defn_contains_foreign_code(NativeTargetLang, Defn) :-
defn_contains_outline_foreign_proc(ForeignLang, Defn) :-
Defn = mlds_defn(_Name, _Context, _Flags, Body),
- Body = mlds_function(_, _, body_defined_here(FunctionBody), _, _),
+ Body = mlds_function(_, _, body_defined_here(FunctionBody), _, _, _),
statement_contains_statement(FunctionBody, Statement),
Statement = statement(Stmt, _),
Stmt = ml_stmt_atomic(outline_foreign_proc(ForeignLang, _, _, _)).
@@ -751,7 +751,7 @@ defn_body_contains_var(DefnBody, DataName) = ContainsVar :-
ContainsVar = initializer_contains_var(Initializer, DataName)
;
DefnBody = mlds_function(_PredProcId, _Params, FunctionBody,
- _Attrs, _EnvVarNames),
+ _Attrs, _EnvVarNames, _MaybeRequireTailrecInfo),
ContainsVar = function_body_contains_var(FunctionBody, DataName)
;
DefnBody = mlds_class(ClassDefn),
diff --git a/compiler/mlds.m b/compiler/mlds.m
index 7c2ec71..ab0b203 100644
--- a/compiler/mlds.m
+++ b/compiler/mlds.m
@@ -582,13 +582,17 @@
; mlds_function(
% Represents functions.
- maybe(pred_proc_id), % Identifies the original
- % Mercury procedure, if any.
- mlds_func_params, % The arguments & return types.
- mlds_function_body, % The function body.
- list(mlds_attribute), % Attributes.
- set(string) % The set of environment variables
- % referred to by the function body.
+ maybe(pred_proc_id), % Identifies the original
+ % Mercury procedure, if any.
+ mlds_func_params, % The arguments & return types.
+ mlds_function_body, % The function body.
+ list(mlds_attribute), % Attributes.
+ set(string), % The set of environment
+ % variables referred to by the
+ % function body.
+ maybe(require_tail_recursion)
+ % Information used to generate
+ % tail recursion errors.
)
; mlds_class(
% Represents packages, classes, interfaces, structs, enums.
diff --git a/compiler/mlds_to_c.m b/compiler/mlds_to_c.m
index 7d666e3..8d38094 100644
--- a/compiler/mlds_to_c.m
+++ b/compiler/mlds_to_c.m
@@ -463,7 +463,7 @@ mlds_get_env_var_names(Defns) = EnvVarNameSet :-
is semidet.
mlds_get_env_var_names_from_defn(Defn, EnvVarNameSet) :-
- Defn = mlds_defn(_, _, _, mlds_function(_, _, _, _, EnvVarNameSet)).
+ Defn = mlds_defn(_, _, _, mlds_function(_, _, _, _, EnvVarNameSet, _)).
:- pred mlds_output_env_var_decl(string::in, io::di, io::uo) is det.
@@ -1519,7 +1519,7 @@ mlds_output_decl(Opts, Indent, ModuleName, Defn, !IO) :-
HighLevelData = Opts ^ m2co_highlevel_data,
( if
HighLevelData = yes,
- DefnBody = mlds_function(_, Params, _, _, _)
+ DefnBody = mlds_function(_, Params, _, _, _, _)
then
Params = mlds_func_params(Arguments, _RetTypes),
ParamTypes = mlds_get_arg_types(Arguments),
@@ -1866,7 +1866,7 @@ mlds_output_type_forward_decl(Opts, Indent, Type, !IO) :-
mlds_output_defn(Opts, Indent, Separate, ModuleName, Defn, !IO) :-
Defn = mlds_defn(Name, Context, Flags, DefnBody),
(
- ( DefnBody = mlds_function(_, _, _, _, _)
+ ( DefnBody = mlds_function(_, _, _, _, _, _)
; DefnBody = mlds_class(_)
),
io.nl(!IO)
@@ -1896,7 +1896,7 @@ mlds_output_decl_body(Opts, Indent, Name, Context, DefnBody, !IO) :-
get_initializer_array_size(Initializer), !IO)
;
DefnBody = mlds_function(MaybePredProcId, Signature,
- _MaybeBody, _Attrs, _EnvVarNames),
+ _MaybeBody, _Attrs, _EnvVarNames, _MaybeRequireTailrecInfo),
mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id(Opts),
!IO),
mlds_output_func_decl(Opts, Indent, Name, Context, Signature, !IO)
@@ -1917,7 +1917,7 @@ mlds_output_defn_body(Opts, Indent, Name, Context, DefnBody, !IO) :-
mlds_output_gc_statement(Opts, Indent, Name, GCStatement, "", !IO)
;
DefnBody = mlds_function(MaybePredProcId, Signature,
- MaybeBody, _Attributes, _EnvVarNames),
+ MaybeBody, _Attributes, _EnvVarNames, _MaybeRequireTailrecInfo),
mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id(Opts),
!IO),
mlds_output_func(Opts, Indent, Name, Context, Signature, MaybeBody,
@@ -2133,7 +2133,7 @@ mlds_output_enum_constant(Opts, Indent, EnumModuleName, Defn, !IO) :-
qual(EnumModuleName, type_qual, Name), !IO),
mlds_output_initializer(Opts, Type, Initializer, !IO)
;
- ( DefnBody = mlds_function(_, _, _, _, _)
+ ( DefnBody = mlds_function(_, _, _, _, _, _)
; DefnBody = mlds_class(_)
),
unexpected($module, $pred, "constant is not data")
@@ -3138,7 +3138,7 @@ mlds_output_extern_or_static(Access, PerInstance, DeclOrDefn, Name, DefnBody,
Name \= entity_type(_, _),
% Don't output "static" for functions that don't have a body.
% This can happen for Mercury procedures declared `:- external'
- DefnBody \= mlds_function(_, _, body_external, _, _)
+ DefnBody \= mlds_function(_, _, body_external, _, _, _)
then
io.write_string("static ", !IO)
else if
diff --git a/compiler/mlds_to_cs.m b/compiler/mlds_to_cs.m
index b0b37ee..2d12261 100644
--- a/compiler/mlds_to_cs.m
+++ b/compiler/mlds_to_cs.m
@@ -469,21 +469,25 @@ find_pointer_addressed_methods_in_scalars(Cord, !CodeAddrs) :-
:- pred method_ptrs_in_entity_defn(mlds_entity_defn::in,
code_addr_map::in, code_addr_map::out) is det.
-method_ptrs_in_entity_defn(mlds_function(_MaybeID, _Params, Body,
- _Attributes, _EnvVars), !CodeAddrs) :-
+method_ptrs_in_entity_defn(Defn, !CodeAddrs) :-
(
- Body = body_defined_here(Statement),
- method_ptrs_in_statement(Statement, !CodeAddrs)
+ Defn = mlds_function(_MaybeID, _Params, Body, _Attributes, _EnvVars,
+ _MaybeRequireTailrecInfo),
+ (
+ Body = body_defined_here(Statement),
+ method_ptrs_in_statement(Statement, !CodeAddrs)
+ ;
+ Body = body_external
+ )
;
- Body = body_external
+ Defn = mlds_data(_Type, Initializer, _GCStatement),
+ method_ptrs_in_initializer(Initializer, !CodeAddrs)
+ ;
+ Defn = mlds_class(ClassDefn),
+ ClassDefn = mlds_class_defn(_, _, _, _, _, Ctors, Members),
+ method_ptrs_in_defns(Ctors, !CodeAddrs),
+ method_ptrs_in_defns(Members, !CodeAddrs)
).
-method_ptrs_in_entity_defn(mlds_data(_Type, Initializer, _GCStatement),
- !CodeAddrs) :-
- method_ptrs_in_initializer(Initializer, !CodeAddrs).
-method_ptrs_in_entity_defn(mlds_class(ClassDefn), !CodeAddrs) :-
- ClassDefn = mlds_class_defn(_, _, _, _, _, Ctors, Members),
- method_ptrs_in_defns(Ctors, !CodeAddrs),
- method_ptrs_in_defns(Members, !CodeAddrs).
:- pred method_ptrs_in_statements(list(statement)::in,
code_addr_map::in, code_addr_map::out) is det.
@@ -738,7 +742,7 @@ collect_env_var_names(Defn, !EnvVarNames) :-
(
EntityDefn = mlds_data(_, _, _)
;
- EntityDefn = mlds_function(_, _, _, _, EnvVarNames),
+ EntityDefn = mlds_function(_, _, _, _, EnvVarNames, _),
set.union(EnvVarNames, !EnvVarNames)
;
EntityDefn = mlds_class(_)
@@ -929,7 +933,7 @@ output_defns(Info, Indent, OutputAux, Defns, !IO) :-
output_defn(Info, Indent, OutputAux, Defn, !IO) :-
Defn = mlds_defn(Name, Context, Flags, DefnBody),
indent_line(Indent, !IO),
- ( DefnBody = mlds_function(_, _, body_external, _, _) ->
+ ( DefnBody = mlds_function(_, _, body_external, _, _, _) ->
% This is just a function declaration, with no body.
% C# doesn't support separate declarations and definitions,
% so just output the declaration as a comment.
@@ -982,7 +986,7 @@ output_defn_body(Info, Indent, UnqualName, OutputAux, Context, Entity, !IO) :-
!IO)
;
Entity = mlds_function(MaybePredProcId, Signature, MaybeBody,
- _Attributes, _EnvVarNames),
+ _Attributes, _EnvVarNames, _MaybeRequireTailrecInfo),
output_maybe(MaybePredProcId, output_pred_proc_id(Info), !IO),
output_func(Info, Indent, UnqualName, OutputAux, Context,
Signature, MaybeBody, !IO)
@@ -1737,7 +1741,7 @@ output_rtti_defn_assignments(Info, Indent, Defn, !IO) :-
DefnBody = mlds_data(_Type, Initializer, _),
output_rtti_defn_assignments_2(Info, Indent, Name, Initializer, !IO)
;
- ( DefnBody = mlds_function(_, _, _, _, _)
+ ( DefnBody = mlds_function(_, _, _, _, _, _)
; DefnBody = mlds_class(_)
),
unexpected($module, $pred, "expected mlds_data")
diff --git a/compiler/mlds_to_java.m b/compiler/mlds_to_java.m
index 5444109..5382154 100644
--- a/compiler/mlds_to_java.m
+++ b/compiler/mlds_to_java.m
@@ -778,21 +778,25 @@ find_pointer_addressed_methods_in_scalars(Cord, !CodeAddrs) :-
:- pred method_ptrs_in_entity_defn(mlds_entity_defn::in,
list(mlds_code_addr)::in, list(mlds_code_addr)::out) is det.
-method_ptrs_in_entity_defn(mlds_function(_MaybeID, _Params, Body,
- _Attributes, _EnvVars), !CodeAddrs) :-
+method_ptrs_in_entity_defn(Defn, !CodeAddrs) :-
(
- Body = body_defined_here(Statement),
- method_ptrs_in_statement(Statement, !CodeAddrs)
+ Defn = mlds_function(_MaybeID, _Params, Body, _Attributes, _EnvVars,
+ _MaybeRequireTailrecInfo),
+ (
+ Body = body_defined_here(Statement),
+ method_ptrs_in_statement(Statement, !CodeAddrs)
+ ;
+ Body = body_external
+ )
;
- Body = body_external
+ Defn = mlds_data(_Type, Initializer, _GCStatement),
+ method_ptrs_in_initializer(Initializer, !CodeAddrs)
+ ;
+ Defn = mlds_class(ClassDefn),
+ ClassDefn = mlds_class_defn(_, _, _, _, _, Ctors, Members),
+ method_ptrs_in_defns(Ctors, !CodeAddrs),
+ method_ptrs_in_defns(Members, !CodeAddrs)
).
-method_ptrs_in_entity_defn(mlds_data(_Type, Initializer, _GCStatement),
- !CodeAddrs) :-
- method_ptrs_in_initializer(Initializer, !CodeAddrs).
-method_ptrs_in_entity_defn(mlds_class(ClassDefn), !CodeAddrs) :-
- ClassDefn = mlds_class_defn(_, _, _, _, _, Ctors, Members),
- method_ptrs_in_defns(Ctors, !CodeAddrs),
- method_ptrs_in_defns(Members, !CodeAddrs).
:- pred method_ptrs_in_statements(list(statement)::in,
list(mlds_code_addr)::in, list(mlds_code_addr)::out) is det.
@@ -1085,7 +1089,7 @@ generate_addr_wrapper_class(MLDS_ModuleName, Arity - CodeAddrs, ClassDefn,
Attributes = [],
EnvVarNames = set.init,
Ctor = mlds_function(no, mlds_func_params(CtorArgs, CtorReturnValues),
- body_defined_here(CtorStatement), Attributes, EnvVarNames),
+ body_defined_here(CtorStatement), Attributes, EnvVarNames, no),
CtorFlags = init_decl_flags(acc_public, per_instance, non_virtual,
overridable, modifiable, concrete),
CtorDefn = mlds_defn(entity_export("<constructor>"), Context,
@@ -1202,7 +1206,7 @@ generate_call_method(MLDS_ModuleName, Arity, CodeAddrs, MethodDefn) :-
MethodAttribs = [],
MethodEnvVarNames = set.init,
MethodBody = mlds_function(MethodMaybeID, MethodParams,
- body_defined_here(Statement), MethodAttribs, MethodEnvVarNames),
+ body_defined_here(Statement), MethodAttribs, MethodEnvVarNames, no),
MethodFlags = ml_gen_member_decl_flags,
MethodDefn = mlds_defn(MethodName, Context, MethodFlags, MethodBody).
@@ -1459,7 +1463,7 @@ rename_class_names_defn(Renaming, !Defn) :-
EntityDefn = mlds_data(Type, Initializer, GCStatement)
;
EntityDefn0 = mlds_function(MaybePPId, FuncParams0, FuncBody0,
- Attributes, EnvVarNames),
+ Attributes, EnvVarNames, MaybeRequireTailrecInfo),
rename_class_names_func_params(Renaming, FuncParams0, FuncParams),
(
FuncBody0 = body_defined_here(Statement0),
@@ -1470,7 +1474,7 @@ rename_class_names_defn(Renaming, !Defn) :-
FuncBody = body_external
),
EntityDefn = mlds_function(MaybePPId, FuncParams, FuncBody,
- Attributes, EnvVarNames)
+ Attributes, EnvVarNames, MaybeRequireTailrecInfo)
;
EntityDefn0 = mlds_class(mlds_class_defn(ClassKind, Imports, Inherits,
Implements, TypeParams, Ctors0, Members0)),
@@ -2000,7 +2004,7 @@ collect_env_var_names(Defn, !EnvVarNames) :-
(
EntityDefn = mlds_data(_, _, _)
;
- EntityDefn = mlds_function(_, _, _, _, EnvVarNames),
+ EntityDefn = mlds_function(_, _, _, _, EnvVarNames, _),
set.union(EnvVarNames, !EnvVarNames)
;
EntityDefn = mlds_class(_)
@@ -2177,7 +2181,7 @@ output_defns(Info, Indent, OutputAux, Defns, !IO) :-
output_defn(Info, Indent, OutputAux, Defn, !IO) :-
Defn = mlds_defn(Name, Context, Flags, DefnBody),
indent_line(Info, marker_comment, Context, Indent, !IO),
- ( if DefnBody = mlds_function(_, _, body_external, _, _) then
+ ( if DefnBody = mlds_function(_, _, body_external, _, _, _) then
% This is just a function declaration, with no body.
% Java doesn't support separate declarations and definitions,
% so just output the declaration as a comment.
@@ -2205,7 +2209,7 @@ output_defn_body(Info, Indent, UnqualName, OutputAux, Context, Entity, !IO) :-
!IO)
;
Entity = mlds_function(MaybePredProcId, Signature, MaybeBody,
- _Attributes, _EnvVarNames),
+ _Attributes, _EnvVarNames, _MaybeRequireTailrecInfo),
output_maybe(MaybePredProcId, output_pred_proc_id(Info), !IO),
output_func(Info, Indent, UnqualName, OutputAux, Context,
Signature, MaybeBody, !IO)
@@ -3011,7 +3015,7 @@ output_rtti_defn_assignments(Info, Indent, Defn, !IO) :-
DefnBody = mlds_data(_Type, Initializer, _),
output_rtti_defn_assignments_2(Info, Indent, Name, Initializer, !IO)
;
- ( DefnBody = mlds_function(_, _, _, _, _)
+ ( DefnBody = mlds_function(_, _, _, _, _, _)
; DefnBody = mlds_class(_)
),
unexpected($module, $pred, "expected mlds_data")
diff --git a/compiler/module_qual.qual_errors.m b/compiler/module_qual.qual_errors.m
index d39ba49..9ffd33a 100644
--- a/compiler/module_qual.qual_errors.m
+++ b/compiler/module_qual.qual_errors.m
@@ -500,6 +500,9 @@ mq_error_context_to_pieces(ErrorContext, Context,Pieces) :-
Pragma = pragma_no_detism_warning(_),
PragmaName = "no_detism_warning"
;
+ Pragma = pragma_require_tail_recursion(_),
+ PragmaName = "require_tail_recursion"
+ ;
Pragma = pragma_tabled(_),
PragmaName = "tabled"
;
diff --git a/compiler/module_qual.qualify_items.m b/compiler/module_qual.qualify_items.m
index 6040bfe..7c7dbc1 100644
--- a/compiler/module_qual.qualify_items.m
+++ b/compiler/module_qual.qualify_items.m
@@ -1058,6 +1058,7 @@ qualify_pragma(InInt, Context, Pragma0, Pragma, !Info, !Specs) :-
; Pragma0 = pragma_no_inline(_)
; Pragma0 = pragma_obsolete(_)
; Pragma0 = pragma_no_detism_warning(_)
+ ; Pragma0 = pragma_require_tail_recursion(_)
; Pragma0 = pragma_unused_args(_)
; Pragma0 = pragma_exceptions(_)
; Pragma0 = pragma_trailing_info(_)
diff --git a/compiler/parse_tree_out_pragma.m b/compiler/parse_tree_out_pragma.m
index 03cbc4f..b3932d3 100644
--- a/compiler/parse_tree_out_pragma.m
+++ b/compiler/parse_tree_out_pragma.m
@@ -100,6 +100,7 @@
:- implementation.
:- import_module libs.
+:- import_module libs.compiler_util.
:- import_module libs.rat.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.parse_tree_out_inst.
@@ -188,6 +189,10 @@ mercury_output_item_pragma(Info, ItemPragma, !IO) :-
mercury_output_pragma_decl(Pred, Arity, pf_predicate,
"no_determinism_warning", no, !IO)
;
+ Pragma = pragma_require_tail_recursion(RequireTailrecPragma),
+ mercury_output_pragma_require_tail_recursion(Lang,
+ RequireTailrecPragma, !IO)
+ ;
Pragma = pragma_tabled(TabledInfo),
mercury_output_pragma_tabled(TabledInfo, !IO)
;
@@ -1144,6 +1149,68 @@ mercury_output_pragma_mm_tabling_info(TablingInfo, !IO) :-
%---------------------------------------------------------------------------%
%
+% Output a require tail recursion pragma
+%
+
+:- pred mercury_output_pragma_require_tail_recursion(output_lang::in,
+ pragma_info_require_tail_recursion::in, io::di, io::uo) is det.
+
+mercury_output_pragma_require_tail_recursion(Lang, RequireTR, !IO) :-
+ RequireTR = pragma_info_require_tail_recursion(Proc, Info),
+ ProcSpecStr = format_pred_name_arity_mpf_mmode(Lang, Proc),
+
+ (
+ Info = suppress_tailrec_warnings(_),
+ format(":- pragma warn_tail_recursion(%s, [none]).\n",
+ [s(ProcSpecStr)], !IO)
+ ;
+ Info = enable_tailrec_warnings(WarnOrError, Type, _),
+ warning_or_error_string(WarnOrError, WarnOrErrorStr),
+ require_tailrec_type_string(Type, TypeStr),
+
+ format(":- pragma warn_tail_recursion(%s, [%s, %s]).\n",
+ [s(ProcSpecStr), s(WarnOrErrorStr), s(TypeStr)], !IO)
+ ).
+
+:- func format_pred_name_arity_mpf_mmode(output_lang,
+ pred_name_arity_mpf_mmode) = string.
+
+format_pred_name_arity_mpf_mmode(Lang, Proc) = ProcSpecStr :-
+ Proc = pred_name_arity_mpf_mmode(Pred, Arity, MaybePredOrFunc, MaybeMode),
+ (
+ MaybePredOrFunc = yes(PredOrFunc)
+ ;
+ MaybePredOrFunc = no,
+ PredOrFunc = pf_predicate
+ ),
+ (
+ MaybeMode = no,
+ (
+ PredOrFunc = pf_predicate,
+ DeclaredArity = Arity
+ ;
+ PredOrFunc = pf_function,
+ DeclaredArity = Arity - 1
+ ),
+ ProcSpecStr = format("%s/%d",
+ [s(mercury_bracketed_sym_name_to_string(Pred)), i(DeclaredArity)])
+ ;
+ MaybeMode = yes(ModeList),
+ varset.init(InitVarSet),
+ (
+ PredOrFunc = pf_predicate,
+ ProcSpecStr = mercury_pred_mode_subdecl_to_string(Lang, InitVarSet,
+ Pred, ModeList, no)
+ ;
+ PredOrFunc = pf_function,
+ pred_args_to_func_args(ModeList, FuncModeList, RetMode),
+ ProcSpecStr = mercury_func_mode_subdecl_to_string(Lang,
+ InitVarSet, Pred, FuncModeList, RetMode, no)
+ )
+ ).
+
+%---------------------------------------------------------------------------%
+%
% Output a tabled pragma.
%
diff --git a/compiler/prog_data.m b/compiler/prog_data.m
index 8fa5126..46f1f0b 100644
--- a/compiler/prog_data.m
+++ b/compiler/prog_data.m
@@ -25,6 +25,7 @@
:- interface.
:- import_module libs.
+:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.rat.
:- import_module mdbcomp.
@@ -889,6 +890,36 @@ default_export_enum_attributes =
%---------------------------------------------------------------------------%
%
+% Require tail recursion pragma.
+%
+
+:- type require_tail_recursion
+ ---> suppress_tailrec_warnings(
+ rtrs_context :: prog_context
+ )
+ ; enable_tailrec_warnings(
+ rtre_warn_or_error :: warning_or_error,
+ rtre_recursion_type :: require_tail_recursion_type,
+ rtre_context :: prog_context
+ ).
+
+:- type require_tail_recursion_type
+ ---> require_direct_tail_recursion
+ ; require_any_tail_recursion.
+
+:- pred require_tailrec_type_string(require_tail_recursion_type, string).
+:- mode require_tailrec_type_string(in, out) is det.
+:- mode require_tailrec_type_string(out, in) is semidet.
+
+:- implementation.
+
+require_tailrec_type_string(require_direct_tail_recursion,
+ "self_recursion_only").
+require_tailrec_type_string(require_any_tail_recursion,
+ "self_or_mutual_recursion").
+
+%---------------------------------------------------------------------------%
+%
% Type classes.
%
diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m
index cc119fb..3f7e706 100644
--- a/compiler/prog_io_pragma.m
+++ b/compiler/prog_io_pragma.m
@@ -45,6 +45,7 @@
:- implementation.
+:- import_module libs.compiler_util.
:- import_module libs.rat.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.error_util.
@@ -232,6 +233,10 @@ parse_pragma_type(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms,
"predicate or function", MakePragma, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeIOM)
;
+ PragmaName = "require_tail_recursion",
+ parse_pragma_require_tail_recursion(ModuleName, PragmaTerms,
+ ErrorTerm, VarSet, Context, SeqNum, MaybeIOM)
+ ;
PragmaName = "reserve_tag",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
TypeCtor = type_ctor(Name, Arity),
@@ -977,6 +982,236 @@ parse_pragma_external_options(VarSet, MaybeOptionsTerm, ContextPieces,
%----------------------------------------------------------------------------%
+:- pred parse_pragma_require_tail_recursion(module_name::in, list(term)::in,
+ term::in, varset::in, prog_context::in, int::in,
+ maybe1(item_or_marker)::out) is det.
+
+parse_pragma_require_tail_recursion(ModuleName, PragmaTerms, _ErrorTerm,
+ VarSet, Context, SeqNum, MaybeIOM) :-
+ PragmaName = "require_tail_recursion",
+ ( if
+ (
+ PragmaTerms = [PredAndModesTerm, OptionsTermPrime],
+ MaybeOptionsTerm = yes(OptionsTermPrime)
+ ;
+ PragmaTerms = [PredAndModesTerm],
+ MaybeOptionsTerm = no
+ )
+ then
+ % Parse the procedure name.
+ ContextPieces = cord.from_list([words("In"),
+ pragma_decl(PragmaName), words("declaration:")]),
+ parse_arity_or_modes(ModuleName, PredAndModesTerm,
+ PredAndModesTerm, VarSet, ContextPieces, MaybeProc),
+
+ % Parse the options
+ (
+ MaybeOptionsTerm = yes(OptionsTerm),
+ ( if list_term_to_term_list(OptionsTerm, OptionsTerms)
+ then
+ parse_pragma_require_tail_recursion_options(OptionsTerms,
+ have_not_seen_none, no, no, [], Context, MaybeOptions)
+ else
+ OptionsContext = get_term_context(OptionsTerm),
+ Pieces1 = [words("Error: expected attribute list for"),
+ pragma_decl("require_tail_recursion"),
+ words("declaration, not"),
+ quote(describe_error_term(VarSet, OptionsTerm)),
+ suffix("."), nl],
+ Message1 = simple_msg(OptionsContext, [always(Pieces1)]),
+ MaybeOptions = error1([error_spec(severity_error,
+ phase_term_to_parse_tree, [Message1])])
+ )
+ ;
+ MaybeOptionsTerm = no,
+ MaybeOptions = ok1(enable_tailrec_warnings(we_warning,
+ require_any_tail_recursion, Context))
+ ),
+
+ % Put them together.
+ (
+ MaybeProc = ok1(Proc),
+ (
+ MaybeOptions = ok1(RequireTailrecInfo),
+ PragmaType = pragma_require_tail_recursion(
+ pragma_info_require_tail_recursion(Proc,
+ RequireTailrecInfo)),
+ MaybeIOM = ok1(iom_item(item_pragma(
+ item_pragma_info(PragmaType, item_origin_user, Context,
+ SeqNum))))
+ ;
+ MaybeOptions = error1(Errors),
+ MaybeIOM = error1(Errors)
+ )
+ ;
+ MaybeProc = error1(ProcErrors),
+ (
+ MaybeOptions = ok1(_),
+ MaybeIOM = error1(ProcErrors)
+ ;
+ MaybeOptions = error1(OptionsErrors),
+ MaybeIOM = error1(ProcErrors ++ OptionsErrors)
+ )
+ )
+ else
+ Pieces = [words("Error: wrong number of arguments in"),
+ pragma_decl(PragmaName), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeIOM = error1([Spec])
+ ).
+
+:- type seen_none
+ ---> seen_none
+ ; have_not_seen_none.
+
+:- pred parse_pragma_require_tail_recursion_options(list(term)::in,
+ seen_none::in, maybe(warning_or_error)::in,
+ maybe(require_tail_recursion_type)::in, list(error_spec)::in,
+ prog_context::in, maybe1(require_tail_recursion)::out) is det.
+
+parse_pragma_require_tail_recursion_options([], SeenNone, MaybeWarnOrError,
+ MaybeType, !.Specs, Context, MaybeRTR) :-
+ (
+ SeenNone = seen_none,
+ % Check for conflicts with "none" option.
+ (
+ MaybeWarnOrError = yes(WarnOrError0),
+ warning_or_error_string(WarnOrError0, WarnOrErrorString),
+ SpecA = conflicting_attributes_error("none", WarnOrErrorString,
+ Context),
+ !:Specs = [SpecA | !.Specs]
+ ;
+ MaybeWarnOrError = no
+ ),
+ (
+ MaybeType = yes(Type0),
+ require_tailrec_type_string(Type0, TypeString),
+ SpecB = conflicting_attributes_error("none", TypeString,
+ Context),
+ !:Specs = [SpecB | !.Specs]
+ ;
+ MaybeType = no
+ )
+ ;
+ SeenNone = have_not_seen_none
+ ),
+ (
+ !.Specs = [_ | _],
+ MaybeRTR = error1(!.Specs)
+ ;
+ !.Specs = [],
+ (
+ SeenNone = seen_none,
+ MaybeRTR = ok1(suppress_tailrec_warnings(Context))
+ ;
+ SeenNone = have_not_seen_none,
+ % If these values were not set then use the defaults.
+ (
+ MaybeWarnOrError = yes(WarnOrError)
+ ;
+ MaybeWarnOrError = no,
+ WarnOrError = we_warning
+ ),
+ (
+ MaybeType = yes(Type)
+ ;
+ MaybeType = no,
+ Type = require_any_tail_recursion
+ ),
+ MaybeRTR = ok1(enable_tailrec_warnings(WarnOrError, Type,
+ Context))
+ )
+ ).
+parse_pragma_require_tail_recursion_options([Term | Terms], SeenNone0,
+ MaybeWarnOrError0, MaybeType0, !.Specs, PragmaContext, MaybeRTR) :-
+ (
+ Term = functor(Functor, _Args, Context),
+ ( if
+ Functor = atom(Name),
+ warning_or_error_string(WarnOrError, Name)
+ then
+ (
+ MaybeWarnOrError0 = no,
+ MaybeWarnOrError = yes(WarnOrError)
+ ;
+ MaybeWarnOrError0 = yes(WarnOrErrorFirst),
+ warning_or_error_string(WarnOrErrorFirst,
+ WarnOrErrorFirstString),
+ Spec = conflicting_attributes_error(Name,
+ WarnOrErrorFirstString, Context),
+ MaybeWarnOrError = MaybeWarnOrError0,
+ !:Specs = [Spec | !.Specs]
+ ),
+ MaybeType = MaybeType0,
+ SeenNone = SeenNone0
+ else if
+ Functor = atom(Name),
+ require_tailrec_type_string(Type, Name)
+ then
+ (
+ MaybeType0 = no,
+ MaybeType = yes(Type)
+ ;
+ MaybeType0 = yes(TypeFirst),
+ require_tailrec_type_string(TypeFirst, TypeFirstString),
+ Spec = conflicting_attributes_error(Name,
+ TypeFirstString, Context),
+ MaybeType = MaybeType0,
+ !:Specs = [Spec | !.Specs]
+ ),
+ MaybeWarnOrError = MaybeWarnOrError0,
+ SeenNone = SeenNone0
+ else if
+ Functor = atom("none")
+ then
+ SeenNone = seen_none,
+ MaybeWarnOrError = MaybeWarnOrError0,
+ MaybeType = MaybeType0
+ else
+ Spec = pragma_require_tailrec_unknown_term_error(Term, Context),
+ !:Specs = [Spec | !.Specs],
+ SeenNone = SeenNone0,
+ MaybeType = MaybeType0,
+ MaybeWarnOrError = MaybeWarnOrError0
+ )
+ ;
+ Term = variable(_, Context),
+ Spec = pragma_require_tailrec_unknown_term_error(Term, Context),
+ !:Specs = [Spec | !.Specs],
+ SeenNone = SeenNone0,
+ MaybeType = MaybeType0,
+ MaybeWarnOrError = MaybeWarnOrError0
+ ),
+ parse_pragma_require_tail_recursion_options(Terms, SeenNone,
+ MaybeWarnOrError, MaybeType, !.Specs, PragmaContext, MaybeRTR).
+
+:- func conflicting_attributes_error(string, string, prog_context) =
+ error_spec.
+
+conflicting_attributes_error(ThisName, EarlierName, Context) = ErrorSpec :-
+ Pieces = [words("Error: Conflicting "),
+ pragma_decl("require_tail_recursion"), words("attributes: "),
+ quote(ThisName), words("conflicts with earlier attribute"),
+ quote(EarlierName), suffix("."), nl],
+ Message = simple_msg(Context, [always(Pieces)]),
+ ErrorSpec = error_spec(severity_error,
+ phase_term_to_parse_tree, [Message]).
+
+:- func pragma_require_tailrec_unknown_term_error(term, prog_context) =
+ error_spec.
+
+pragma_require_tailrec_unknown_term_error(Term, Context) = ErrorSpec :-
+ varset.init(VarSet),
+ Pieces = [words("Error: unrecognised "),
+ pragma_decl("require_tail_recursion"), words("attribute: "),
+ quote(describe_error_term(VarSet, Term)), suffix("."), nl],
+ Message = simple_msg(Context, [always(Pieces)]),
+ ErrorSpec = error_spec(severity_error,
+ phase_term_to_parse_tree, [Message]).
+
+%----------------------------------------------------------------------------%
+
:- pred parse_pragma_unused_args(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
@@ -1045,8 +1280,8 @@ parse_pragma_type_spec(ModuleName, VarSet, ErrorTerm, PragmaTerms,
VarSet, ArityOrModesContextPieces, MaybeArityOrModes),
(
MaybeArityOrModes = ok1(ArityOrModes),
- ArityOrModes = arity_or_modes(PredName, Arity, MaybePredOrFunc,
- MaybeModes),
+ ArityOrModes = pred_name_arity_mpf_mmode(PredName, Arity,
+ MaybePredOrFunc, MaybeModes),
conjunction_to_list(TypeSubnTerm, TypeSubnTerms),
% The varset is actually a tvarset.
@@ -2611,8 +2846,8 @@ parse_tabling_pragma(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms,
VarSet, ContextPieces, MaybeArityOrModes),
(
MaybeArityOrModes = ok1(ArityOrModes),
- ArityOrModes = arity_or_modes(PredName, Arity, MaybePredOrFunc,
- MaybeModes),
+ ArityOrModes = pred_name_arity_mpf_mmode(PredName, Arity,
+ MaybePredOrFunc, MaybeModes),
(
MaybeAttrs = no,
PredNameArityMPF = pred_name_arity_mpf(PredName, Arity,
@@ -2882,16 +3117,8 @@ parse_arg_tabling_method(term.functor(term.atom("promise_implied"), [], _),
yes(arg_promise_implied)).
parse_arg_tabling_method(term.functor(term.atom("output"), [], _), no).
-:- type arity_or_modes
- ---> arity_or_modes(
- sym_name,
- arity,
- maybe(pred_or_func),
- maybe(list(mer_mode))
- ).
-
:- pred parse_arity_or_modes(module_name::in, term::in, term::in, varset::in,
- cord(format_component)::in, maybe1(arity_or_modes)::out) is det.
+ cord(format_component)::in, maybe1(pred_name_arity_mpf_mmode)::out) is det.
parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm, VarSet,
ContextPieces, MaybeArityOrModes) :-
@@ -2905,7 +3132,8 @@ parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm, VarSet,
PredNameTerm, PredName),
ArityTerm = term.functor(term.integer(Arity), [], _)
then
- MaybeArityOrModes = ok1(arity_or_modes(PredName, Arity, no, no))
+ MaybeArityOrModes = ok1(pred_name_arity_mpf_mmode(PredName,
+ Arity, no, no))
else
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
words("Error: expected predname/arity."), nl],
@@ -2926,8 +3154,8 @@ parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm, VarSet,
PredOrFunc = pf_predicate,
Arity = Arity0
),
- ArityOrModes = arity_or_modes(PredName, Arity, yes(PredOrFunc),
- yes(Modes)),
+ ArityOrModes = pred_name_arity_mpf_mmode(PredName, Arity,
+ yes(PredOrFunc), yes(Modes)),
MaybeArityOrModes = ok1(ArityOrModes)
;
MaybePredAndModes = error2(Specs),
diff --git a/compiler/prog_item.m b/compiler/prog_item.m
index d2ab849..f0f8d77 100644
--- a/compiler/prog_item.m
+++ b/compiler/prog_item.m
@@ -792,6 +792,7 @@
; pragma_mm_tabling_info(pragma_info_mm_tabling_info)
; pragma_obsolete(pred_name_arity)
; pragma_no_detism_warning(pred_name_arity)
+ ; pragma_require_tail_recursion(pragma_info_require_tail_recursion)
; pragma_tabled(pragma_info_tabled)
; pragma_fact_table(pragma_info_fact_table)
; pragma_reserve_tag(type_ctor)
@@ -944,6 +945,21 @@
mm_tabling_info_status :: mm_tabling_status
).
+:- type pragma_info_require_tail_recursion
+ ---> pragma_info_require_tail_recursion(
+ rtr_proc_id :: pred_name_arity_mpf_mmode,
+ rtr_require_tailrec :: require_tail_recursion
+
+ % This parameter only makes sense when options contains
+ % either rtro_mutual_rec_only or rtro_all_recursion.
+ % TODO, currently unused, may be used later to implement one
+ % of Zoltan's suggestions here:
+ % http://www.mercurylang.org/list-archives/developers/
+ % 2015-November/016482.html
+ % rtr_maybe_scc :: maybe(list(
+ % pred_name_arity_mpf_mmode))
+ ).
+
% Evaluation method pragmas.
:- type pragma_info_tabled
@@ -1058,6 +1074,14 @@
pnapm_mode_num :: mode_num
).
+:- type pred_name_arity_mpf_mmode
+ ---> pred_name_arity_mpf_mmode(
+ pnampm_pred_name :: sym_name,
+ pnampm_arity :: arity,
+ pnampm_maybe_pf :: maybe(pred_or_func),
+ pnampm_maybe_mode :: maybe(list(mer_mode))
+ ).
+
:- type pred_name_modes_pf
---> pred_name_modes_pf(
pnmp_pred_name :: sym_name,
@@ -1530,6 +1554,7 @@ pragma_allowed_in_interface(Pragma) = Allowed :-
; Pragma = pragma_inline(_)
; Pragma = pragma_no_inline(_)
; Pragma = pragma_no_detism_warning(_)
+ ; Pragma = pragma_require_tail_recursion(_)
; Pragma = pragma_fact_table(_)
; Pragma = pragma_tabled(_)
; Pragma = pragma_promise_pure(_)
@@ -1607,6 +1632,10 @@ pragma_context_pieces(Pragma) = ContextPieces :-
ContextPieces = [pragma_decl("no_determinism_warning"),
words("declaration")]
;
+ Pragma = pragma_require_tail_recursion(_),
+ ContextPieces = [pragma_decl("require_tail_recursion"),
+ words("declaration")]
+ ;
Pragma = pragma_fact_table(_),
ContextPieces = [pragma_decl("fact_table"), words("declaration")]
;
@@ -1924,6 +1953,7 @@ get_pragma_foreign_code(Globals, Pragma, !Info) :-
; Pragma = pragma_promise_pure(_)
; Pragma = pragma_promise_semipure(_)
; Pragma = pragma_require_feature_set(_)
+ ; Pragma = pragma_require_tail_recursion(_)
; Pragma = pragma_reserve_tag(_)
; Pragma = pragma_structure_reuse(_)
; Pragma = pragma_structure_sharing(_)
diff --git a/compiler/prog_item_stats.m b/compiler/prog_item_stats.m
index 080c9da..603ee9c 100644
--- a/compiler/prog_item_stats.m
+++ b/compiler/prog_item_stats.m
@@ -323,6 +323,7 @@ gather_stats_in_item_pragma(ItemPragmaInfo, !ItemStats) :-
; PragmaType = pragma_check_termination(_)
; PragmaType = pragma_mode_check_clauses(_)
; PragmaType = pragma_require_feature_set(_)
+ ; PragmaType = pragma_require_tail_recursion(_)
),
!ItemStats ^ item_num_pragma_other_pass_2 :=
!.ItemStats ^ item_num_pragma_other_pass_2 + 1
diff --git a/compiler/recompilation.version.m b/compiler/recompilation.version.m
index e13e408..ef45fe7 100644
--- a/compiler/recompilation.version.m
+++ b/compiler/recompilation.version.m
@@ -622,6 +622,7 @@ is_pred_pragma(PragmaType, MaybePredOrFuncId) :-
; PragmaType = pragma_reserve_tag(_)
; PragmaType = pragma_oisu(_) % XXX
; PragmaType = pragma_require_feature_set(_)
+ ; PragmaType = pragma_require_tail_recursion(_)
),
MaybePredOrFuncId = no
;
diff --git a/compiler/write_module_interface_files.m b/compiler/write_module_interface_files.m
index b37c373..26bcc94 100644
--- a/compiler/write_module_interface_files.m
+++ b/compiler/write_module_interface_files.m
@@ -2074,6 +2074,7 @@ classify_items([Item | Items], !TypeDefnMap, !InstDefnMap, !ModeDefnMap,
; Pragma = pragma_structure_reuse(_)
; Pragma = pragma_require_feature_set(_)
; Pragma = pragma_foreign_import_module(_)
+ ; Pragma = pragma_require_tail_recursion(_)
),
set.insert(Item, !SortableItems)
;
diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi
index c8063a1..f744a01 100644
--- a/doc/reference_manual.texi
+++ b/doc/reference_manual.texi
@@ -9872,6 +9872,7 @@ extensions to the Mercury language:
calculated results and detecting or avoiding
certain kinds of infinite loops.
* Termination analysis:: Support for automatic proofs of termination.
+ at c * Tail recursion check:: Require that a predicate is tail recursive.
* Feature sets:: Support for checking that optional features of
the implementation are supported at compile
time.
@@ -10468,6 +10469,105 @@ function then the compiler will quit with an error message.
@c The compiler includes a structure reuse analysis system.
@c
+ at c @node Tail recursion check
+ at c @section Tail recursion check
+ at c
+ at c The @samp{require_tail_recursion} pragma can be used to enable and disable
+ at c warnings or errors for predicates and functions that contain recursive
+ at c calls which are not @emph{tail} recursive.
+ at c
+ at c @example
+ at c :- pragma require_tail_recursion(@var{Name}/@var{Arity}, @var{Options}).
+ at c :- pragma require_tail_recursion(@var{Name}(@var{Modes}), @var{Options}).
+ at c :- pragma require_tail_recursion(@var{Name}(@var{Modes}) = @var{ReturnMode},
+ at c @var{Options}).
+ at c @end example
+ at c
+ at c This pragma affects all modes of a predicate or function (in the first form)
+ at c or a specific mode of a predicate or function (the second and third forms).
+ at c These pragmas can be used to enable or inhibit warnings for non tail
+ at c recursive code.
+ at c
+ at c When tail recursion warnings are enabled using the
+ at c @samp{--warn-non-tail-recursion} compiler option (see the user's guide),
+ at c the compiler may emit warnings for predicates that the developer knows and
+ at c accepts aren't tail recursive.
+ at c These can be suppressed using the @samp{none} option in the
+ at c @samp{require_tail_recursion} pragma.
+ at c
+ at c @example
+ at c :- pragma require_tail_recursion(foo/3, [none]).
+ at c @end example
+ at c
+ at c When the @samp{--warn-non-tail-recursion} compiler option is not enabled
+ at c then the pragma can be used to explicitly enable the tail recursion check
+ at c for a predicate or function.
+ at c If you think that a predicate or function will probably recurse deeply,
+ at c and may exhaust the stack unless its recursive calls are all tail recursive,
+ at c then use this pragma on that predicate
+ at c to get a warning or an error
+ at c if any of those recursive calls are not tail recursive.
+ at c You may also wish to enable this warning
+ at c if you expect the predicate or function to be called many times,
+ at c even if those calls are very unlikely to exhaust the stack,
+ at c simply because tail recursion is more efficient than non-tail recursion.
+ at c
+ at c @example
+ at c :- pragma require_tail_recursion(map/3).
+ at c @end example
+ at c
+ at c The following options may be given:
+ at c
+ at c @table @code
+ at c
+ at c @item warn
+ at c Non tail recursive code should generate a compiler warning.
+ at c This is the default.
+ at c This option is incompatible with @samp{error} and @samp{none}.
+ at c
+ at c @item error
+ at c Non tail recursive code should generate a compiler error.
+ at c This option is incompatible with @samp{warn} and @samp{none}.
+ at c
+ at c @item none
+ at c Disable the tail recursion check for this predicate or function.
+ at c This option is incompatible with every other option.
+ at c
+ at c @item self_or_mutual_recursion
+ at c Allow the recursive calls to be self or mutually recursive.
+ at c The compiler will generate warnings or errors for recursive calls that are
+ at c not tail calls (and not later followed by a recursive call that @emph{is} a
+ at c tail call).
+ at c This is the default.
+ at c This option is incompatible with @samp{self_recursion_only} and @samp{none}.
+ at c
+ at c @item self_recursion_only
+ at c Require that all recursive calls are self-recursive.
+ at c In addition to @code{self_or_mutual_recursion},
+ at c this option causes the compiler to generate a warning or error
+ at c when a mutually recursive call is a @emph{tail} call, even if it can
+ at c optimize the tail call.
+ at c Some backends can optimize self recursion but not mutual recursion,
+ at c or mutual recursion is less efficient.
+ at c This option can be used to alert the programmer of code that isn't tail
+ at c recursive on these backends.
+ at c This option is incompatible with @samp{self_or_mutual_recursion} and
+ at c @samp{none}.
+ at c
+ at c @end table
+ at c
+ at c Note that the compiler cannot analyse recursion across module boundaries
+ at c or through higher order calls.
+ at c Therefore inter-module and higher order calls are considered to be
+ at c non-recursive.
+ at c
+ at c This pragma has no effect with @samp{--no-optimize-tailcalls}.
+ at c It also has no effect when generating Erlang code,
+ at c because the Erlang implementation itself implements last call optimisation.
+ at c
+ at c Issuing the pragma more than once for the same predicate or function, or a
+ at c mode off that predicate or function, will cause undefined behaviour.
+
@node Feature sets
@section Feature sets
diff --git a/tests/invalid/Mercury.options b/tests/invalid/Mercury.options
index bc0b0b3..c6d0ded 100644
--- a/tests/invalid/Mercury.options
+++ b/tests/invalid/Mercury.options
@@ -116,6 +116,9 @@ MCFLAGS-one_member = --verbose-error-messages
MCFLAGS-polymorphic_unification = --verbose-error-messages
MCFLAGS-predmode = --verbose-error-messages
MCFLAGS-prog_io_erroneous = --verbose-error-messages
+
+MCFLAGS-require_tail_recursion = --allow-stubs --no-warn-stubs
+
# We compile test_feature_set in hl.gc because that grade is incompatible
# with the features in the test require_feature_set pragma.
MCFLAGS-test_feature_set = --grade hl.gc --verbose-error-messages
diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile
index 8ce454a..0710db3 100644
--- a/tests/invalid/Mmakefile
+++ b/tests/invalid/Mmakefile
@@ -217,6 +217,7 @@ SINGLEMODULE= \
repeated_instance_vars_unsat \
require_det_in_lambda \
require_scopes \
+ require_tail_recursion \
reserved \
some \
specified \
diff --git a/tests/invalid/require_tail_recursion.err_exp b/tests/invalid/require_tail_recursion.err_exp
new file mode 100644
index 0000000..29607b8
--- /dev/null
+++ b/tests/invalid/require_tail_recursion.err_exp
@@ -0,0 +1,86 @@
+require_tail_recursion.m:014: Error: `:- pragma require_tail_recursion'
+require_tail_recursion.m:014: declaration in module interface.
+require_tail_recursion.m:021: Error: `:- pragma require_tail_recursion' pragma
+require_tail_recursion.m:021: for
+require_tail_recursion.m:021: `require_tail_recursion.non_existant_pred'/3
+require_tail_recursion.m:021: without corresponding `:- pred' or `:- func'
+require_tail_recursion.m:021: declaration.
+require_tail_recursion.m:022: Error: `:- pragma require_tail_recursion' pragma
+require_tail_recursion.m:022: for
+require_tail_recursion.m:022: `require_tail_recursion.non_existant_proc'/2
+require_tail_recursion.m:022: without corresponding `:- pred' or `:- func'
+require_tail_recursion.m:022: declaration.
+require_tail_recursion.m:023: Error: `:- pragma require_tail_recursion' pragma
+require_tail_recursion.m:023: for
+require_tail_recursion.m:023: `require_tail_recursion.non_existant_func_proc'/1
+require_tail_recursion.m:023: without corresponding `:- pred' or `:- func'
+require_tail_recursion.m:023: declaration.
+require_tail_recursion.m:026: Error: no such mode for
+require_tail_recursion.m:026: `require_tail_recursion.length'/2 in
+require_tail_recursion.m:026: `:- pragma require_tail_recursion' pragma.
+require_tail_recursion.m:029: Error: Conflicting
+require_tail_recursion.m:029: `:- pragma require_tail_recursion' attributes:
+require_tail_recursion.m:029: `error' conflicts with earlier attribute
+require_tail_recursion.m:029: `warn'.
+require_tail_recursion.m:032: Error: Conflicting
+require_tail_recursion.m:032: `:- pragma require_tail_recursion' attributes:
+require_tail_recursion.m:032: `none' conflicts with earlier attribute `warn'.
+require_tail_recursion.m:035: Error: Conflicting
+require_tail_recursion.m:035: `:- pragma require_tail_recursion' attributes:
+require_tail_recursion.m:035: `none' conflicts with earlier attribute
+require_tail_recursion.m:035: `error'.
+require_tail_recursion.m:039: Error: Conflicting
+require_tail_recursion.m:039: `:- pragma require_tail_recursion' attributes:
+require_tail_recursion.m:039: `self_recursion_only' conflicts with earlier
+require_tail_recursion.m:039: attribute `self_or_mutual_recursion'.
+require_tail_recursion.m:042: Error: Conflicting
+require_tail_recursion.m:042: `:- pragma require_tail_recursion' attributes:
+require_tail_recursion.m:042: `none' conflicts with earlier attribute
+require_tail_recursion.m:042: `self_or_mutual_recursion'.
+require_tail_recursion.m:046: Error: Conflicting
+require_tail_recursion.m:046: `:- pragma require_tail_recursion' attributes:
+require_tail_recursion.m:046: `none' conflicts with earlier attribute
+require_tail_recursion.m:046: `self_recursion_only'.
+require_tail_recursion.m:050: Error: unrecognised
+require_tail_recursion.m:050: `:- pragma require_tail_recursion' attribute:
+require_tail_recursion.m:050: `blahblahblah'.
+require_tail_recursion.m:054: Error: `:- pragma require_tail_recursion' pragma
+require_tail_recursion.m:054: for `require_tail_recursion.blahblahblah'/0
+require_tail_recursion.m:054: without corresponding `:- pred' or `:- func'
+require_tail_recursion.m:054: declaration.
+require_tail_recursion.m:056: Error: expected attribute list for
+require_tail_recursion.m:056: `:- pragma require_tail_recursion' declaration,
+require_tail_recursion.m:056: not `Woop'.
+require_tail_recursion.m:059: Error: expected attribute list for
+require_tail_recursion.m:059: `:- pragma require_tail_recursion' declaration,
+require_tail_recursion.m:059: not `23'.
+require_tail_recursion.m:066: Error: Conflicting
+require_tail_recursion.m:066: `:- pragma require_tail_recursion' attributes:
+require_tail_recursion.m:066: `none' conflicts with earlier attribute
+require_tail_recursion.m:066: `self_recursion_only'.
+require_tail_recursion.m:066: Error: Conflicting
+require_tail_recursion.m:066: `:- pragma require_tail_recursion' attributes:
+require_tail_recursion.m:066: `none' conflicts with earlier attribute `warn'.
+require_tail_recursion.m:067: Error: unrecognised
+require_tail_recursion.m:067: `:- pragma require_tail_recursion' attribute:
+require_tail_recursion.m:067: `grasshopper'.
+require_tail_recursion.m:072: Error: conflicting
+require_tail_recursion.m:072: `:- pragma require_tail_recursion' pragmas for
+require_tail_recursion.m:072: `require_tail_recursion.length10'/2 or one of
+require_tail_recursion.m:072: its modes.
+require_tail_recursion.m:070: Earlier pragma is here.
+require_tail_recursion.m:075: Error: conflicting
+require_tail_recursion.m:075: `:- pragma require_tail_recursion' pragmas for
+require_tail_recursion.m:075: `require_tail_recursion.length10'/2 or one of
+require_tail_recursion.m:075: its modes.
+require_tail_recursion.m:070: Earlier pragma is here.
+require_tail_recursion.m:089: Error: conflicting
+require_tail_recursion.m:089: `:- pragma require_tail_recursion' pragmas for
+require_tail_recursion.m:089: `require_tail_recursion.append'/3 or one of its
+require_tail_recursion.m:089: modes.
+require_tail_recursion.m:087: Earlier pragma is here.
+require_tail_recursion.m:089: Error: conflicting
+require_tail_recursion.m:089: `:- pragma require_tail_recursion' pragmas for
+require_tail_recursion.m:089: `require_tail_recursion.append'/3 or one of its
+require_tail_recursion.m:089: modes.
+require_tail_recursion.m:088: Earlier pragma is here.
diff --git a/tests/invalid/require_tail_recursion.m b/tests/invalid/require_tail_recursion.m
new file mode 100644
index 0000000..0e80d11
--- /dev/null
+++ b/tests/invalid/require_tail_recursion.m
@@ -0,0 +1,90 @@
+%
+% This test case tests for invalid uses of the require_tail_recursion
+% pragma. It does not test the use of this pragma on a non tail recursive
+% predicate or function, that will be tested separately.
+
+:- module require_tail_recursion.
+
+:- interface.
+
+:- import_module list.
+:- import_module int.
+
+% The pragma shouldn't be allowed in the interface
+:- pragma require_tail_recursion(length/2, [warn]).
+
+:- pred length(list(T)::in, int::out) is det.
+
+:- implementation.
+
+% The pragma used with an non-existant predicate or function.
+:- pragma require_tail_recursion(non_existant_pred/3, [warn]).
+:- pragma require_tail_recursion(non_existant_proc(in, out), [error]).
+:- pragma require_tail_recursion(non_existant_func_proc(in) = out, [error]).
+
+% or with a non existent mode of a predicate that does exist.
+:- pragma require_tail_recursion(length(out, in), [self_recursion_only]).
+
+% conflicting options.
+:- pragma require_tail_recursion(length1/2, [warn, error]).
+:- pred length1(list(T)::in, int::out) is det.
+
+:- pragma require_tail_recursion(length2/2, [warn, none]).
+:- pred length2(list(T)::in, int::out) is det.
+
+:- pragma require_tail_recursion(length3/2, [error, none]).
+:- pred length3(list(T)::in, int::out) is det.
+
+:- pragma require_tail_recursion(length4/2, [self_or_mutual_recursion,
+ self_recursion_only]).
+:- pred length4(list(T)::in, int::out) is det.
+
+:- pragma require_tail_recursion(length5/2, [self_or_mutual_recursion,
+ none]).
+:- pred length5(list(T)::in, int::out) is det.
+
+:- pragma require_tail_recursion(length6/2, [self_recursion_only, none]).
+:- pred length6(list(T)::in, int::out) is det.
+
+% malformed arguments / options.
+:- pragma require_tail_recursion(length7/2, [blahblahblah]).
+:- pred length7(list(T)::in, int::out) is det.
+
+% This gets read as a 0-arity predicate, that is then non-existent.
+:- pragma require_tail_recursion(blahblahblah).
+
+:- pragma require_tail_recursion(length8/2, Woop).
+:- pred length8(list(T)::in, int::out) is det.
+
+:- pragma require_tail_recursion(length9/2, 23).
+:- pred length9(list(T)::in, int::out) is det.
+
+% Multiple problems, this tests that each problem is reported, not just the
+% first. However the non-existent pred/proc is not checked until
+% add_pragma.m, but this predicate is rejected earlier (prog_io_pragma.m)
+% due to the bad attribute list.
+:- pragma require_tail_recursion(length_nonexistent/3, [none, warn,
+ self_recursion_only, grasshopper]).
+
+% Multiple pragmas for the same predicate.
+:- pragma require_tail_recursion(length10/2, [warn,
+ self_or_mutual_recursion]).
+:- pragma require_tail_recursion(length10/2, [error,
+ self_recursion_only]).
+% Even the same options applied multiple times should cause an error.
+:- pragma require_tail_recursion(length10/2, [error,
+ self_recursion_only]).
+
+:- pred length10(list(T)::in, int::out) is det.
+
+% Multiple definitions for the same mode of a predicate.
+
+:- pred append(list(T), list(T), list(T)).
+:- mode append(in, in, out) is det.
+:- mode append(out, out, in) is multi.
+:- mode append(in, in, in) is semidet.
+
+:- pragma require_tail_recursion(append(in, in, out), [warn]).
+:- pragma require_tail_recursion(append(in, in, in), [warn]).
+:- pragma require_tail_recursion(append/3, [warn]). % error should be here.
+
--
2.6.2
More information about the reviews
mailing list