diff --git a/compiler/det_analysis.m b/compiler/det_analysis.m index 9e50b39e5..1e0ca8356 100644 --- a/compiler/det_analysis.m +++ b/compiler/det_analysis.m @@ -289,7 +289,7 @@ det_infer_proc(PredId, ProcId, ModuleInfo0, ModuleInfo, Globals, % Now see if the evaluation model can change the detism proc_info_eval_method(Proc0, EvalMethod), - eval_method_change_determinism(EvalMethod, Detism2, Detism), + Detism = eval_method_change_determinism(EvalMethod, Detism2), % Save the newly inferred information proc_info_set_goal(Proc0, Goal, Proc1), diff --git a/compiler/det_report.m b/compiler/det_report.m index 5245f4cf3..6b74b6cae 100644 --- a/compiler/det_report.m +++ b/compiler/det_report.m @@ -246,7 +246,8 @@ check_determinism(PredId, ProcId, PredInfo0, ProcInfo0, % make sure the code model is valid given the eval method { proc_info_eval_method(ProcInfo0, EvalMethod) }, ( - { valid_determinism_for_eval_method(EvalMethod, InferredDetism) } + { valid_determinism_for_eval_method(EvalMethod, + InferredDetism) = yes } -> { proc_info_set_eval_method(ProcInfo0, EvalMethod, ProcInfo), @@ -259,7 +260,7 @@ check_determinism(PredId, ProcId, PredInfo0, ProcInfo0, ; { proc_info_context(ProcInfo0, Context) }, prog_out__write_context(Context), - { eval_method_to_string(EvalMethod, EvalMethodS) }, + { EvalMethodS = eval_method_to_string(EvalMethod) }, io__write_string("Error: `pragma "), io__write_string(EvalMethodS), io__write_string("' declaration not allowed for procedure\n"), @@ -284,7 +285,7 @@ check_determinism(PredId, ProcId, PredInfo0, ProcInfo0, get_valid_dets(EvalMethod, Detism) :- determinism(Detism), - valid_determinism_for_eval_method(EvalMethod, Detism). + valid_determinism_for_eval_method(EvalMethod, Detism) = yes. % generate all the possible determinisms :- pred determinism(determinism). diff --git a/compiler/hlds_out.m b/compiler/hlds_out.m index 1f1021bbf..2c0c61963 100644 --- a/compiler/hlds_out.m +++ b/compiler/hlds_out.m @@ -3505,10 +3505,23 @@ hlds_out__write_eval_method(eval_memo) --> io__write_string("memo"). hlds_out__write_eval_method(eval_minimal) --> io__write_string("minimal"). -hlds_out__write_eval_method(eval_table_io) --> - io__write_string("table_io"). -hlds_out__write_eval_method(eval_table_io_decl) --> - io__write_string("table_io_decl"). +hlds_out__write_eval_method(eval_table_io(IsDecl, IsUnitize)) --> + io__write_string("table_io("), + ( + { IsDecl = table_io_decl }, + io__write_string("decl, ") + ; + { IsDecl = table_io_proc }, + io__write_string("proc, ") + ), + ( + { IsUnitize = table_io_unitize }, + io__write_string("unitize") + ; + { IsUnitize = table_io_alone }, + io__write_string("alone") + ), + io__write_string(")"). %-----------------------------------------------------------------------------% diff --git a/compiler/hlds_pred.m b/compiler/hlds_pred.m index c0aa7f3a7..9b9b8aae8 100644 --- a/compiler/hlds_pred.m +++ b/compiler/hlds_pred.m @@ -2785,12 +2785,10 @@ hlds_pred__is_differential(ModuleInfo, PredId) :- % Check if the given evaluation method is allowed with % the given determinism. -:- pred valid_determinism_for_eval_method(eval_method, determinism). -:- mode valid_determinism_for_eval_method(in, in) is semidet. +:- func valid_determinism_for_eval_method(eval_method, determinism) = bool. % Convert an evaluation method to a string. -:- pred eval_method_to_string(eval_method, string). -:- mode eval_method_to_string(in, out) is det. +:- func eval_method_to_string(eval_method) = string. % Return true if the given evaluation method requires a % stratification check. @@ -2815,71 +2813,81 @@ hlds_pred__is_differential(ModuleInfo, PredId) :- % Return the change a given evaluation method can do to a given % determinism. -:- pred eval_method_change_determinism(eval_method, determinism, - determinism). -:- mode eval_method_change_determinism(in, in, out) is det. +:- func eval_method_change_determinism(eval_method, determinism) = determinism. :- implementation. :- import_module check_hlds__det_analysis. -valid_determinism_for_eval_method(eval_normal, _). -valid_determinism_for_eval_method(eval_loop_check, _). -valid_determinism_for_eval_method(eval_table_io, _) :- +valid_determinism_for_eval_method(eval_normal, _) = yes. +valid_determinism_for_eval_method(eval_loop_check, _) = yes. +valid_determinism_for_eval_method(eval_table_io(_, _), _) = _ :- error("valid_determinism_for_eval_method called after tabling phase"). -valid_determinism_for_eval_method(eval_memo, _). -valid_determinism_for_eval_method(eval_minimal, Determinism) :- - determinism_components(Determinism, can_fail, _). +valid_determinism_for_eval_method(eval_memo, _) = yes. +valid_determinism_for_eval_method(eval_minimal, Determinism) = Valid :- + ( determinism_components(Determinism, can_fail, _) -> + Valid = yes + ; + Valid = no + ). -eval_method_to_string(eval_normal, "normal"). -eval_method_to_string(eval_loop_check, "loop_check"). -eval_method_to_string(eval_table_io, "table_io"). -eval_method_to_string(eval_table_io_decl, "table_io_decl"). -eval_method_to_string(eval_memo, "memo"). -eval_method_to_string(eval_minimal, "minimal_model"). +eval_method_to_string(eval_normal) = "normal". +eval_method_to_string(eval_loop_check) = "loop_check". +eval_method_to_string(eval_memo) = "memo". +eval_method_to_string(eval_minimal) = "minimal_model". +eval_method_to_string(eval_table_io(IsDecl, IsUnitize)) = Str :- + ( + IsDecl = table_io_decl, + DeclStr = "decl, " + ; + IsDecl = table_io_proc, + DeclStr = "proc, " + ), + ( + IsUnitize = table_io_unitize, + UnitizeStr = "unitize" + ; + IsUnitize = table_io_alone, + UnitizeStr = "alone" + ), + Str = "table_io(" ++ DeclStr ++ UnitizeStr ++ ")". eval_method_needs_stratification(eval_normal) = no. eval_method_needs_stratification(eval_loop_check) = no. -eval_method_needs_stratification(eval_table_io) = no. -eval_method_needs_stratification(eval_table_io_decl) = no. +eval_method_needs_stratification(eval_table_io(_, _)) = no. eval_method_needs_stratification(eval_memo) = no. eval_method_needs_stratification(eval_minimal) = yes. eval_method_has_per_proc_tabling_pointer(eval_normal) = no. eval_method_has_per_proc_tabling_pointer(eval_loop_check) = yes. -eval_method_has_per_proc_tabling_pointer(eval_table_io) = no. -eval_method_has_per_proc_tabling_pointer(eval_table_io_decl) = no. +eval_method_has_per_proc_tabling_pointer(eval_table_io(_, _)) = no. eval_method_has_per_proc_tabling_pointer(eval_memo) = yes. eval_method_has_per_proc_tabling_pointer(eval_minimal) = yes. eval_method_requires_tabling_transform(eval_normal) = no. eval_method_requires_tabling_transform(eval_loop_check) = yes. -eval_method_requires_tabling_transform(eval_table_io) = yes. -eval_method_requires_tabling_transform(eval_table_io_decl) = yes. +eval_method_requires_tabling_transform(eval_table_io(_, _)) = yes. eval_method_requires_tabling_transform(eval_memo) = yes. eval_method_requires_tabling_transform(eval_minimal) = yes. eval_method_requires_ground_args(eval_normal) = no. eval_method_requires_ground_args(eval_loop_check) = yes. -eval_method_requires_ground_args(eval_table_io) = yes. -eval_method_requires_ground_args(eval_table_io_decl) = yes. +eval_method_requires_ground_args(eval_table_io(_, _)) = yes. eval_method_requires_ground_args(eval_memo) = yes. eval_method_requires_ground_args(eval_minimal) = yes. eval_method_destroys_uniqueness(eval_normal) = no. eval_method_destroys_uniqueness(eval_loop_check) = yes. -eval_method_destroys_uniqueness(eval_table_io) = no. -eval_method_destroys_uniqueness(eval_table_io_decl) = no. +eval_method_destroys_uniqueness(eval_table_io(_, _)) = no. eval_method_destroys_uniqueness(eval_memo) = yes. eval_method_destroys_uniqueness(eval_minimal) = yes. -eval_method_change_determinism(eval_normal, Detism, Detism). -eval_method_change_determinism(eval_loop_check, Detism, Detism). -eval_method_change_determinism(eval_table_io, Detism, Detism). -eval_method_change_determinism(eval_table_io_decl, Detism, Detism). -eval_method_change_determinism(eval_memo, Detism, Detism). -eval_method_change_determinism(eval_minimal, Det0, Det) :- - det_conjunction_detism(semidet, Det0, Det). +eval_method_change_determinism(eval_normal, Detism) = Detism. +eval_method_change_determinism(eval_loop_check, Detism) = Detism. +eval_method_change_determinism(eval_table_io(_, _), Detism) = Detism. +eval_method_change_determinism(eval_memo, Detism) = Detism. +eval_method_change_determinism(eval_minimal, Detism0) = Detism :- + det_conjunction_detism(semidet, Detism0, Detism). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% diff --git a/compiler/layout_out.m b/compiler/layout_out.m index 5319e79cb..64db5e45a 100644 --- a/compiler/layout_out.m +++ b/compiler/layout_out.m @@ -720,9 +720,25 @@ write_maybe_slot_num(no) --> eval_method_to_c_string(eval_normal) = "MR_EVAL_METHOD_NORMAL". eval_method_to_c_string(eval_loop_check) = "MR_EVAL_METHOD_LOOP_CHECK". eval_method_to_c_string(eval_memo) = "MR_EVAL_METHOD_MEMO". -eval_method_to_c_string(eval_table_io) = "MR_EVAL_METHOD_TABLE_IO". -eval_method_to_c_string(eval_table_io_decl) = "MR_EVAL_METHOD_TABLE_IO_DECL". eval_method_to_c_string(eval_minimal) = "MR_EVAL_METHOD_MINIMAL". +eval_method_to_c_string(eval_table_io(Decl, Unitize)) = Str :- + ( + Decl = table_io_proc, + Unitize = table_io_alone, + Str = "MR_EVAL_METHOD_TABLE_IO" + ; + Decl = table_io_proc, + Unitize = table_io_unitize, + Str = "MR_EVAL_METHOD_TABLE_IO_UNITIZE" + ; + Decl = table_io_decl, + Unitize = table_io_alone, + Str = "MR_EVAL_METHOD_TABLE_IO_DECL" + ; + Decl = table_io_decl, + Unitize = table_io_unitize, + Str = "MR_EVAL_METHOD_TABLE_IO_UNITIZE_DECL" + ). :- pred output_proc_layout_head_var_nums(proc_label::in, list(int)::in, decl_set::in, decl_set::out, io__state::di, io__state::uo) is det. diff --git a/compiler/make_hlds.m b/compiler/make_hlds.m index 62320aeb5..235373848 100644 --- a/compiler/make_hlds.m +++ b/compiler/make_hlds.m @@ -754,7 +754,7 @@ add_item_clause(pragma(Pragma), Status, Status, Context, { module_info_incr_errors(Module0, Module) }, prog_out__write_context(Context), io__write_string("Error: `:- pragma "), - { eval_method_to_string(Type, EvalMethodS) }, + { EvalMethodS = eval_method_to_string(Type) }, io__write_string(EvalMethodS), io__write_string( "' declaration requires the type_ctor_layout\n"), @@ -4616,7 +4616,7 @@ module_add_pragma_foreign_proc(Attributes, PredName, PredOrFunc, module_add_pragma_tabled(EvalMethod, PredName, Arity, MaybePredOrFunc, MaybeModes, Status, Context, ModuleInfo0, ModuleInfo) --> { module_info_get_predicate_table(ModuleInfo0, PredicateTable0) }, - { eval_method_to_string(EvalMethod, EvalMethodS) }, + { EvalMethodS = eval_method_to_string(EvalMethod) }, % Find out if we are tabling a predicate or a function ( @@ -4693,7 +4693,7 @@ module_add_pragma_tabled_2(EvalMethod, PredName, Arity0, MaybePredOrFunc, { adjust_func_arity(PredOrFunc, Arity0, Arity) }, % print out a progress message - { eval_method_to_string(EvalMethod, EvalMethodS) }, + { EvalMethodS = eval_method_to_string(EvalMethod) }, globals__io_lookup_bool_option(very_verbose, VeryVerbose), ( { VeryVerbose = yes } diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m index 283add345..33f7f462d 100644 --- a/compiler/mercury_to_mercury.m +++ b/compiler/mercury_to_mercury.m @@ -549,7 +549,7 @@ mercury_output_item(_UnqualifiedItemNames, pragma(Pragma), Context) --> mercury_output_pragma_decl(Pred, Arity, predicate, "obsolete") ; { Pragma = tabled(Type, Pred, Arity, _PredOrFunc, _Mode) }, - { eval_method_to_string(Type, TypeS) }, + { TypeS = eval_method_to_string(Type) }, mercury_output_pragma_decl(Pred, Arity, predicate, TypeS) ; { Pragma = type_spec(_, _, _, _, _, _, _, _) }, @@ -3769,18 +3769,9 @@ output_class_id(class_id(Name, Arity)) --> :- pred output_eval_method(eval_method::in, string::di, string::uo) is det. -output_eval_method(eval_normal) --> - output_string("eval_normal"). -output_eval_method(eval_loop_check) --> - output_string("eval_loop_check"). -output_eval_method(eval_memo) --> - output_string("eval_memo"). -output_eval_method(eval_table_io) --> - output_string("eval_table_io"). -output_eval_method(eval_table_io_decl) --> - output_string("eval_table_io_decl"). -output_eval_method(eval_minimal) --> - output_string("eval_minimal"). +output_eval_method(EvalMethod) --> + output_string("eval_"), + output_string(eval_method_to_string(EvalMethod)). :- pred output_lambda_eval_method(lambda_eval_method::in, string::di, string::uo) is det. diff --git a/compiler/modes.m b/compiler/modes.m index d71bd62dd..27b28ce6b 100644 --- a/compiler/modes.m +++ b/compiler/modes.m @@ -2298,7 +2298,7 @@ check_mode_of_main([Di, Uo], ModuleInfo) :- report_eval_method_requires_ground_args(ProcInfo, ModuleInfo0, ModuleInfo) --> { proc_info_eval_method(ProcInfo, EvalMethod) }, { proc_info_context(ProcInfo, Context) }, - { eval_method_to_string(EvalMethod, EvalMethodS) }, + { EvalMethodS = eval_method_to_string(EvalMethod) }, globals__io_lookup_bool_option(verbose_errors, VerboseErrors), prog_out__write_context(Context), io__write_string("Sorry, not implemented: `pragma "), @@ -2326,7 +2326,7 @@ report_eval_method_requires_ground_args(ProcInfo, ModuleInfo0, ModuleInfo) --> report_eval_method_destroys_uniqueness(ProcInfo, ModuleInfo0, ModuleInfo) --> { proc_info_eval_method(ProcInfo, EvalMethod) }, { proc_info_context(ProcInfo, Context) }, - { eval_method_to_string(EvalMethod, EvalMethodS) }, + { EvalMethodS = eval_method_to_string(EvalMethod) }, globals__io_lookup_bool_option(verbose_errors, VerboseErrors), prog_out__write_context(Context), io__write_string("Error: `pragma "), diff --git a/compiler/prog_data.m b/compiler/prog_data.m index 81595e364..e7673140f 100644 --- a/compiler/prog_data.m +++ b/compiler/prog_data.m @@ -345,18 +345,34 @@ % Stuff for tabling pragmas % - % The evaluation method that should be used for a pred. + % The evaluation method that should be used for a procedure. % Ignored for Aditi procedures. :- type eval_method ---> eval_normal % normal mercury % evaluation ; eval_loop_check % loop check only ; eval_memo % memoing + loop check - ; eval_table_io % memoing I/O actions for debugging - ; eval_table_io_decl % memoing I/O actions for declarative - % debugging + ; eval_table_io( % memoing I/O actions for debugging + table_io_is_decl, + table_io_is_unitize + ) ; eval_minimal. % minimal model % evaluation + +:- type table_io_is_decl + ---> table_io_decl % The procedure is tabled for + % declarative debugging. + ; table_io_proc. % The procedure is tabled only for + % procedural debugging. + +:- type table_io_is_unitize + ---> table_io_unitize % The procedure is tabled for I/O + % together with its Mercury + % descendants. + ; table_io_alone. % The procedure is tabled for I/O + % by itself; it can have no Mercury + % descendants. + % % Stuff for the `aditi_index' pragma % @@ -651,7 +667,9 @@ :- type tabled_for_io ---> not_tabled_for_io - ; tabled_for_io. + ; tabled_for_io + ; tabled_for_io_unitize + ; tabled_for_descendant_io. :- type pragma_var ---> pragma_var(prog_var, string, mode). @@ -659,7 +677,6 @@ % we explicitly store the name because we need the real % name in code_gen - :- type pragma_foreign_proc_extra_attribute ---> max_stack_size(int). @@ -1125,7 +1142,6 @@ set_purity(Attrs0, Purity, Attrs) :- set_legacy_purity_behaviour(Attrs0, Legacy, Attrs) :- Attrs = Attrs0 ^ legacy_purity_behaviour := Legacy. - attributes_to_strings(Attrs, StringList) :- % We ignore Lang because it isn't an attribute that you can put % in the attribute list -- the foreign language specifier string @@ -1149,6 +1165,12 @@ attributes_to_strings(Attrs, StringList) :- ( TabledForIO = tabled_for_io, TabledForIOStr = "tabled_for_io" + ; + TabledForIO = tabled_for_io_unitize, + TabledForIOStr = "tabled_for_io_unitize" + ; + TabledForIO = tabled_for_descendant_io, + TabledForIOStr = "tabled_for_descendant_io" ; TabledForIO = not_tabled_for_io, TabledForIOStr = "not_tabled_for_io" diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m index 7b8bb9ef9..02e8cc5d7 100644 --- a/compiler/prog_io_pragma.m +++ b/compiler/prog_io_pragma.m @@ -1144,6 +1144,16 @@ parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma, Term, thread_safe(thread_safe) - thread_safe(not_thread_safe), tabled_for_io(tabled_for_io) - + tabled_for_io(tabled_for_io_unitize), + tabled_for_io(tabled_for_io) - + tabled_for_io(tabled_for_descendant_io), + tabled_for_io(tabled_for_io) - + tabled_for_io(not_tabled_for_io), + tabled_for_io(tabled_for_io_unitize) - + tabled_for_io(tabled_for_descendant_io), + tabled_for_io(tabled_for_io_unitize) - + tabled_for_io(not_tabled_for_io), + tabled_for_io(tabled_for_descendant_io) - tabled_for_io(not_tabled_for_io), purity(pure) - purity(impure), purity(pure) - purity(semipure), @@ -1278,10 +1288,20 @@ parse_threadsafe(term__functor(term__atom("not_thread_safe"), [], _), :- pred parse_tabled_for_io(term, tabled_for_io). :- mode parse_tabled_for_io(in, out) is semidet. -parse_tabled_for_io(term__functor(term__atom("tabled_for_io"), [], _), - tabled_for_io). -parse_tabled_for_io(term__functor(term__atom("not_tabled_for_io"), [], _), - not_tabled_for_io). +parse_tabled_for_io(term__functor(term__atom(Str), [], _), TabledForIo) :- + ( + Str = "tabled_for_io", + TabledForIo = tabled_for_io + ; + Str = "tabled_for_io_unitize", + TabledForIo = tabled_for_io_unitize + ; + Str = "tabled_for_descendant_io", + TabledForIo = tabled_for_descendant_io + ; + Str = "not_tabled_for_io", + TabledForIo = not_tabled_for_io + ). % XXX For the moment we just ignore the following attributes. % These attributes are used for aliasing on the reuse branch, @@ -1294,7 +1314,6 @@ parse_aliasing(term__functor(term__atom("no_aliasing"), [], _)). parse_aliasing(term__functor(term__atom("unknown_aliasing"), [], _)). parse_aliasing(term__functor(term__atom("alias"), [_Types, _Alias], _)). - :- pred parse_max_stack_size(term::in, int::out) is semidet. parse_max_stack_size(term__functor( diff --git a/compiler/table_gen.m b/compiler/table_gen.m index b1a0e440d..65589c136 100644 --- a/compiler/table_gen.m +++ b/compiler/table_gen.m @@ -300,70 +300,145 @@ table_gen__process_procs(PredId, [ProcId | ProcIds], ModuleInfo0, ModuleInfo, map__lookup(PredTable, PredId, PredInfo), pred_info_procedures(PredInfo, ProcTable), map__lookup(ProcTable, ProcId, ProcInfo0), - - module_info_globals(ModuleInfo0, Globals), - proc_info_eval_method(ProcInfo0, EvalMethod), - - ( eval_method_requires_tabling_transform(EvalMethod) = yes -> - table_gen__process_proc(EvalMethod, PredId, ProcId, ProcInfo0, - PredInfo, ModuleInfo0, ModuleInfo2), - S1 = S0 - ; - globals__lookup_bool_option(Globals, trace_table_io, yes), - globals__lookup_bool_option(Globals, trace_table_io_require, - Require), - proc_info_has_io_state_pair(ModuleInfo0, ProcInfo0, - _InArgNum, _OutArgNum), - proc_info_interface_code_model(ProcInfo0, model_det), - proc_info_goal(ProcInfo0, BodyGoal), - some [SubGoal,Attrs] ( - goal_contains_goal(BodyGoal, SubGoal), - SubGoal = foreign_proc(Attrs, _,_,_,_,_,_) - - _, - ( tabled_for_io(Attrs, tabled_for_io) - ; Require = yes - ) - ), - predicate_module(ModuleInfo0, PredId, PredModuleName), - \+ any_mercury_builtin_module(PredModuleName) - -> - ( - Require = yes, - some [SubGoal,Attrs] ( - goal_contains_goal(BodyGoal, SubGoal), - SubGoal = foreign_proc(Attrs, _,_,_,_,_,_) - - _, - \+ tabled_for_io(Attrs, tabled_for_io) - ) - -> - report_missing_tabled_for_io(ModuleInfo0, PredInfo, - PredId, ProcId, S0, S1), - module_info_incr_errors(ModuleInfo0, ModuleInfo1) - ; - ModuleInfo1 = ModuleInfo0, - S1 = S0 - ), - globals__lookup_bool_option(Globals, trace_table_io_decl, - TraceTableIoDecl), - ( - TraceTableIoDecl = yes, - TableIoMethod = eval_table_io_decl - ; - TraceTableIoDecl = no, - TableIoMethod = eval_table_io - ), - proc_info_set_eval_method(ProcInfo0, TableIoMethod, ProcInfo1), - table_gen__process_proc(TableIoMethod, PredId, ProcId, - ProcInfo1, PredInfo, ModuleInfo1, ModuleInfo2) - ; - ModuleInfo2 = ModuleInfo0, - S1 = S0 - ), - table_gen__process_procs(PredId, ProcIds, ModuleInfo2, ModuleInfo, + table_gen__process_proc(PredId, ProcId, ProcInfo0, PredInfo, + ModuleInfo0, ModuleInfo1, S0, S1), + table_gen__process_procs(PredId, ProcIds, ModuleInfo1, ModuleInfo, S1, S). +:- pred table_gen__process_proc(pred_id::in, proc_id::in, proc_info::in, + pred_info::in, module_info::in, module_info::out, io__state::di, + io__state::uo) is det. + +table_gen__process_proc(PredId, ProcId, ProcInfo0, PredInfo0, + ModuleInfo0, ModuleInfo, S0, S) :- + proc_info_eval_method(ProcInfo0, EvalMethod), + ( eval_method_requires_tabling_transform(EvalMethod) = yes -> + table_gen__transform_proc(EvalMethod, PredId, ProcId, + ProcInfo0, PredInfo0, ModuleInfo0, ModuleInfo), + S = S0 + ; + module_info_globals(ModuleInfo0, Globals), + globals__lookup_bool_option(Globals, trace_table_io, yes), + proc_info_has_io_state_pair(ModuleInfo0, ProcInfo0, + _InArgNum, _OutArgNum) + -> +% XXX We can't include this sanity checking code, because it fails on +% globals:io_lookup_bool_option. +% +% proc_info_interface_code_model(ProcInfo0, CodeModel), +% ( CodeModel = model_det -> +% true +% ; +% pred_id_to_int(PredId, PredIdInt), +% Msg = string__format( +% "I/O procedure pred id %d not model_det", +% [i(PredIdInt)]), +% error(Msg) +% ), + globals__lookup_bool_option(Globals, trace_table_io_require, + Require), + proc_info_goal(ProcInfo0, BodyGoal), + predicate_module(ModuleInfo0, PredId, PredModuleName), + should_io_procedure_be_transformed(Require, BodyGoal, + PredModuleName, AnnotationIsMissing, + TransformPrimitive), + ( + AnnotationIsMissing = yes, + report_missing_tabled_for_io(ModuleInfo0, PredInfo0, + PredId, ProcId, S0, S), + module_info_incr_errors(ModuleInfo0, ModuleInfo1) + ; + AnnotationIsMissing = no, + ModuleInfo1 = ModuleInfo0, + S = S0 + ), + ( + TransformPrimitive = no, + ModuleInfo = ModuleInfo0 + ; + TransformPrimitive = yes(Unitize), + globals__lookup_bool_option(Globals, + trace_table_io_decl, TraceTableIoDecl), + ( + TraceTableIoDecl = yes, + Decl = table_io_decl + ; + TraceTableIoDecl = no, + Decl = table_io_proc + ), + TableIoMethod = eval_table_io(Decl, Unitize), + proc_info_set_eval_method(ProcInfo0, TableIoMethod, + ProcInfo1), + table_gen__transform_proc(TableIoMethod, + PredId, ProcId, ProcInfo1, PredInfo0, + ModuleInfo1, ModuleInfo) + ) + ; + ModuleInfo = ModuleInfo0, + S = S0 + ). + %-----------------------------------------------------------------------------% +:- pred should_io_procedure_be_transformed(bool::in, hlds_goal::in, + sym_name::in, bool::out, maybe(table_io_is_unitize)::out) is det. + +should_io_procedure_be_transformed(Require, BodyGoal, PredModuleName, + AnnotationIsMissing, TransformInfo) :- + tabled_for_io_attributes(BodyGoal, TabledForIoAttrs), + ( TabledForIoAttrs = [] -> + AnnotationIsMissing = no, + TransformInfo = no + ; TabledForIoAttrs = [TabledForIoAttr] -> + ( + TabledForIoAttr = not_tabled_for_io, + ( + Require = yes, + \+ any_mercury_builtin_module(PredModuleName) + -> + AnnotationIsMissing = yes + ; + AnnotationIsMissing = no + ), + TransformInfo = no + ; + TabledForIoAttr = tabled_for_descendant_io, + AnnotationIsMissing = no, + % The procedure itself doesn't do any I/O, so don't + % transform it. + TransformInfo = no + ; + TabledForIoAttr = tabled_for_io, + AnnotationIsMissing = no, + TransformInfo = yes(table_io_alone) + ; + TabledForIoAttr = tabled_for_io_unitize, + AnnotationIsMissing = no, + TransformInfo = yes(table_io_unitize) + ) + ; + % Since table_gen is run before inlining, each procedure + % should contain at most one foreign_proc goal. + error("should_io_procedure_be_transformed: different tabled_for_io attributes in one procedure") + ). + +:- pred tabled_for_io_attributes(hlds_goal::in, list(tabled_for_io)::out) + is det. + +tabled_for_io_attributes(Goal, TabledForIoAttrs) :- + solutions(subgoal_tabled_for_io_attribute(Goal), TabledForIoAttrs). + +:- pred subgoal_tabled_for_io_attribute(hlds_goal::in, tabled_for_io::out) + is nondet. + +subgoal_tabled_for_io_attribute(Goal, TabledForIoAttr) :- + some [SubGoal,Attrs] ( + goal_contains_goal(Goal, SubGoal), + SubGoal = foreign_proc(Attrs, _,_,_,_,_,_) - _, + tabled_for_io(Attrs, TabledForIoAttr), + \+ TabledForIoAttr = not_tabled_for_io + ). + :- pred report_missing_tabled_for_io(module_info::in, pred_info::in, pred_id::in, proc_id::in, io__state::di, io__state::uo) is det. @@ -376,11 +451,11 @@ report_missing_tabled_for_io(ModuleInfo, PredInfo, PredId, ProcId) --> %-----------------------------------------------------------------------------% -:- pred table_gen__process_proc(eval_method::in, pred_id::in, proc_id::in, +:- pred table_gen__transform_proc(eval_method::in, pred_id::in, proc_id::in, proc_info::in, pred_info::in, module_info::in, module_info::out) is det. -table_gen__process_proc(EvalMethod, PredId, ProcId, ProcInfo0, PredInfo0, +table_gen__transform_proc(EvalMethod, PredId, ProcId, ProcInfo0, PredInfo0, ModuleInfo0, ModuleInfo) :- table_info_init(ModuleInfo0, PredId, ProcId, PredInfo0, ProcInfo0, TableInfo0), @@ -394,19 +469,11 @@ table_gen__process_proc(EvalMethod, PredId, ProcId, ProcInfo0, PredInfo0, proc_info_goal(ProcInfo0, OrigGoal), proc_info_argmodes(ProcInfo0, ArgModes), - ( - ( - EvalMethod = eval_table_io, - TableDecl = no - ; - EvalMethod = eval_table_io_decl, - TableDecl = yes - ) - -> + ( EvalMethod = eval_table_io(Decl, Unitize) -> module_info_globals(ModuleInfo0, Globals), globals__lookup_bool_option(Globals, trace_table_io_states, TableIoStates), - table_gen__create_new_io_goal(OrigGoal, TableDecl, + table_gen__create_new_io_goal(OrigGoal, Decl, Unitize, TableIoStates, HeadVars, ArgModes, VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, Goal, MaybeTableIoDeclInfo), @@ -469,13 +536,13 @@ table_gen__process_proc(EvalMethod, PredId, ProcId, ProcInfo0, PredInfo0, % Transform procedures that do I/O. % -:- pred table_gen__create_new_io_goal(hlds_goal::in, bool::in, bool::in, - list(prog_var)::in, list(mode)::in, +:- pred table_gen__create_new_io_goal(hlds_goal::in, table_io_is_decl::in, + table_io_is_unitize::in, bool::in, list(prog_var)::in, list(mode)::in, map(prog_var, type)::in, map(prog_var, type)::out, prog_varset::in, prog_varset::out, table_info::in, table_info::out, hlds_goal::out, maybe(table_io_decl_info)::out) is det. -table_gen__create_new_io_goal(OrigGoal, TableDecl, TableIoStates, +table_gen__create_new_io_goal(OrigGoal, TableDecl, Unitize, TableIoStates, HeadVars, HeadVarModes, VarTypes0, VarTypes, VarSet0, VarSet, TableInfo0, TableInfo, Goal, MaybeTableIoDeclInfo) :- OrigGoal = _ - OrigGoalInfo, @@ -502,11 +569,11 @@ table_gen__create_new_io_goal(OrigGoal, TableDecl, TableIoStates, HeadVars, _, SavedHeadVars) ), - generate_new_table_var("TableVar0", VarTypes0, VarTypes1, + generate_new_table_var("TableVar0", node_type, VarTypes0, VarTypes1, VarSet0, VarSet1, TableVar0), - generate_new_table_var("CounterVar", VarTypes1, VarTypes2, + generate_new_table_var("CounterVar", int_type, VarTypes1, VarTypes2, VarSet1, VarSet2, CounterVar), - generate_new_table_var("StartVar", VarTypes2, VarTypes3, + generate_new_table_var("StartVar", int_type, VarTypes2, VarTypes3, VarSet2, VarSet3, StartVar), generate_call("table_io_in_range", [TableVar0, CounterVar, StartVar], semidet, yes(impure), [TableVar0 - ground(shared, none), @@ -514,7 +581,7 @@ table_gen__create_new_io_goal(OrigGoal, TableDecl, TableIoStates, StartVar - ground(shared, none)], ModuleInfo, Context, InRangeGoal), - generate_new_table_var("TableVar", VarTypes3, VarTypes4, + generate_new_table_var("TableVar", node_type, VarTypes3, VarTypes4, VarSet3, VarSet4, TableVar), generate_call("table_lookup_insert_start_int", [TableVar0, StartVar, CounterVar, TableVar], @@ -525,14 +592,13 @@ table_gen__create_new_io_goal(OrigGoal, TableDecl, TableIoStates, semidet, yes(semipure), [], ModuleInfo, Context, OccurredGoal), ( - TableDecl = yes, + TableDecl = table_io_decl, PredId = TableInfo0 ^ table_cur_pred_id, ProcId = TableInfo0 ^ table_cur_proc_id, RttiProcLabel = rtti__make_proc_label(ModuleInfo, PredId, ProcId), TableIoDeclConsId = table_io_decl(RttiProcLabel), - get_table_var_type(TableVarType), - make_const_construction(TableIoDeclConsId, TableVarType, + make_const_construction(TableIoDeclConsId, node_type, yes("TableIoDeclPtr"), TableIoDeclGoal, TableIoDeclPtrVar, VarTypes4, VarTypes5, VarSet4, VarSet5), @@ -548,7 +614,7 @@ table_gen__create_new_io_goal(OrigGoal, TableDecl, TableIoStates, NumberedSavedHeadVars, TableIoDeclInfo), MaybeTableIoDeclInfo = yes(TableIoDeclInfo) ; - TableDecl = no, + TableDecl = table_io_proc, VarTypes5 = VarTypes4, VarSet5 = VarSet4, true_goal(TableIoDeclGoal), @@ -605,12 +671,32 @@ table_gen__create_new_io_goal(OrigGoal, TableDecl, TableIoStates, RestoreAnsGoal = RestoreAnsGoalEx - RestoreAnsGoalInfo ), generate_save_goal(NumberedSaveVars, TableVar, BlockSize, - Context, VarTypes6, VarTypes, VarSet6, VarSet, + Context, VarTypes6, VarTypes7, VarSet6, VarSet7, TableInfo0, TableInfo, SaveAnsGoal), - CallSaveAnsGoalEx = conj([OrigGoal, TableIoDeclGoal, SaveAnsGoal]), - create_instmap_delta([OrigGoal, TableIoDeclGoal, SaveAnsGoal], - CallSaveAnsInstMapDelta0), + ( + Unitize = table_io_alone, + VarSet = VarSet7, + VarTypes = VarTypes7, + CallSaveAnsGoalList = [OrigGoal, TableIoDeclGoal, SaveAnsGoal] + ; + Unitize = table_io_unitize, + generate_new_table_var("SavedTraceEnabled", int_type, + VarTypes7, VarTypes, VarSet7, VarSet, + SavedTraceEnabledVar), + generate_call("table_io_left_bracket_unitized_goal", + [SavedTraceEnabledVar], det, yes(impure), + [SavedTraceEnabledVar - ground(unique, none)], + ModuleInfo, Context, LeftBracketGoal), + generate_call("table_io_right_bracket_unitized_goal", + [SavedTraceEnabledVar], det, yes(impure), [], + ModuleInfo, Context, RightBracketGoal), + CallSaveAnsGoalList = [LeftBracketGoal, OrigGoal, + RightBracketGoal, TableIoDeclGoal, SaveAnsGoal] + ), + + CallSaveAnsGoalEx = conj(CallSaveAnsGoalList), + create_instmap_delta(CallSaveAnsGoalList, CallSaveAnsInstMapDelta0), set__insert(OrigNonLocals, TableVar, CallSaveAnsNonLocals), instmap_delta_restrict(CallSaveAnsInstMapDelta0, CallSaveAnsNonLocals, CallSaveAnsInstMapDelta), @@ -1064,7 +1150,7 @@ table_gen__var_is_io_state(VarTypes, Var) :- generate_get_table_goal(PredId, ProcId, VarTypes0, VarTypes, VarSet0, VarSet, PredTableVar, Goal) :- - generate_new_table_var("PredTable", VarTypes0, VarTypes, + generate_new_table_var("PredTable", node_type, VarTypes0, VarTypes, VarSet0, VarSet, PredTableVar), ConsId = tabling_pointer_const(PredId, ProcId), make_const_construction(PredTableVar, ConsId, GoalExpr - GoalInfo0), @@ -1114,7 +1200,7 @@ generate_non_lookup_goal(Vars, PredId, ProcId, Context, VarTypes0, VarTypes, generate_lookup_goals(Vars, Context, PredTableVar, TableNodeVar, VarTypes1, VarTypes2, VarSet1, VarSet2, TableInfo0, TableInfo, LookupGoals), - generate_new_table_var("SubgoalVar", VarTypes2, VarTypes, + generate_new_table_var("SubgoalVar", node_type, VarTypes2, VarTypes, VarSet2, VarSet, SubgoalVar), generate_call("table_nondet_setup", [TableNodeVar, SubgoalVar], det, yes(impure), [SubgoalVar - ground(unique, none)], @@ -1186,7 +1272,7 @@ gen_lookup_call_for_type(TypeCat, Type, TableVar, ArgVar, Context, VarTypes1, VarSet0, VarSet1, RangeVar, RangeUnifyGoal), - generate_new_table_var("TableNodeVar", + generate_new_table_var("TableNodeVar", node_type, VarTypes1, VarTypes, VarSet1, VarSet, NextTableVar), generate_call("table_lookup_insert_enum", @@ -1206,8 +1292,8 @@ gen_lookup_call_for_type(TypeCat, Type, TableVar, ArgVar, Context, error("gen_lookup: unexpected type") ) ; - generate_new_table_var("TableNodeVar", VarTypes0, VarTypes1, - VarSet0, VarSet1, NextTableVar), + generate_new_table_var("TableNodeVar", node_type, + VarTypes0, VarTypes1, VarSet0, VarSet1, NextTableVar), InstMapAL = [NextTableVar - ground(unique, none)], ( ( TypeCat = pred_type @@ -1263,8 +1349,8 @@ generate_save_goal(NumberedVars, TableVar, BlockSize, Context, VarTypes1, VarSet0, VarSet1, BlockSizeVar, BlockSizeVarUnifyGoal), - generate_new_table_var("AnswerTableVar", VarTypes1, VarTypes2, - VarSet1, VarSet2, AnsTableVar), + generate_new_table_var("AnswerTableVar", node_type, + VarTypes1, VarTypes2, VarSet1, VarSet2, AnsTableVar), generate_call("table_create_ans_block", [TableVar, BlockSizeVar, AnsTableVar], det, @@ -1305,8 +1391,8 @@ generate_non_save_goal(NumberedOutputVars, TableVar, BlockSize, Context, Goal) :- ModuleInfo = TableInfo0 ^ table_module_info, - generate_new_table_var("AnswerTableVar", VarTypes0, VarTypes1, - VarSet0, VarSet1, AnsTableVar0), + generate_new_table_var("AnswerTableVar", node_type, + VarTypes0, VarTypes1, VarSet0, VarSet1, AnsTableVar0), generate_call("table_nondet_get_ans_table", [TableVar, AnsTableVar0], det, yes(impure), [AnsTableVar0 - ground(unique, none)], ModuleInfo, Context, GetAnsTableGoal), @@ -1318,15 +1404,15 @@ generate_non_save_goal(NumberedOutputVars, TableVar, BlockSize, Context, semidet, yes(impure), [], ModuleInfo, Context, DuplicateCheckGoal), - generate_new_table_var("AnswerSlotVar", VarTypes2, VarTypes3, - VarSet2, VarSet3, AnsSlotVar), + generate_new_table_var("AnswerSlotVar", node_type, + VarTypes2, VarTypes3, VarSet2, VarSet3, AnsSlotVar), generate_call("table_nondet_new_ans_slot", [TableVar, AnsSlotVar], det, yes(impure), [AnsSlotVar - ground(unique, none)], ModuleInfo, Context, NewAnsSlotGoal), gen_int_construction("BlockSize", BlockSize, VarTypes3, VarTypes4, VarSet3, VarSet4, BlockSizeVar, BlockSizeVarUnifyGoal), - generate_new_table_var("AnswerBlock", VarTypes4, VarTypes5, + generate_new_table_var("AnswerBlock", node_type, VarTypes4, VarTypes5, VarSet4, VarSet5, AnsBlockVar), generate_call("table_create_ans_block", [AnsSlotVar, BlockSizeVar, AnsBlockVar], det, yes(impure), @@ -1453,7 +1539,7 @@ generate_restore_all_goal(Detism, NumberedOutputVars, TableVar, ModuleInfo, Context, VarTypes0, VarTypes, VarSet0, VarSet, Goal) :- - generate_new_table_var("AnswerTable", VarTypes0, VarTypes1, + generate_new_table_var("AnswerTable", node_type, VarTypes0, VarTypes1, VarSet0, VarSet1, AnsTableVar), ( Detism = multidet -> ReturnAllAns = "table_multi_return_all_ans" @@ -1532,7 +1618,7 @@ gen_restore_call_for_type(TypeCat, Type, TableVar, Var, OffsetVar, generate_suspend_goal(NumberedOutputVars, TableVar, ModuleInfo, Context, VarTypes0, VarTypes, VarSet0, VarSet, Goal) :- - generate_new_table_var("AnswerTable", VarTypes0, VarTypes1, + generate_new_table_var("AnswerTable", node_type, VarTypes0, VarTypes1, VarSet0, VarSet1, AnsTableVar), generate_call("table_nondet_suspend", [TableVar, AnsTableVar], nondet, yes(semipure), [AnsTableVar - ground(unique, none)], @@ -1588,13 +1674,13 @@ generate_loop_error_goal(TableInfo, Context, VarTypes0, VarTypes, %-----------------------------------------------------------------------------% -:- pred generate_new_table_var(string::in, +:- pred generate_new_table_var(string::in, (type)::in, map(prog_var, type)::in, map(prog_var, type)::out, prog_varset::in, prog_varset::out, prog_var::out) is det. -generate_new_table_var(Name, VarTypes0, VarTypes, VarSet0, VarSet, Var) :- +generate_new_table_var(Name, Type, VarTypes0, VarTypes, VarSet0, VarSet, Var) + :- varset__new_named_var(VarSet0, Name, Var, VarSet), - get_table_var_type(Type), map__set(VarTypes0, Var, Type, VarTypes). :- pred generate_call(string::in, list(prog_var)::in, determinism::in, @@ -1639,11 +1725,9 @@ gen_string_construction(VarName, VarValue, VarTypes0, VarTypes, VarSet0, VarSet, make_string_const_construction(VarValue, yes(VarName), Goal, Var, VarTypes0, VarTypes, VarSet0, VarSet). -:- pred get_table_var_type((type)::out) is det. +:- func node_type = (type). -get_table_var_type(Type) :- - mercury_public_builtin_module(BuiltinModule), - construct_type(qualified(BuiltinModule, "c_pointer") - 0, [], Type). +node_type = c_pointer_type. :- pred get_input_output_vars(list(prog_var)::in, list(mode)::in, module_info::in, list(prog_var)::out, list(prog_var)::out) is det. diff --git a/library/table_builtin.m b/library/table_builtin.m index c1ae70234..87afa4eb4 100644 --- a/library/table_builtin.m +++ b/library/table_builtin.m @@ -439,6 +439,18 @@ table_simple_mark_as_inactive(_) :- :- pred table_io_copy_io_state(io__state::di, io__state::uo) is det. + % Calls to these predicates bracket the code of foreign_procs with + % the tabled_for_io_unitize annotation. The left bracket procedure + % returns the current value of MR_trace_enabled, and then turns off + % both MR_trace_enabled and MR_io_tabling_enabled. (We don't need to + % save MR_io_tabling_enabled because we only get to this code if it + % contains true.) The right bracket code takes the value returned by + % the left bracket as input and restores both globals to the values + % they had before the call to the left bracket. + +:- impure pred table_io_left_bracket_unitized_goal(int::out) is det. +:- impure pred table_io_right_bracket_unitized_goal(int::in) is det. + % N.B. interface continued below %-----------------------------------------------------------------------------% @@ -566,6 +578,23 @@ table_simple_mark_as_inactive(_) :- S = S0; "). +:- pragma foreign_proc("C", + table_io_left_bracket_unitized_goal(TraceEnabled::out), + [will_not_call_mercury], +" + TraceEnabled = MR_trace_enabled; + MR_trace_enabled = MR_FALSE; + MR_io_tabling_enabled = MR_FALSE; +"). + +:- pragma foreign_proc("C", + table_io_right_bracket_unitized_goal(TraceEnabled::in), + [will_not_call_mercury], +" + MR_io_tabling_enabled = MR_TRUE; + MR_trace_enabled = TraceEnabled; +"). + table_io_in_range(_, _, _) :- % This version is only used for back-ends for which there is no % matching foreign_proc version. diff --git a/runtime/mercury_stack_layout.h b/runtime/mercury_stack_layout.h index 71cfe4a67..ecdbc3034 100644 --- a/runtime/mercury_stack_layout.h +++ b/runtime/mercury_stack_layout.h @@ -600,7 +600,9 @@ typedef enum { MR_EVAL_METHOD_MEMO, MR_EVAL_METHOD_MINIMAL, MR_EVAL_METHOD_TABLE_IO, - MR_EVAL_METHOD_TABLE_IO_DECL + MR_EVAL_METHOD_TABLE_IO_DECL, + MR_EVAL_METHOD_TABLE_IO_UNITIZE, + MR_EVAL_METHOD_TABLE_IO_UNITIZE_DECL } MR_EvalMethod; typedef MR_int_least8_t MR_EvalMethodInt; diff --git a/runtime/mercury_trace_base.c b/runtime/mercury_trace_base.c index e5e4961fb..3657d0e61 100644 --- a/runtime/mercury_trace_base.c +++ b/runtime/mercury_trace_base.c @@ -48,11 +48,17 @@ MR_Trace_Type MR_trace_handler = MR_TRACE_INTERNAL; /* ** Compiler generated tracing code will check whether MR_trace_enabled is true, ** before calling MR_trace. +** ** MR_trace_enabled should keep the same value throughout the execution of -** the entire program after being set in mercury_wrapper.c. There is one -** exception to this: the Mercury routines called as part of the functionality -** of the tracer itself (e.g. the term browser) should always be executed -** with MR_trace_enabled set to MR_FALSE. +** the entire program after being set in mercury_wrapper.c. There are two +** exceptions to this. First, the Mercury routines called as part of the +** functionality of the tracer itself (e.g. the term browser) should always be +** executed with MR_trace_enabled set to MR_FALSE. Second, when a procedure +** implemented in foreign code has the tabled_for_io_unitize annotation, +** which means that it can both do I/O and call Mercury code, then we turn the +** procedure and its descendants into a single unit by turning off tracing +** within the descendants. This is required to prevent the I/O tabling problems +** that could otherwise arise if we got retries from within the descendants. */ MR_bool MR_trace_enabled = MR_FALSE; diff --git a/tests/debugger/Mmakefile b/tests/debugger/Mmakefile index d911e0129..1488b19d2 100644 --- a/tests/debugger/Mmakefile +++ b/tests/debugger/Mmakefile @@ -22,6 +22,7 @@ RETRY_PROGS = \ queens \ retry \ tabled_read \ + tabled_read_unitize \ tabled_read_decl NONRETRY_PROGS = \ @@ -57,6 +58,7 @@ MLFLAGS-completion = --runtime-flags --force-readline MCFLAGS-queens_rep = --trace rep MCFLAGS-shallow = --trace shallow MCFLAGS-tabled_read = --trace-table-io +MCFLAGS-tabled_read_unitize = --trace-table-io MCFLAGS-tabled_read_decl = --trace-table-io-decl # By default, we reclaim heap on failure in non-Boehm-gc grades. # The extra stack slots required for this reclamation cause spurious @@ -293,6 +295,12 @@ shallow.out: shallow shallow.inp tabled_read.out: tabled_read tabled_read.inp tabled_read.data $(MDB) ./tabled_read < tabled_read.inp > tabled_read.out 2>&1 +tabled_read_unitize.out: tabled_read_unitize.data + +tabled_read_unitize.out: tabled_read_unitize tabled_read_unitize.inp + $(MDB) ./tabled_read_unitize < tabled_read_unitize.inp \ + > tabled_read_unitize.out 2>&1 + tabled_read_decl.out: tabled_read_decl tabled_read_decl.inp tabled_read_decl.data $(MDB) ./tabled_read_decl < tabled_read_decl.inp \ > tabled_read_decl.out 2>&1 diff --git a/tests/debugger/tabled_read_unitize.data b/tests/debugger/tabled_read_unitize.data new file mode 100644 index 000000000..f2f5ec721 --- /dev/null +++ b/tests/debugger/tabled_read_unitize.data @@ -0,0 +1,4 @@ +123 +45 +6 +789 diff --git a/tests/debugger/tabled_read_unitize.exp b/tests/debugger/tabled_read_unitize.exp new file mode 100644 index 000000000..00139f895 --- /dev/null +++ b/tests/debugger/tabled_read_unitize.exp @@ -0,0 +1,20 @@ + 1: 1 1 CALL pred tabled_read_unitize:main/2-0 (det) tabled_read_unitize.m:17 +mdb> echo on +Command echo enabled. +mdb> register --quiet +mdb> context none +Contexts will not be printed. +mdb> table_io start +io tabling started +mdb> break unitize + 0: + stop interface pred tabled_read_unitize:unitize/4-0 (det) +mdb> continue + 37: 12 2 CALL pred tabled_read_unitize:unitize/4-0 (det) +mdb> finish -a + 38: 12 2 THEN pred tabled_read_unitize:unitize/4-0 (det) t; + 39: 12 2 ELSE pred tabled_read_unitize:unitize/4-0 (det) t;c2;e; + 40: 12 2 EXIT pred tabled_read_unitize:unitize/4-0 (det) +mdb> continue -S +123 +4506 +789 diff --git a/tests/debugger/tabled_read_unitize.inp b/tests/debugger/tabled_read_unitize.inp new file mode 100644 index 000000000..7baa53bba --- /dev/null +++ b/tests/debugger/tabled_read_unitize.inp @@ -0,0 +1,9 @@ +echo on +register --quiet +context none +table_io start +break unitize +continue +finish -a +retry +continue -S diff --git a/tests/debugger/tabled_read_unitize.m b/tests/debugger/tabled_read_unitize.m new file mode 100644 index 000000000..5af908975 --- /dev/null +++ b/tests/debugger/tabled_read_unitize.m @@ -0,0 +1,120 @@ +% We define our own I/O primitives, in case the library was compiled without +% IO tabling. + +:- module tabled_read_unitize. + +:- interface. + +:- import_module io. + +:- pred main(io__state, io__state). +:- mode main(di, uo) is det. + +:- implementation. + +:- import_module list, char, int. + +main --> + tabled_read_unitize__open_input("tabled_read_unitize.data", Res, + Stream), + ( { Res = 0 } -> + tabled_read_unitize__read_num(Stream, A), + tabled_read_unitize__unitize(Stream, B), + tabled_read_unitize__read_num(Stream, C), + tabled_read_unitize__write_int(A), + tabled_read_unitize__write_int(B), + tabled_read_unitize__write_int(C) + ; + io__write_string("could not open tabled_read_unitize.data\n") + ). + +:- pragma export(tabled_read_unitize__read_num(in, out, di, uo), + "MT_read_num"). + +:- pred tabled_read_unitize__read_num(c_pointer::in, int::out, + io__state::di, io__state::uo) is det. + +tabled_read_unitize__read_num(Stream, Num) --> + tabled_read_unitize__read_num_2(Stream, 0, Num). + +:- pred tabled_read_unitize__read_num_2(c_pointer::in, int::in, int::out, + io__state::di, io__state::uo) is det. + +tabled_read_unitize__read_num_2(Stream, SoFar, N) --> + tabled_read_unitize__read_char_code(Stream, CharCode), + ( + { char__to_int(Char, CharCode) }, + { char__is_digit(Char) }, + { char__digit_to_int(Char, CharInt) } + -> + tabled_read_unitize__read_num_2(Stream, SoFar * 10 + CharInt, + N) + ; + { N = SoFar } + ). + +:- pred tabled_read_unitize__unitize(c_pointer::in, int::out, + io__state::di, io__state::uo) is det. + +:- pragma foreign_proc("C", + tabled_read_unitize__unitize(Stream::in, N::out, _IO0::di, _IO::uo), + [may_call_mercury, promise_pure, tabled_for_io_unitize], +" + MR_Integer int1; + MR_Integer int2; + + MT_read_num(Stream, &int1); + MT_read_num(Stream, &int2); + N = int1 * 100 + int2; +"). + +:- pragma c_header_code("#include "). + +:- pred tabled_read_unitize__open_input(string::in, int::out, c_pointer::out, + io__state::di, io__state::uo) is det. + +:- pragma foreign_proc("C", + tabled_read_unitize__open_input(FileName::in, Res::out, Stream::out, + IO0::di, IO::uo), + [will_not_call_mercury, promise_pure, tabled_for_io], +" + Stream = (MR_Word) fopen((const char *) FileName, ""r""); + Res = Stream? 0 : -1; + IO = IO0; +"). + +:- pred tabled_read_unitize__read_char_code(c_pointer::in, int::out, + io__state::di, io__state::uo) is det. + +:- pragma foreign_proc("C", + tabled_read_unitize__read_char_code(Stream::in, CharCode::out, + IO0::di, IO::uo), + [will_not_call_mercury, promise_pure, tabled_for_io], +" + CharCode = getc((FILE *) Stream); + IO = IO0; +"). + +:- pred tabled_read_unitize__poly_read_char_code(c_pointer::in, T::in, int::out, + io__state::di, io__state::uo) is det. + +:- pragma foreign_proc("C", + tabled_read_unitize__poly_read_char_code(Stream::in, Unused::in, + CharCode::out, IO0::di, IO::uo), + [will_not_call_mercury, promise_pure, tabled_for_io], +" + /* ignore Unused */ + CharCode = getc((FILE *) Stream); + IO = IO0; +"). + +:- pred tabled_read_unitize__write_int(int::in, io__state::di, io__state::uo) + is det. + +:- pragma foreign_proc("C", + tabled_read_unitize__write_int(N::in, IO0::di, IO::uo), + [will_not_call_mercury, promise_pure], +"{ + printf(""%d\\n"", (int) N); + IO = IO0; +}"). diff --git a/trace/mercury_trace.c b/trace/mercury_trace.c index a56b88dce..96facfbdf 100644 --- a/trace/mercury_trace.c +++ b/trace/mercury_trace.c @@ -1354,6 +1354,8 @@ MR_maybe_record_call_table(const MR_Proc_Layout *level_layout, case MR_EVAL_METHOD_TABLE_IO: case MR_EVAL_METHOD_TABLE_IO_DECL: + case MR_EVAL_METHOD_TABLE_IO_UNITIZE: + case MR_EVAL_METHOD_TABLE_IO_UNITIZE_DECL: return; }