diff --git a/src/rcallback.c b/src/rcallback.c index bc0fe4369e7..094c8daae6b 100644 --- a/src/rcallback.c +++ b/src/rcallback.c @@ -60,7 +60,7 @@ igraph_error_t R_igraph_motifs_handler(const igraph_t *graph, /* Call the R function: callback(vids, isoclass) */ PROTECT(R_fcall = Rf_lang3(callback, vids_r, isoclass_r)); - PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv)); /* Check if result is an error condition (from tryCatch) */ if (Rf_inherits(result, "error")) { @@ -110,7 +110,7 @@ igraph_error_t R_igraph_clique_handler(const igraph_vector_int_t *clique, void * /* Call the R function: callback(clique) */ PROTECT(R_fcall = Rf_lang2(callback, clique_r)); - PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv)); /* Check if result is an error condition (from tryCatch) */ if (Rf_inherits(result, "error")) { @@ -182,7 +182,7 @@ igraph_error_t R_igraph_cycle_handler( /* Call the R function: callback(vertices, edges) */ PROTECT(R_fcall = Rf_lang3(callback, vertices_r, edges_r)); - PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv)); /* Check if result is an error condition (from tryCatch) */ if (Rf_inherits(result, "error")) { @@ -242,7 +242,7 @@ igraph_error_t R_igraph_isomorphism_handler( /* Call the R function: callback(map12, map21) */ PROTECT(R_fcall = Rf_lang3(callback, map12_r, map21_r)); - PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv)); /* Check if result is an error condition (from tryCatch) */ if (Rf_inherits(result, "error")) { @@ -336,7 +336,7 @@ igraph_error_t R_igraph_bfs_handler( /* Call the R callback with the converted data */ PROTECT(R_fcall = Rf_lang2(callback, args)); - PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv)); /* Check if result is an error or interrupt condition */ if (Rf_inherits(result, "error")) { @@ -415,7 +415,7 @@ igraph_error_t R_igraph_dfs_handler_in( /* Call the R callback */ PROTECT(R_fcall = Rf_lang2(callback, args)); - PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv)); /* Check if result is an error or interrupt condition */ if (Rf_inherits(result, "error")) { @@ -464,7 +464,7 @@ igraph_error_t R_igraph_dfs_handler_out( /* Call the R callback */ PROTECT(R_fcall = Rf_lang2(callback, args)); - PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv)); + PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv)); /* Check if result is an error or interrupt condition */ if (Rf_inherits(result, "error")) { @@ -574,11 +574,11 @@ igraph_error_t R_igraph_levc_handler( PROTECT(l2 = R_MakeExternalPtr((void*)&cont, R_NilValue, R_NilValue)); PROTECT(l3 = R_MakeExternalPtr(arpack_extra, R_NilValue, R_NilValue)); PROTECT(R_multip_call = Rf_lang3(l1, l2, l3)); - PROTECT(s_multip = Rf_eval(R_multip_call, data->env_arp)); + PROTECT(s_multip = Rx_igraph_eval_callback(R_multip_call, data->env_arp)); /* Build the call: callback(membership, community, value, vector, multiplier, extra) */ PROTECT(R_fcall = Rx_igraph_i_lang7(callback, s_memb, s_comm, s_evalue, s_evector, s_multip, data->extra)); - PROTECT(res = Rf_eval(R_fcall, data->env)); + PROTECT(res = Rx_igraph_eval_callback(R_fcall, data->env)); /* Check if result is an error condition (from tryCatch) */ if (Rf_inherits(res, "error")) { diff --git a/src/rinterface.h b/src/rinterface.h index c1a18271c7b..19a1701c2f6 100644 --- a/src/rinterface.h +++ b/src/rinterface.h @@ -43,6 +43,8 @@ SEXP Rx_igraph_add_env(SEXP graph); void Rx_igraph_attribute_clean_preserve_list(void); void Rx_igraph_set_in_r_check(bool set); +bool Rx_igraph_callback_running(void); +SEXP Rx_igraph_eval_callback(SEXP call, SEXP rho); void Rx_igraph_error(void); void Rx_igraph_warning(void); void Rx_igraph_interrupt(void); diff --git a/src/rinterface_extra.c b/src/rinterface_extra.c index 0ffcc2f4d40..ffae131b33e 100644 --- a/src/rinterface_extra.c +++ b/src/rinterface_extra.c @@ -299,7 +299,7 @@ SEXP Rx_igraph_safe_eval_in_env(SEXP expr_call, SEXP rho, Rx_igraph_safe_eval_re SET_TAG(CDDR(CDR(try_catch_call)), Rf_install("interrupt")); /* execute the call */ - SEXP retval = PROTECT(Rf_eval(try_catch_call, rho)); + SEXP retval = PROTECT(Rx_igraph_eval_callback(try_catch_call, rho)); /* did we get an error or an interrupt? */ if (result) { @@ -2371,6 +2371,60 @@ void Rx_igraph_set_in_r_check(bool set) { Rx_igraph_in_r_check = set; } +/* How many R callbacks a running algorithm is waiting on. + * + * R code that igraph reaches from inside an algorithm -- a search callback, an + * attribute combination function, an ARPACK multiplication -- can find its way + * back into igraph without meaning to: `length()` on a graph calls `vcount()`, + * and lifecycle gets there through `rlang::trace_back()` while it assembles a + * backtrace for a deprecation warning. While that is going on the "finally" + * stack belongs to the algorithm that is still running, and the nested call + * must not unwind it (see R_igraph_finalizer()). */ +static int Rx_igraph_running_callbacks = 0; + +/* HELPER: internal C; must use IGRAPH_CHECK */ +bool Rx_igraph_callback_running(void) { + return Rx_igraph_running_callbacks > 0; +} + +typedef struct Rx_igraph_i_callback_t { + SEXP call; + SEXP rho; +} Rx_igraph_i_callback_t; + +/* HELPER: internal C; must use IGRAPH_CHECK */ +static SEXP Rx_igraph_i_eval_callback(void *data) { + Rx_igraph_i_callback_t *callback = data; + return Rf_eval(callback->call, callback->rho); +} + +/* HELPER: internal C; must use IGRAPH_CHECK */ +static void Rx_igraph_i_left_callback(void *data, Rboolean jump) { + (void) data; + (void) jump; + Rx_igraph_running_callbacks--; +} + +/* HELPER: internal C; must use IGRAPH_CHECK */ +SEXP Rx_igraph_eval_callback(SEXP call, SEXP rho) { + Rx_igraph_i_callback_t callback = { call, rho }; + SEXP continuation = PROTECT(R_MakeUnwindCont()); + SEXP result; + + Rx_igraph_running_callbacks++; + /* R_UnwindProtect() rather than a plain decrement afterwards: a callback + * that raises an error unwinds past us, and a count left standing would + * silence R_igraph_finalizer() for the rest of the session. */ + result = R_UnwindProtect( + Rx_igraph_i_eval_callback, &callback, + Rx_igraph_i_left_callback, NULL, + continuation + ); + + UNPROTECT(1); + return result; +} + /* HELPER: internal C; must use IGRAPH_CHECK */ void Rx_igraph_error(void) { Rx_igraph_errors_count = 0; @@ -2648,6 +2702,17 @@ SEXP Rx_igraph_set_verbose(SEXP verbose) { /* TOP-LEVEL: called from R via .Call; must use IGRAPH_R_CHECK */ SEXP R_igraph_finalizer(void) { + /* Every igraph function calls this on exit, to clean up after an algorithm + * that was left half-way. One reached from a callback is not that case: the + * "finally" stack then holds the structures of the algorithm that is still + * running, and freeing them leaves it working on destroyed memory -- the + * algorithm carries on and trips over an assertion, or takes R down with it. + * The algorithm cleans up after itself when it finishes, and the error path + * of the callback frees the stack before it aborts. */ + if (Rx_igraph_callback_running()) { + return R_NilValue; + } + IGRAPH_FINALLY_FREE(); int px = 0; SEXP rho; @@ -6070,7 +6135,7 @@ igraph_error_t Rx_igraph_i_arpack_callback(igraph_real_t *to, const igraph_real_ memcpy(REAL(s_from), from, sizeof(igraph_real_t) * (size_t) n); PROTECT(R_fcall = Rf_lang3(data->fun, s_from, data->extra)); - PROTECT(s_to = Rf_eval(R_fcall, data->rho)); + PROTECT(s_to = Rx_igraph_eval_callback(R_fcall, data->rho)); memcpy(to, REAL(s_to), sizeof(igraph_real_t) * (size_t) n); UNPROTECT(3); diff --git a/tests/testthat/_snaps/nested-igraph-calls.md b/tests/testthat/_snaps/nested-igraph-calls.md new file mode 100644 index 00000000000..311265b4a64 --- /dev/null +++ b/tests/testthat/_snaps/nested-igraph-calls.md @@ -0,0 +1,15 @@ +# a callback may signal a deprecation + + Code + order <- bfs(g, root = 1, callback = function(...) { + is.igraph(g) + FALSE + })$order + Condition + Warning: + `is.igraph()` was deprecated in igraph 2.0.0. + i Please use `is_igraph()` instead. + Warning: + `is.igraph()` was deprecated in igraph 2.0.0. + i Please use `is_igraph()` instead. + diff --git a/tests/testthat/test-nested-igraph-calls.R b/tests/testthat/test-nested-igraph-calls.R new file mode 100644 index 00000000000..80d361b67fb --- /dev/null +++ b/tests/testthat/test-nested-igraph-calls.R @@ -0,0 +1,124 @@ +# Reaching igraph again from inside a callback is easy to do without meaning +# to: `length()` on a graph calls `vcount()`, and lifecycle gets there through +# `rlang::trace_back()` while it assembles a backtrace for a deprecation +# warning. Every one of these used to leave the running algorithm working on +# structures that the nested call had freed, which ended in an igraph assertion +# or took R down with it. + +# The smallest nested igraph call there is. Callbacks continue on FALSE. +call_igraph_again <- function(...) { + vcount(make_ring(3)) + FALSE +} + +test_that("a search callback may call igraph again", { + g <- make_ring(5, directed = TRUE) + + expect_no_error(bfs(g, root = 1, callback = call_igraph_again)) + expect_no_error(dfs(g, root = 1, in.callback = call_igraph_again)) + expect_no_error(dfs(g, root = 1, out.callback = call_igraph_again)) +}) + +test_that("a clique callback may call igraph again", { + g <- make_full_graph(4) + + expect_no_error(cliques(g, min = 2, callback = call_igraph_again)) + expect_no_error(max_cliques(g, min = 2, callback = call_igraph_again)) +}) + +test_that("a motif callback may call igraph again", { + g <- make_ring(5, directed = TRUE) + + expect_no_error(motifs(g, 3, callback = call_igraph_again)) +}) + +test_that("a cycle callback may call igraph again", { + g <- make_ring(5, directed = TRUE) + + expect_no_error(simple_cycles(g, callback = call_igraph_again)) +}) + +test_that("an isomorphism callback may call igraph again", { + g <- make_ring(5, directed = TRUE) + h <- make_ring(5, directed = TRUE) + + expect_no_error(isomorphisms(g, h, callback = call_igraph_again)) + expect_no_error( + subgraph_isomorphisms(g, h, method = "vf2", callback = call_igraph_again) + ) +}) + +test_that("a community callback may call igraph again", { + g <- make_graph("Zachary") + + expect_no_error(cluster_leading_eigen(g, callback = call_igraph_again)) +}) + +test_that("an ARPACK multiplication may call igraph again", { + multiply <- function(x, extra) { + vcount(make_ring(3)) + x + } + + expect_no_error(arpack( + multiply, + options = list(n = 5, nev = 1, ncv = 3, which = "LM"), + sym = TRUE + )) +}) + +test_that("an attribute combination function may call igraph again", { + combine <- function(x) { + vcount(make_ring(3)) + sum(x) + } + + g <- make_graph(c(1, 2, 1, 2)) + E(g)$weight <- c(1, 2) + expect_no_error(simplify(g, edge.attr.comb = list(weight = combine))) + + h <- make_ring(5) + V(h)$size <- 1:5 + expect_no_error( + contract(h, c(1, 1, 2, 2, 3), vertex.attr.comb = list(size = combine)) + ) +}) + +test_that("a callback may signal a deprecation", { + # The motivating case: lifecycle reaches `vcount()` through the backtrace it + # assembles, so a deprecated function used as a callback took igraph down. + # Two vertices keep the snapshot short: the callback runs for each of them, + # and the "warning" verbosity a snapshot needs turns off the deduplication + # that leaves a user with one warning. + g <- make_ring(2, directed = TRUE) + rlang::local_options(lifecycle_verbosity = "warning") + + expect_snapshot({ + order <- bfs(g, root = 1, callback = function(...) { + is.igraph(g) + FALSE + })$order + }) +}) + +test_that("a callback may look at the graph it is given (#253)", { + g <- set_vertex_attr(make_tree(10), "xx", value = 10:19) + callback <- function(graph, data, extra) { + V(graph)[data[["vid"]]]$xx + format(graph) + FALSE + } + + expect_no_error(bfs(g, root = 1, mode = "out", callback = callback)) +}) + +test_that("an error in a callback still reaches the caller", { + # The nested call must not swallow the abort path along with the unwinding. + g <- make_ring(5, directed = TRUE) + callback <- function(...) { + vcount(make_ring(3)) + cli::cli_abort("from the callback") + } + + expect_error(bfs(g, root = 1, callback = callback), "from the callback") +}) diff --git a/tests/testthat/test-structural-properties.R b/tests/testthat/test-structural-properties.R index 6c4e5752024..eb75d0ed860 100644 --- a/tests/testthat/test-structural-properties.R +++ b/tests/testthat/test-structural-properties.R @@ -211,8 +211,6 @@ test_that("BFS callback does not blow up when an error is raised within the call }) test_that("BFS callback does not blow up when another igraph function is raised within the callback", { - skip("nested igraph call handling not implemented yet") - callback <- function(graph, data, extra) { neighbors(graph, 1) FALSE