More on TCO

trealla-prolog · Oct 10, 2024 · ccb1f55 · ccb1f55
1 parent cd77b18
commit ccb1f55
Show file tree

Hide file tree

Showing 9 changed files with 50 additions and 26 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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).