From ccb1f55bca9e10b7f52139f5dda98d130fdb58a7 Mon Sep 17 00:00:00 2001 From: Andrew Davison Date: Thu, 10 Oct 2024 15:54:41 +1000 Subject: [PATCH] More on TCO --- samples/tco.pl | 2 +- src/bif_control.c | 50 +++++++++++++++++++++++++----------- src/heap.c | 1 - src/internal.h | 2 +- src/query.c | 12 ++++----- src/unify.c | 6 +++++ tests/tests/test096.pl | 1 - tests/tests/test101.expected | 1 + tests/tests/test101.pl | 1 + 9 files changed, 50 insertions(+), 26 deletions(-) diff --git a/samples/tco.pl b/samples/tco.pl index 94d16e36e..72479b37b 100644 --- a/samples/tco.pl +++ b/samples/tco.pl @@ -24,7 +24,7 @@ main :- write(test1), write(': '), test1(1000000); write(test2), write(': '), test2(1000000); - %write(test3), write(': '), test3(1000000); + write(test3), write(': '), test3(1000000); %write(test4), write(': '), test4(1000000); %write(test5), write(': '), test5(1000000); true. diff --git a/src/bif_control.c b/src/bif_control.c index 120aae57f..aa27d79ff 100644 --- a/src/bif_control.c +++ b/src/bif_control.c @@ -84,9 +84,10 @@ bool bif_call_0(query *q, cell *p1, pl_idx p1_ctx) if (!is_callable(p1)) return throw_error(q, p1, p1_ctx, "type_error", "callable"); - cell *tmp = prepare_call(q, NOPREFIX_LEN, p1, p1_ctx, 3); + cell *tmp = prepare_call(q, NOPREFIX_LEN, p1, p1_ctx, 4); check_heap_error(tmp); pl_idx nbr_cells = p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); make_call(q, tmp+nbr_cells); @@ -181,9 +182,10 @@ static bool bif_iso_call_n(query *q) if (!call_check(q, tmp2, &status, true)) return status; - cell *tmp = prepare_call(q, PREFIX_LEN, tmp2, q->st.curr_frame, 1); + cell *tmp = prepare_call(q, PREFIX_LEN, tmp2, q->st.curr_frame, 2); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + tmp2->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_call(q, tmp+nbr_cells); if (is_tail_call(q->st.curr_instr)) @@ -208,10 +210,11 @@ bool bif_iso_call_1(query *q) return status; } - cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 3); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 4); check_heap_error(tmp); tmp[1].flags &= ~FLAG_TAIL_CALL; pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); make_call(q, tmp+nbr_cells); @@ -241,10 +244,11 @@ static bool bif_iso_once_1(query *q) return status; } - cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 4); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 5); check_heap_error(tmp); tmp[1].flags &= ~FLAG_TAIL_CALL; pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_cut_s, bif_iso_cut_0, 0, 0); make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); @@ -267,10 +271,11 @@ static bool bif_ignore_1(query *q) if (!call_check(q, tmp2, &status, false)) return status; - cell *tmp = prepare_call(q, PREFIX_LEN, tmp2, q->st.curr_frame, 4); + cell *tmp = prepare_call(q, PREFIX_LEN, tmp2, q->st.curr_frame, 5); check_heap_error(tmp); tmp[1].flags &= ~FLAG_TAIL_CALL; pl_idx nbr_cells = PREFIX_LEN + tmp2->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_cut_s, bif_iso_cut_0, 0, 0); make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); @@ -286,13 +291,15 @@ static bool bif_iso_if_then_2(query *q) { GET_FIRST_ARG(p1,callable); GET_NEXT_ARG(p2,callable); - cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 3+p2->nbr_cells+1); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 3+p2->nbr_cells+3); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_cut_s, bif_iso_cut_0, 0, 0); make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); nbr_cells += dup_cells_by_ref(tmp+nbr_cells, p2, p2_ctx, p2->nbr_cells); + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_call(q, tmp+nbr_cells); check_heap_error(push_fail_on_retry(q)); q->st.curr_instr = tmp; @@ -305,12 +312,14 @@ static bool bif_if_2(query *q) { GET_FIRST_ARG(p1,callable); GET_NEXT_ARG(p2,callable); - cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 2+p2->nbr_cells+1); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 2+p2->nbr_cells+3); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); nbr_cells += dup_cells_by_ref(tmp+nbr_cells, p2, p2_ctx, p2->nbr_cells); + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_call(q, tmp+nbr_cells); check_heap_error(push_fail_on_retry(q)); q->st.curr_instr = tmp; @@ -326,13 +335,15 @@ static bool do_if_then_else(query *q, cell *p1, cell *p2, cell *p3) return true; } - cell *tmp = prepare_call(q, PREFIX_LEN, p1, q->st.curr_frame, 3+p2->nbr_cells+1); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, q->st.curr_frame, 3+p2->nbr_cells+3); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_cut_s, bif_iso_cut_0, 0, 0); make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); nbr_cells += dup_cells_by_ref(tmp+nbr_cells, p2, q->st.curr_frame, p2->nbr_cells); + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_call(q, tmp+nbr_cells); check_heap_error(push_barrier(q)); q->st.curr_instr = tmp; @@ -348,12 +359,14 @@ static bool soft_do_if_then_else(query *q, cell *p1, cell *p2, cell *p3) return true; } - cell *tmp = prepare_call(q, PREFIX_LEN, p1, q->st.curr_frame, 2+p2->nbr_cells+1); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, q->st.curr_frame, 2+p2->nbr_cells+3); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); nbr_cells += dup_cells_by_ref(tmp+nbr_cells, p2, q->st.curr_frame, p2->nbr_cells); + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_call(q, tmp+nbr_cells); check_heap_error(push_barrier(q)); q->st.curr_instr = tmp; @@ -426,9 +439,10 @@ static bool bif_iso_disjunction_2(query *q) static bool bif_iso_negation_1(query *q) { GET_FIRST_ARG(p1,callable); - cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 5); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 6); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_cut_s, bif_iso_cut_0, 0, 0); make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); @@ -478,9 +492,10 @@ static bool bif_iso_catch_3(query *q) GET_NEXT_ARG(p2,any); GET_NEXT_ARG(p3,callable); q->retry = QUERY_OK; - cell *tmp = prepare_call(q, PREFIX_LEN, p3, p3_ctx, 3); + cell *tmp = prepare_call(q, PREFIX_LEN, p3, p3_ctx, 4); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p3->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); make_call(q, tmp+nbr_cells); @@ -522,14 +537,16 @@ static bool bif_reset_3(query *q) GET_NEXT_ARG(p2,any); GET_NEXT_ARG(p3,any); - cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 2+(1+p3->nbr_cells+1)+1); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 2+(1+p3->nbr_cells+1)+3); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_drop_barrier_s, bif_sys_drop_barrier_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); make_struct(tmp+nbr_cells++, g_sys_set_if_var_s, bif_sys_set_if_var_2, 2, p3->nbr_cells+1); nbr_cells += dup_cells_by_ref(tmp+nbr_cells, p3, p3_ctx, p3->nbr_cells); + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_atom(tmp+nbr_cells++, g_none_s); make_call(q, tmp+nbr_cells); @@ -610,9 +627,10 @@ bool bif_sys_call_cleanup_3(query *q) GET_NEXT_ARG(p2,any); GET_NEXT_ARG(p3,callable); q->retry = QUERY_OK; - cell *tmp = prepare_call(q, PREFIX_LEN, p3, p3_ctx, 3); + cell *tmp = prepare_call(q, PREFIX_LEN, p3, p3_ctx, 4); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p3->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_cleanup_if_det_s, bif_sys_cleanup_if_det_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); make_call(q, tmp+nbr_cells); @@ -626,9 +644,10 @@ bool bif_sys_call_cleanup_3(query *q) // First time through? Try the primary goal... - cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 3); + cell *tmp = prepare_call(q, PREFIX_LEN, p1, p1_ctx, 4); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + p1->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_cleanup_if_det_s, bif_sys_cleanup_if_det_1, 1, 1); make_uint(tmp+nbr_cells++, q->cp); make_call(q, tmp+nbr_cells); @@ -668,9 +687,10 @@ static bool bif_sys_countall_2(query *q) cell n; make_uint(&n, 0); reset_var(q, p2, p2_ctx, &n, q->st.curr_frame); - cell *tmp = prepare_call(q, PREFIX_LEN, tmp2, q->st.curr_frame, 4); + cell *tmp = prepare_call(q, PREFIX_LEN, tmp2, q->st.curr_frame, 5); check_heap_error(tmp); pl_idx nbr_cells = PREFIX_LEN + tmp2->nbr_cells; + make_struct(tmp+nbr_cells++, g_true_s, bif_iso_true_0, 0, 0); // see query fact matching make_struct(tmp+nbr_cells++, g_sys_counter_s, bif_sys_counter_1, 1, 1); make_ref(tmp+nbr_cells++, p2->var_nbr, p2_ctx); make_struct(tmp+nbr_cells++, g_fail_s, bif_iso_fail_0, 0, 0); diff --git a/src/heap.c b/src/heap.c index 3132ac5d3..a97345979 100644 --- a/src/heap.c +++ b/src/heap.c @@ -356,7 +356,6 @@ cell *prepare_call(query *q, bool prefix, cell *p1, pl_idx p1_ctx, unsigned extr make_struct(tmp, g_true_s, bif_iso_true_0, 0, 0); } - q->in_call++; cell *dst = tmp + (prefix ? PREFIX_LEN : NOPREFIX_LEN); dup_cells_by_ref(dst, p1, p1_ctx, p1->nbr_cells); return tmp; diff --git a/src/internal.h b/src/internal.h index abc4074ed..f3ee5e9e3 100644 --- a/src/internal.h +++ b/src/internal.h @@ -703,7 +703,7 @@ struct query_ { pl_idx q_size[MAX_QUEUES], tmpq_size[MAX_QUEUES], qp[MAX_QUEUES]; prolog_flags flags; enum q_retry retry; - int is_cyclic1, is_cyclic2, in_call; + int is_cyclic1, is_cyclic2; uint32_t vgen; int8_t halt_code; int8_t quoted; diff --git a/src/query.c b/src/query.c index 90d81f4d0..a11e4c37f 100644 --- a/src/query.c +++ b/src/query.c @@ -653,9 +653,6 @@ static void commit_frame(query *q) frame *f = GET_CURR_FRAME(); f->mid = q->st.m->id; - if (!q->st.curr_rule->owner->is_builtin) - q->st.m = q->st.curr_rule->owner->m; - bool is_det = !q->has_vars && cl->is_unique; bool next_key = has_next_key(q); bool last_match = is_det || cl->is_first_cut || !next_key; @@ -691,13 +688,11 @@ static void commit_frame(query *q) #endif } - // Matching a fact (see disjunction in bif_control.c)... + // Matching a ground fact (see disjunction in bif_control.c)... if (q->pl->opt && last_match && !body - && !q->no_tco - && !q->has_vars && !cl->nbr_vars - && cl->is_unique + && !q->no_tco ) { leave_predicate(q, q->st.pr); drop_choice(q); @@ -708,6 +703,9 @@ static void commit_frame(query *q) return; } + if (!q->st.curr_rule->owner->is_builtin) + q->st.m = q->st.curr_rule->owner->m; + if (q->pl->opt && tco) { reuse_frame(q, cl); } else { diff --git a/src/unify.c b/src/unify.c index a9c2fbf98..62af7c30a 100644 --- a/src/unify.c +++ b/src/unify.c @@ -322,6 +322,12 @@ static void set_var(query *q, const cell *c, pl_idx c_ctx, cell *v, pl_idx v_ctx if (c_attrs) q->run_hook = true; + if (is_compound(v) && (v_ctx == q->st.fp)) + q->no_tco = true; + + if (is_managed(v)) + q->no_tco = true; + // If anything outside the current frame points inside the // current frame then we can't TCO. // If anything points inside the next frame then ditto. diff --git a/tests/tests/test096.pl b/tests/tests/test096.pl index c0c3aae6e..8b64c7f29 100644 --- a/tests/tests/test096.pl +++ b/tests/tests/test096.pl @@ -1,5 +1,4 @@ :- use_module(library(clpz)). -:- use_module(library(format)). sudoku(Rows) :- length(Rows, 9), maplist(same_length(Rows), Rows), diff --git a/tests/tests/test101.expected b/tests/tests/test101.expected index de2654191..b059b6de6 100644 --- a/tests/tests/test101.expected +++ b/tests/tests/test101.expected @@ -1,2 +1,3 @@ test1: [4,0,3,7] test2: [4,0,3,7] +test3: [4,0,3,7] diff --git a/tests/tests/test101.pl b/tests/tests/test101.pl index 380002325..4be4cef41 100644 --- a/tests/tests/test101.pl +++ b/tests/tests/test101.pl @@ -1,4 +1,5 @@ :- initialization(main). + test1(0) :- !, statistics(active_frames, Fs), statistics(active_choices, Cs), statistics(active_trails, Ts), statistics(active_slots, Ss), write([Fs,Cs,Ts,Ss]), nl, fail. test1(N) :- N1 is N-1, test1(N1).