[m-rev.] for review: make I/O tabling respect pragma no_inline
Ian MacLarty
maclarty at cs.mu.OZ.AU
Wed Sep 14 01:09:50 AEST 2005
For review by anyone.
Please note that I use the original goal_info for the new call goal. I
looked through the goal_info and there didn't seem to be anything that would
need to be changed, but I may have missed something.
Estimated hours taken: 3
Branches: main and 0.12
Make the I/O tabling transformation respect :- pragma no_inline directives
by creating a copy of the predicate to be transformed and calling the
copy, instead of duplicating the body, if :- pragma no_inline is
given.
compiler/hlds_pred.m:
Add a new functor to the pred_creation type to indicate that a pred
was created by the I/O tabling transformation.
Fix some formatting.
compiler/table_gen.m:
If the predicate to be I/O tabled should not be inlined, then
create a copy of the predicate and call the new predicate in the
transformed version.
tests/debugger/Mercury.options:
tests/debugger/Mmakefile:
tests/debugger/io_tab_goto.data:
tests/debugger/io_tab_goto.exp:
tests/debugger/io_tab_goto.inp:
tests/debugger/io_tab_goto.m:
Test that foreign C code with labels is I/O tabled correctly.
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.178
diff -u -r1.178 hlds_pred.m
--- compiler/hlds_pred.m 13 Sep 2005 04:56:04 -0000 1.178
+++ compiler/hlds_pred.m 13 Sep 2005 07:00:53 -0000
@@ -1337,7 +1337,10 @@
; aditi_magic_supp
; aditi_join
; aditi_rl_exprn
- ; deforestation.
+ ; deforestation
+ % I/O tabling will create a new predicate if the predicate
+ % to be I/O tabled must not be inlined.
+ ; io_tabling.
:- type pred_origin
---> special_pred(special_pred)
@@ -1772,7 +1775,7 @@
% polymorphically-typed arguments whose type depends on the
% values of those type_info-related variables;
% accurate GC for the MLDS back-end relies on this.
- :- type pred_info --->
+:- type pred_info --->
pred_info(
module_name :: module_name,
% Module in which pred occurs.
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.91
diff -u -r1.91 table_gen.m
--- compiler/table_gen.m 12 Sep 2005 08:41:57 -0000 1.91
+++ compiler/table_gen.m 13 Sep 2005 09:06:16 -0000
@@ -1175,9 +1175,30 @@
OrigInputVars, OrigOutputVars, !VarTypes, !VarSet,
!TableInfo, Goal, MaybeProcTableInfo) :-
OrigGoal = _ - OrigGoalInfo,
+ ModuleInfo0 = !.TableInfo ^ table_module_info,
+ module_info_pred_info(ModuleInfo0, PredId, PredInfo),
+ pred_info_get_markers(PredInfo, Markers),
+ ( check_marker(Markers, user_marked_no_inline) ->
+ %
+ % If the predicate should not be inlined, then we create a new
+ % predicate with the same body as the original predicate, which is
+ % called where-ever the original goal would appear in the transformed
+ % code. This is necessary when the original goal is foreign C code
+ % which uses labels. The original goal would otherwise be duplicated
+ % by the transformation, resulting in duplicate label errors from
+ % the C compiler.
+ %
+ clone_proc_and_create_call(PredInfo, ProcId, CallExpr, ModuleInfo0,
+ ModuleInfo),
+ NewGoal = CallExpr - OrigGoalInfo,
+ !:TableInfo = !.TableInfo ^ table_module_info := ModuleInfo
+ ;
+ NewGoal = OrigGoal,
+ ModuleInfo = ModuleInfo0
+ ),
goal_info_get_nonlocals(OrigGoalInfo, OrigNonLocals),
goal_info_get_context(OrigGoalInfo, Context),
- ModuleInfo = !.TableInfo ^ table_module_info,
+
(
TableIoStates = yes,
IoStateAssignToVars = [],
@@ -1290,7 +1311,7 @@
SaveAnswerGoals),
(
Unitize = table_io_alone,
- CallSaveAnswerGoalList = [OrigGoal, TableIoDeclGoal | SaveAnswerGoals]
+ CallSaveAnswerGoalList = [NewGoal, TableIoDeclGoal | SaveAnswerGoals]
;
Unitize = table_io_unitize,
generate_new_table_var("SavedTraceEnabled", int_type,
@@ -1302,7 +1323,7 @@
generate_call("table_io_right_bracket_unitized_goal", det,
[SavedTraceEnabledVar], impure_code, [],
ModuleInfo, Context, RightBracketGoal),
- CallSaveAnswerGoalList = [LeftBracketGoal, OrigGoal,
+ CallSaveAnswerGoalList = [LeftBracketGoal, NewGoal,
RightBracketGoal, TableIoDeclGoal | SaveAnswerGoals]
),
CallSaveAnswerGoalExpr = conj(CallSaveAnswerGoalList),
@@ -1341,8 +1362,8 @@
- CheckAndGenAnswerGoalInfo,
BodyGoalExpr = if_then_else([], InRangeGoal, CheckAndGenAnswerGoal,
- OrigGoal),
- create_instmap_delta([InRangeGoal, CheckAndGenAnswerGoal, OrigGoal],
+ NewGoal),
+ create_instmap_delta([InRangeGoal, CheckAndGenAnswerGoal, NewGoal],
BodyInstMapDelta0),
instmap_delta_restrict(OrigNonLocals, BodyInstMapDelta0, BodyInstMapDelta),
goal_info_init_hide(OrigNonLocals, BodyInstMapDelta, det, impure,
@@ -1783,6 +1804,54 @@
predicate_table_insert(PredInfo, GeneratorPredId, PredTable0, PredTable),
module_info_set_predicate_table(PredTable, ModuleInfo0, ModuleInfo),
!:TableInfo = !.TableInfo ^ table_module_info := ModuleInfo.
+
+ % clone_proc_and_create_call(PredInfo, ProcId, CallExpr, !ModuleInfo).
+ % This predicate creates a new procedure with the same body as the
+ % procedure with ProcId in PredInfo. It then creates a call goal
+ % expression which calls the new procedure with its formal arguments as the
+ % actual arguments.
+ %
+:- pred clone_proc_and_create_call(pred_info::in, proc_id::in,
+ hlds_goal_expr::out, module_info::in, module_info::out) is det.
+
+clone_proc_and_create_call(PredInfo, ProcId, CallExpr, !ModuleInfo) :-
+ pred_info_proc_info(PredInfo, ProcId, ProcInfo),
+ proc_info_context(ProcInfo, ProcContext),
+ proc_info_varset(ProcInfo, ProcVarSet),
+ proc_info_vartypes(ProcInfo, ProcVarTypes),
+ proc_info_headvars(ProcInfo, ProcHeadVars),
+ proc_info_inst_varset(ProcInfo, ProcInstVarSet),
+ proc_info_argmodes(ProcInfo, ProcHeadModes),
+ proc_info_inferred_determinism(ProcInfo, ProcDetism),
+ proc_info_goal(ProcInfo, ProcGoal),
+ proc_info_rtti_varmaps(ProcInfo, ProcRttiVarMaps),
+ proc_info_create(ProcContext, ProcVarSet, ProcVarTypes,
+ ProcHeadVars, ProcInstVarSet, ProcHeadModes,
+ ProcDetism, ProcGoal, ProcRttiVarMaps, address_is_not_taken,
+ NewProcInfo),
+ ModuleName = pred_info_module(PredInfo),
+ OrigPredName = pred_info_name(PredInfo),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+ pred_info_context(PredInfo, PredContext),
+ NewPredName = qualified(ModuleName, "OutlinedFrom_" ++ OrigPredName),
+ pred_info_arg_types(PredInfo, PredArgTypes),
+ pred_info_typevarset(PredInfo, PredTypeVarSet),
+ pred_info_get_exist_quant_tvars(PredInfo, PredExistQVars),
+ pred_info_get_class_context(PredInfo, PredClassContext),
+ pred_info_get_assertions(PredInfo, PredAssertions),
+ pred_info_get_aditi_owner(PredInfo, AditiOwner),
+ pred_info_get_markers(PredInfo, Markers),
+ pred_info_create(ModuleName, NewPredName, PredOrFunc, PredContext,
+ created(io_tabling), local, Markers, PredArgTypes,
+ PredTypeVarSet, PredExistQVars, PredClassContext,
+ PredAssertions, AditiOwner, NewProcInfo, NewProcId,
+ NewPredInfo),
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ predicate_table_insert(NewPredInfo, NewPredId,
+ PredicateTable0, PredicateTable),
+ module_info_set_predicate_table(PredicateTable, !ModuleInfo),
+ CallExpr = call(NewPredId, NewProcId, ProcHeadVars, not_builtin, no,
+ NewPredName).
:- pred keep_only_output_arg_types(assoc_list(prog_var, type)::in,
list(var_mode_pos_method)::in, list(type)::out) is det.
Index: tests/debugger/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/Mercury.options,v
retrieving revision 1.13
diff -u -r1.13 Mercury.options
--- tests/debugger/Mercury.options 15 Aug 2005 08:52:48 -0000 1.13
+++ tests/debugger/Mercury.options 13 Sep 2005 09:07:59 -0000
@@ -10,6 +10,7 @@
# The label_layout test is for a bug that showed up only with --opt-space.
MCFLAGS-label_layout = --opt-space
+MCFLAGS-io_tab_goto = --trace-table-io-all
MCFLAGS-no_inline_builtins = --no-inline-builtins
MCFLAGS-poly_io_retry = --trace-table-io-all
MCFLAGS-poly_io_retry2 = --trace-table-io-all
Index: tests/debugger/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/Mmakefile,v
retrieving revision 1.116
diff -u -r1.116 Mmakefile
--- tests/debugger/Mmakefile 15 Aug 2005 08:52:48 -0000 1.116
+++ tests/debugger/Mmakefile 13 Sep 2005 08:19:55 -0000
@@ -7,8 +7,9 @@
RETRY_PROGS = \
all_solutions \
browser_test \
- mdb_command_test \
+ io_tab_goto \
lambda_expr \
+ mdb_command_test \
queens \
retry \
tabled_read \
@@ -364,6 +365,9 @@
implied_instance.out: implied_instance implied_instance.inp
$(MDB) ./implied_instance < implied_instance.inp \
> implied_instance.out 2>&1
+
+io_tab_goto.out: io_tab_goto io_tab_goto.inp
+ $(MDB_STD) ./io_tab_goto < io_tab_goto.inp > io_tab_goto.out 2>&1
lambda_expr.out: lambda_expr lambda_expr.inp
$(MDB_STD) ./lambda_expr < lambda_expr.inp > lambda_expr.out 2>&1
Index: tests/debugger/io_tab_goto.data
===================================================================
RCS file: tests/debugger/io_tab_goto.data
diff -N tests/debugger/io_tab_goto.data
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/io_tab_goto.data 13 Sep 2005 08:16:23 -0000
@@ -0,0 +1,4 @@
+123
+456
+789
+42
Index: tests/debugger/io_tab_goto.exp
===================================================================
RCS file: tests/debugger/io_tab_goto.exp
diff -N tests/debugger/io_tab_goto.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/io_tab_goto.exp 13 Sep 2005 08:17:48 -0000
@@ -0,0 +1,55 @@
+ E1: C1 CALL pred io_tab_goto.main/2-0 (det) io_tab_goto.m:13
+mdb> echo on
+Command echo enabled.
+mdb> register --quiet
+mdb> context none
+Contexts will not be printed.
+mdb> table_io allow
+mdb> table_io
+I/O tabling has not yet started.
+mdb> break io_tab_goto__test
+ 0: + stop interface pred io_tab_goto.test/5-0 (det)
+mdb> table_io start
+I/O tabling started.
+mdb> continue
+should see this printf
+ E2: C2 CALL pred io_tab_goto.test/5-0 (det)
+mdb> finish -n
+ E3: C2 EXIT pred io_tab_goto.test/5-0 (det)
+mdb> print *
+ Stream (arg 1) '<<c_pointer>>'
+ SoFar (arg 2) 0
+ N (arg 3) 123
+mdb> retry -o -a
+ E2: C2 CALL pred io_tab_goto.test/5-0 (det)
+mdb> print *
+ Stream (arg 1) '<<c_pointer>>'
+ SoFar (arg 2) 0
+mdb> finish -n
+ E4: C2 EXIT pred io_tab_goto.test/5-0 (det)
+mdb> print *
+ Stream (arg 1) '<<c_pointer>>'
+ SoFar (arg 2) 0
+ N (arg 3) 123
+mdb> table_io end
+I/O tabling stopped.
+mdb> continue
+123
+456
+ E5: C3 CALL pred io_tab_goto.test/5-0 (det)
+mdb> finish -n
+ E6: C3 EXIT pred io_tab_goto.test/5-0 (det)
+mdb> print *
+ Stream (arg 1) '<<c_pointer>>'
+ SoFar (arg 2) 0
+ N (arg 3) 789
+mdb> retry -f
+ E5: C3 CALL pred io_tab_goto.test/5-0 (det)
+mdb> finish -n
+ E7: C3 EXIT pred io_tab_goto.test/5-0 (det)
+mdb> print *
+ Stream (arg 1) '<<c_pointer>>'
+ SoFar (arg 2) 0
+ N (arg 3) 42
+mdb> continue -S
+42
Index: tests/debugger/io_tab_goto.inp
===================================================================
RCS file: tests/debugger/io_tab_goto.inp
diff -N tests/debugger/io_tab_goto.inp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/io_tab_goto.inp 13 Sep 2005 08:15:00 -0000
@@ -0,0 +1,22 @@
+echo on
+register --quiet
+context none
+table_io allow
+table_io
+break io_tab_goto__test
+table_io start
+continue
+finish -n
+print *
+retry -o -a
+print *
+finish -n
+print *
+table_io end
+continue
+finish -n
+print *
+retry -f
+finish -n
+print *
+continue -S
Index: tests/debugger/io_tab_goto.m
===================================================================
RCS file: tests/debugger/io_tab_goto.m
diff -N tests/debugger/io_tab_goto.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/io_tab_goto.m 13 Sep 2005 08:16:15 -0000
@@ -0,0 +1,148 @@
+:- module io_tab_goto.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module list, char, int.
+
+main(!IO) :-
+ goto(!IO),
+ io_tab_goto.open_input("io_tab_goto.data", Res, Stream, !IO),
+ ( Res = 0 ->
+ io_tab_goto.part_1(Stream, !IO),
+ io_tab_goto.part_2(Stream, !IO)
+ ;
+ io.write_string("could not open io_tab_goto.data\n", !IO)
+ ).
+
+:- pred goto(io::di, io::uo) is det.
+
+:- pragma no_inline(goto/2).
+
+:- pragma foreign_proc(c, goto(IO0::di, IO::uo),
+ [tabled_for_io, promise_pure], "
+ printf(""should see this printf\\n"");
+ goto label;
+ printf(""should never see this printf\\n"");
+label:
+ IO = IO0;
+").
+
+:- pred io_tab_goto.part_1(c_pointer::in, io.state::di, io.state::uo)
+ is det.
+
+io_tab_goto.part_1(Stream) -->
+ io_tab_goto.test(Stream, 0, A),
+ io_tab_goto.write_int(A),
+ io_tab_goto.poly_test(Stream, ['a', 'b', 'c'], 0, B),
+ io_tab_goto.write_int(B).
+
+:- pred io_tab_goto.part_2(c_pointer::in, io.state::di, io.state::uo)
+ is det.
+
+io_tab_goto.part_2(Stream) -->
+ io_tab_goto.test(Stream, 0, A),
+ io_tab_goto.write_int(A).
+
+:- pred io_tab_goto.test(c_pointer::in, int::in, int::out,
+ io.state::di, io.state::uo) is det.
+
+io_tab_goto.test(Stream, SoFar, N) -->
+ io_tab_goto.read_char_code(Stream, CharCode),
+ (
+ { char.to_int(Char, CharCode) },
+ { char.is_digit(Char) },
+ { char.digit_to_int(Char, CharInt) }
+ ->
+ io_tab_goto.test(Stream, SoFar * 10 + CharInt, N)
+ ;
+ { N = SoFar }
+ ).
+
+:- pred io_tab_goto.poly_test(c_pointer::in, T::in, int::in, int::out,
+ io.state::di, io.state::uo) is det.
+
+io_tab_goto.poly_test(Stream, Unused, SoFar, N) -->
+ io_tab_goto.poly_read_char_code(Stream, Unused, CharCode),
+ (
+ { char.to_int(Char, CharCode) },
+ { char.is_digit(Char) },
+ { char.digit_to_int(Char, CharInt) }
+ ->
+ io_tab_goto.poly_test(Stream, Unused,
+ SoFar * 10 + CharInt, N)
+ ;
+ { N = SoFar }
+ ).
+
+:- pragma c_header_code("#include <stdio.h>").
+
+:- pred io_tab_goto.open_input(string::in, int::out, c_pointer::out,
+ io.state::di, io.state::uo) is det.
+
+:- pragma no_inline(io_tab_goto.open_input/5).
+
+:- pragma foreign_proc("C",
+ io_tab_goto.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;
+ goto end1;
+end1:
+ IO = IO0;
+").
+
+:- pred io_tab_goto.read_char_code(c_pointer::in, int::out,
+ io.state::di, io.state::uo) is det.
+
+:- pragma no_inline(io_tab_goto.read_char_code/4).
+
+:- pragma foreign_proc("C",
+ io_tab_goto.read_char_code(Stream::in, CharCode::out,
+ IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ CharCode = getc((FILE *) Stream);
+ goto end2;
+end2:
+ IO = IO0;
+").
+
+:- pred io_tab_goto.poly_read_char_code(c_pointer::in, T::in, int::out,
+ io.state::di, io.state::uo) is det.
+
+:- pragma no_inline(io_tab_goto.poly_read_char_code/5).
+
+:- pragma foreign_proc("C",
+ io_tab_goto.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);
+ goto end3;
+end3:
+ IO = IO0;
+").
+
+:- pred io_tab_goto.write_int(int::in, io.state::di, io.state::uo)
+ is det.
+
+:- pragma no_inline(io_tab_goto.write_int/3).
+
+:- pragma foreign_proc("C",
+ io_tab_goto.write_int(N::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"{
+ printf(""%d\\n"", (int) N);
+ goto end4;
+end4:
+ IO = IO0;
+}").
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list