[m-rev.] for review: Add new require_tail_recursion pragma.
Paul Bone
paul at bone.id.au
Fri Nov 27 18:08:05 AEDT 2015
For review by Zoltan, he and I were discussing this on the mailing list.
---
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 relevent procedures. It does
not implement the pragma in any of the backends.
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_item.m:
Add new require_tail_recursion pragma.
compiler/prog_io_pragma.m:
Parse the new pragma.
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/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.
doc/reference_manual.texi
Document the require_tail_recursion pragma
---
compiler/add_pragma.m | 87 +++++++++++++++
compiler/comp_unit_interface.m | 1 +
compiler/compiler_util.m | 23 ++++
compiler/equiv_type.m | 1 +
compiler/get_dependencies.m | 1 +
compiler/hlds_pred.m | 31 +++++-
compiler/item_util.m | 1 +
compiler/make_hlds_separate_items.m | 1 +
compiler/module_qual.qual_errors.m | 3 +
compiler/module_qual.qualify_items.m | 1 +
compiler/parse_tree_out_pragma.m | 61 +++++++++++
compiler/prog_io_pragma.m | 187 ++++++++++++++++++++++++++++++++
compiler/prog_item.m | 46 ++++++++
compiler/prog_item_stats.m | 1 +
compiler/recompilation.version.m | 1 +
compiler/write_module_interface_files.m | 1 +
doc/reference_manual.texi | 76 +++++++++++++
17 files changed, 522 insertions(+), 1 deletion(-)
diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m
index ecc5cca..c395956 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,87 @@ 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("declration")],
+ undefined_pred_or_func_error(Name, Arity, Context, Pieces, !Specs)
+ ; PredIds = [PredId],
+ module_info_pred_info(!.ModuleInfo, PredId, Pred0),
+ pred_info_get_proc_table(Pred0, Procs0),
+ map.to_assoc_list(Procs0, Procs),
+ ( MaybeMode = yes(Mode),
+ % Choose the matching proc.
+ ( if
+ % 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
+ lookup(Procs0, ProcId, Proc),
+ add_pragma_require_tail_recursion_proc(Pragma, Context,
+ !.ModuleInfo, PredId, ProcId - Proc, Pred0, Pred,
+ !Specs)
+ else
+ Pieces = [words("Error: no such mode for"),
+ sym_name_and_arity(Name / Arity), words("in"),
+ pragma_decl("require_tail_recursion"),
+ words("declration.")],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ Pred = Pred0,
+ !:Specs = [Spec | !.Specs]
+ )
+ ; MaybeMode = no,
+ foldl2(add_pragma_require_tail_recursion_proc(Pragma, Context,
+ !.ModuleInfo, PredId), Procs, Pred0, Pred, !Specs)
+ ),
+ module_info_set_pred_info(PredId, Pred, !ModuleInfo)
+ ; PredIds = [_, _ | _],
+ Pieces = [words("Error: ambigious predicate or function in"),
+ pragma_decl("require_tail_recursion"), words("declration.")],
+ 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(
+ pragma_info_require_tail_recursion::in, prog_context::in,
+ module_info::in, pred_id::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(Pragma, _Context, _ModuleInfo, _PredId,
+ ProcId - Proc0, !PredInfo, !Specs) :-
+ WarnOrError = Pragma ^ rtr_warning_or_error,
+ Option = Pragma ^ rtr_options,
+ (
+ Option = rtro_none,
+ RequireTailrec = suppress_tailrec_warnings
+ ;
+ (
+ Option = rtro_self_rec_only,
+ Type = require_direct_tail_recursion
+ ;
+ Option = rtro_any_recursion,
+ Type = require_any_tail_recursion
+ ),
+ RequireTailrec = enable_tailrec_warnings(WarnOrError, Type)
+ ),
+ proc_info_set_require_tailrec_info(RequireTailrec, Proc0, Proc),
+ pred_info_set_proc_info(ProcId, Proc, !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..16df7a1 100644
--- a/compiler/compiler_util.m
+++ b/compiler/compiler_util.m
@@ -22,6 +22,24 @@
:- 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.
%-----------------------------------------------------------------------------%
@@ -61,6 +79,11 @@
%-----------------------------------------------------------------------------%
+warning_or_error_string(we_warning, "warn").
+warning_or_error_string(we_error, "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 71e48c1..fbc3398 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 9c3eaad..12050bb 100644
--- a/compiler/get_dependencies.m
+++ b/compiler/get_dependencies.m
@@ -462,6 +462,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 0c15598..8e2c38d 100644
--- a/compiler/hlds_pred.m
+++ b/compiler/hlds_pred.m
@@ -33,6 +33,7 @@
:- import_module hlds.status.
:- import_module hlds.vartypes.
:- import_module libs.
+:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module mdbcomp.
:- import_module mdbcomp.goal_path.
@@ -2117,6 +2118,17 @@ attribute_list_to_attributes(Attributes, AttributeSet) :-
; oisu_mutator_for(type_ctor)
; oisu_destructor_for(type_ctor).
+:- type require_tailrec_info
+ ---> suppress_tailrec_warnings
+ ; enable_tailrec_warnings(
+ rtr_warn_or_error :: warning_or_error,
+ rtr_recursion_type :: require_tail_recursion_type
+ ).
+
+:- type require_tail_recursion_type
+ ---> require_direct_tail_recursion
+ ; require_any_tail_recursion.
+
% Is a procedure the subject of any foreign_export pragmas?
%
:- type proc_foreign_exports
@@ -2197,6 +2209,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_tailrec_info)::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,
@@ -2279,6 +2293,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_tailrec_info::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,
@@ -2597,6 +2613,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_tailrec_info),
+
%-----------------------------------------------------------%
% Information needed by the LLDS code generator.
%-----------------------------------------------------------%
@@ -2836,6 +2857,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),
@@ -2857,7 +2879,7 @@ proc_info_init(MainContext, Arity, Types, DeclaredModes, Modes, MaybeArgLives,
ProcSubInfo = proc_sub_info(
MainContext,
- CanProcess,
+ CanProcess,
DetismDecl,
MaybeUntupleInfo,
VarNameRemap,
@@ -2868,6 +2890,7 @@ proc_info_init(MainContext, Arity, Types, DeclaredModes, Modes, MaybeArgLives,
HasUserEvent,
HasTailCallEvent,
OisuKinds,
+ MaybeRequireTailRecursion,
RegR_HeadVars,
MaybeArgPassInfo,
MaybeSpecialReturn,
@@ -2958,6 +2981,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),
@@ -2990,6 +3014,7 @@ proc_info_create_with_declared_detism(MainContext, VarSet, VarTypes, HeadVars,
HasUserEvent,
HasTailCallEvent,
OisuKinds,
+ MaybeRequireTailRecursion,
RegR_HeadVars,
MaybeArgPassInfo,
MaybeSpecialReturn,
@@ -3097,6 +3122,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) :-
@@ -3181,6 +3208,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/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 2bc9947..9a174de 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..36bf3b5 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,62 @@ 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, WarnOrError,
+ Option),
+
+ ProcSpecStr = format_pred_name_arity_mpf_mmode(Lang, Proc),
+ warning_or_error_string(WarnOrError, WarnOrErrorStr),
+ require_tailrec_option_string(Option, OptionStr),
+
+ format(":- pragma warn_tail_recursion(%s, [%s, %s]).\n",
+ [s(ProcSpecStr), s(WarnOrErrorStr), s(OptionStr)], !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_io_pragma.m b/compiler/prog_io_pragma.m
index 4fb39f3..4fa0e2d 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,188 @@ 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.
+ Pieces0 = cord.from_list([
+ words("Error: expected predicate or function"),
+ words("name/arity or name(modes) for"),
+ pragma_decl(PragmaName), words("declaration, not"),
+ quote(describe_error_term(VarSet, PredAndModesTerm)),
+ suffix("."), nl]),
+ parse_arity_or_modes(ModuleName, PredAndModesTerm,
+ PredAndModesTerm, VarSet, Pieces0, MaybeArityOrModes),
+ ( MaybeArityOrModes = ok1(ArityOrModes),
+ ArityOrModes = arity_or_modes(Name, Arity, MaybePF,
+ MaybeModes),
+ MaybeProc = ok1(pred_name_arity_mpf_mmode(Name, Arity, MaybePF,
+ MaybeModes))
+ ; MaybeArityOrModes = error1(Errors0),
+ MaybeProc = error1(Errors0)
+ ),
+
+ % Parse the options
+ (
+ MaybeOptionsTerm = yes(OptionsTerm),
+ ( if list_term_to_term_list(OptionsTerm, OptionsTerms)
+ then
+ parse_pragma_require_tail_recursion_options(OptionsTerms,
+ no, no, MaybeOptions)
+ else
+ ( OptionsTerm = functor(_, _, OptionsContext)
+ ; OptionsTerm = variable(_, OptionsContext)
+ ),
+ 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({we_warning, rtro_any_recursion})
+ ),
+
+ % Put them together.
+ (
+ MaybeProc = ok1(Proc),
+ (
+ MaybeOptions = ok1({WarnOrError, Option}),
+ PragmaType = pragma_require_tail_recursion(
+ pragma_info_require_tail_recursion(Proc, WarnOrError,
+ Option)),
+ 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])
+ ).
+
+:- pred parse_pragma_require_tail_recursion_options(list(term)::in,
+ maybe(warning_or_error)::in,
+ maybe(require_tailrec_option)::in,
+ maybe1({warning_or_error, require_tailrec_option})::out) is det.
+
+parse_pragma_require_tail_recursion_options([], MaybeWarnOrError,
+ MaybeOption, MaybeOptions) :-
+ % If these values were not set then use the defaults.
+ (
+ MaybeWarnOrError = yes(WarnOrError)
+ ;
+ MaybeWarnOrError = no,
+ WarnOrError = we_warning
+ ),
+ (
+ MaybeOption = yes(Option)
+ ;
+ MaybeOption = no,
+ Option = rtro_any_recursion
+ ),
+ MaybeOptions = ok1({WarnOrError, Option}).
+parse_pragma_require_tail_recursion_options([Term | Terms],
+ MaybeWarnOrError, MaybeOption, MaybeOptions) :-
+ (
+ Term = functor(Functor, _Args, Context),
+ ( if
+ Functor = atom(Name),
+ warning_or_error_string(WarnOrError, Name)
+ then
+ (
+ MaybeWarnOrError = no,
+ parse_pragma_require_tail_recursion_options(Terms,
+ yes(WarnOrError), MaybeOption, MaybeOptions)
+ ;
+ MaybeWarnOrError = yes(WarnOrErrorFirst),
+ warning_or_error_string(WarnOrErrorFirst,
+ WarnOrErrorFirstString),
+ MaybeOptions = error1([conflicting_attributes_error(
+ Name, WarnOrErrorFirstString, Context)])
+ )
+ else if
+ Functor = atom(Name),
+ require_tailrec_option_string(Option, Name)
+ then
+ (
+ MaybeOption = no,
+ parse_pragma_require_tail_recursion_options(Terms,
+ MaybeWarnOrError, yes(Option), MaybeOptions)
+ ;
+ MaybeOption = yes(OptionFirst),
+ require_tailrec_option_string(OptionFirst, OptionFirstString),
+ MaybeOptions = error1([conflicting_attributes_error(Name,
+ OptionFirstString, Context)])
+ )
+ else
+ MaybeOptions = error1([
+ pragma_require_tailrec_unknown_term_error(Term, Context)])
+ )
+ ;
+ Term = variable(_, Context),
+ MaybeOptions = error1([pragma_require_tailrec_unknown_term_error(
+ Term, Context)])
+ ).
+
+:- 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.
diff --git a/compiler/prog_item.m b/compiler/prog_item.m
index c55fe10..24517bb 100644
--- a/compiler/prog_item.m
+++ b/compiler/prog_item.m
@@ -24,6 +24,7 @@
:- interface.
:- import_module libs.
+:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.
@@ -791,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)
@@ -943,6 +945,32 @@
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_warning_or_error :: warning_or_error,
+ rtr_options :: require_tailrec_option
+
+ % This parameter only makes sense when options cantains
+ % 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))
+ ).
+
+ % Which recursion types to create a warning or error for.
+ %
+:- type require_tailrec_option
+ ---> rtro_none
+ ; rtro_self_rec_only
+ ; rtro_any_recursion.
+
+:- pred require_tailrec_option_string(require_tailrec_option, string).
+:- mode require_tailrec_option_string(in, out) is det.
+:- mode require_tailrec_option_string(out, in) is semidet.
+
% Evaluation method pragmas.
:- type pragma_info_tabled
@@ -1057,6 +1085,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,
@@ -1529,6 +1565,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(_)
@@ -1606,6 +1643,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")]
;
@@ -1923,6 +1964,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(_)
@@ -1953,6 +1995,10 @@ do_get_item_foreign_include_file(Lang, LiteralOrInclude, !Info) :-
!Info ^ all_foreign_include_files := IncludeFilesCord
).
+require_tailrec_option_string(rtro_none, "none").
+require_tailrec_option_string(rtro_self_rec_only, "self_recursion_only").
+require_tailrec_option_string(rtro_any_recursion, "self_or_mutual_recursion").
+
%-----------------------------------------------------------------------------%
:- end_module parse_tree.prog_item.
%-----------------------------------------------------------------------------%
diff --git a/compiler/prog_item_stats.m b/compiler/prog_item_stats.m
index d960c14..8a2cc64 100644
--- a/compiler/prog_item_stats.m
+++ b/compiler/prog_item_stats.m
@@ -317,6 +317,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 f14d9ce..7ca1506 100644
--- a/compiler/write_module_interface_files.m
+++ b/compiler/write_module_interface_files.m
@@ -2072,6 +2072,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 0fd2371..e228c28 100644
--- a/doc/reference_manual.texi
+++ b/doc/reference_manual.texi
@@ -9820,6 +9820,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.
@@ -10416,6 +10417,81 @@ 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 for non tail recursive predicates and functions.
+ 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 This is useful for code that you expect will recurse many times, or will be
+ at c called frequently.
+ 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 is a compiler warning.
+ at c This is the default.
+ at c This option is incompatible with @samp{error}.
+ at c
+ at c @item error
+ at c Non tail recursive code is a compiler error.
+ at c This option is incompatible with @samp{warn}.
+ 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_recursion_only
+ at c Require that the recursive calls are self-recursive.
+ at c This option is incompatible with @samp{self_or_mutual_recursion}.
+ at c
+ at c @item self_or_mutual_recursion
+ at c Allow the recursive calls to be self or mutually recursive.
+ at c The calls must not be mutually recursive over module boundaries or through
+ at c higher order calls.
+ at c This option is incompatible with @samp{self_recursion_only}.
+ at c
+ at c @end table
+ at c
+ at c This pragma has no effect when @samp{--optimize-tailcalls} is disabled
+ at c or on the Erlang backend.
+ at c Erlang provides last call optimisation itself.
+ 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
--
2.6.2
More information about the reviews
mailing list