From c1ee5fa7a15a238a6b25242bc291615968993135 Mon Sep 17 00:00:00 2001 From: Randy Lai Date: Wed, 29 Apr 2020 14:05:21 -0700 Subject: [PATCH 1/5] fix queue serialization issue --- R/queue.R | 3 +-- src/collections.c | 1 + src/deque.c | 15 --------------- src/queue.c | 27 +++++++++++++++++++++------ src/queue.h | 2 ++ src/utils.c | 26 ++++++++++++++++++++++++++ src/utils.h | 6 ++++++ tests/testthat/test-queue.R | 10 ++++++++++ 8 files changed, 67 insertions(+), 23 deletions(-) diff --git a/R/queue.R b/R/queue.R index 49ca5e1..57f8576 100644 --- a/R/queue.R +++ b/R/queue.R @@ -50,8 +50,7 @@ queue <- function(items = NULL) { .Call(C_pairlist_car, q) } clear <- function() { - q <<- NULL - last <<- NULL + .Call(C_queue_clear, self) invisible(self) } size <- function() length(q) diff --git a/src/collections.c b/src/collections.c index 2355d10..9198747 100644 --- a/src/collections.c +++ b/src/collections.c @@ -14,6 +14,7 @@ SEXP missing_arg() { static const R_CallMethodDef CallEntries[] = { {"queue_push", (DL_FUNC) &queue_push, 2}, {"queue_pop", (DL_FUNC) &queue_pop, 1}, + {"queue_clear", (DL_FUNC) &queue_clear, 1}, {"stack_push", (DL_FUNC) &stack_push, 2}, {"stack_pop", (DL_FUNC) &stack_pop, 1}, {"pairlist_car", (DL_FUNC) &pairlist_car, 1}, diff --git a/src/deque.c b/src/deque.c index fbaef63..fe179b5 100644 --- a/src/deque.c +++ b/src/deque.c @@ -1,21 +1,6 @@ #include "deque.h" #include "utils.h" -// return the current item of a pairlist -SEXP pairlist_car(SEXP x) { - if (!Rf_isList(x)) - Rf_error("x must be a pairlist"); - return CAR(x); -} - - -// return the next item of a pairlist -SEXP pairlist_cdr(SEXP x) { - if (!Rf_isList(x)) - Rf_error("x must be a pairlist"); - return CDR(x); -} - SEXP deque_push(SEXP self, SEXP value) { SEXP q = PROTECT(get_sexp_value(self, "q")); diff --git a/src/queue.c b/src/queue.c index 352f670..1f5c6e9 100644 --- a/src/queue.c +++ b/src/queue.c @@ -5,20 +5,26 @@ SEXP queue_push(SEXP self, SEXP value) { PROTECT(value); SEXP q = get_sexp_value(self, "q"); - SEXP last; + SEXP last_ptr, last; SEXP v; if (q == R_NilValue) { v = PROTECT(Rf_cons(value, R_NilValue)); set_sexp_value(self, "q", v); - set_sexp_value(self, "last", v); + R_SetExternalPtrAddr(get_sexp_value(self, "last"), v); + UNPROTECT(1); } else { - last = PROTECT(get_sexp_value(self, "last")); + last_ptr = PROTECT(get_sexp_value(self, "last")); + last = PROTECT(R_ExternalPtrAddr(last_ptr)); + if (last == NULL) { + last = pairlist_last(q); + R_SetExternalPtrAddr(get_sexp_value(self, "last"), last); + } v = PROTECT(Rf_cons(value, R_NilValue)); SETCDR(last, v); - set_sexp_value(self, "last", v); - UNPROTECT(1); // last + R_SetExternalPtrAddr(last_ptr, v); + UNPROTECT(3); // last } - UNPROTECT(2); + UNPROTECT(1); return value; } @@ -29,3 +35,12 @@ SEXP queue_pop(SEXP self) { UNPROTECT(1); return CAR(q); } + + +SEXP queue_clear(SEXP self) { + set_sexp_value(self, "q", R_NilValue); + SEXP last = PROTECT(R_MakeExternalPtr(NULL, R_NilValue, R_NilValue)); + set_sexp_value(self, "last", last); + UNPROTECT(1); + return R_NilValue; +} diff --git a/src/queue.h b/src/queue.h index b14ccd4..d97920e 100644 --- a/src/queue.h +++ b/src/queue.h @@ -8,4 +8,6 @@ SEXP queue_push(SEXP self, SEXP value); SEXP queue_pop(SEXP self); +SEXP queue_clear(SEXP self); + #endif diff --git a/src/utils.c b/src/utils.c index 52798e1..c9c7b60 100644 --- a/src/utils.c +++ b/src/utils.c @@ -1,5 +1,31 @@ #include "utils.h" +// return the current value of a pairlist +SEXP pairlist_car(SEXP x) { + if (!Rf_isList(x)) + Rf_error("x must be a pairlist"); + return CAR(x); +} + +// return the next cons of a pairlist +SEXP pairlist_cdr(SEXP x) { + if (!Rf_isList(x)) + Rf_error("x must be a pairlist"); + return CDR(x); +} + +// return the last cons of a pairlist +SEXP pairlist_last(SEXP x) { + if (!Rf_isList(x)) + Rf_error("x must be a pairlist"); + SEXP nx = CDR(x); + while (!Rf_isNull(nx)) { + x = nx; + nx = CDR(x); + } + return x; +} + SEXP get_sexp_value(SEXP env, const char* name) { SEXP x = Rf_findVarInFrame(env, Rf_install(name)); diff --git a/src/utils.h b/src/utils.h index d02b429..7a644ef 100644 --- a/src/utils.h +++ b/src/utils.h @@ -6,6 +6,12 @@ #include +SEXP pairlist_car(SEXP x); + +SEXP pairlist_cdr(SEXP x); + +SEXP pairlist_last(SEXP x); + SEXP get_sexp_value(SEXP env, const char* name); void set_sexp_value(SEXP env, const char* name, SEXP value); diff --git a/tests/testthat/test-queue.R b/tests/testthat/test-queue.R index 2144644..e6cab74 100644 --- a/tests/testthat/test-queue.R +++ b/tests/testthat/test-queue.R @@ -44,3 +44,13 @@ test_that("push NULL", { expect_null(q$pop()) expect_equal(q$size(), 1) }) + + +test_that("serialization", { + q <- queue() + q$push(1)$push(2) + q2 <- unserialize(serialize(q, NULL)) + expect_equal(q2$size(), 2) + q2$push(3) + expect_equal(q2$size(), 3) +}) From b3c37f685c8bcd876e41f0c2a0efe647ff6bc933 Mon Sep 17 00:00:00 2001 From: Randy Lai Date: Wed, 29 Apr 2020 14:28:28 -0700 Subject: [PATCH 2/5] more serialization tests --- tests/testthat/test-priority_queue.R | 10 ++++++++++ tests/testthat/test-stack.R | 10 ++++++++++ 2 files changed, 20 insertions(+) diff --git a/tests/testthat/test-priority_queue.R b/tests/testthat/test-priority_queue.R index b69d25d..777cd36 100644 --- a/tests/testthat/test-priority_queue.R +++ b/tests/testthat/test-priority_queue.R @@ -64,3 +64,13 @@ test_that("grow and shrink", { for (i in 1:99) q$pop() expect_lt(length(q$self$h), len) }) + + +test_that("serialization", { + q <- priority_queue() + q$push(1)$push(2) + q2 <- unserialize(serialize(q, NULL)) + expect_equal(q2$size(), 2) + q2$push(3) + expect_equal(q2$size(), 3) +}) diff --git a/tests/testthat/test-stack.R b/tests/testthat/test-stack.R index e3cebaa..d202e6b 100644 --- a/tests/testthat/test-stack.R +++ b/tests/testthat/test-stack.R @@ -42,3 +42,13 @@ test_that("push NULL", { expect_null(q$pop()) expect_equal(q$size(), 1) }) + + +test_that("serialization", { + s <- stack() + s$push(1)$push(2) + s2 <- unserialize(serialize(s, NULL)) + expect_equal(s2$size(), 2) + s2$push(3) + expect_equal(s2$size(), 3) +}) From ddbc93ff9e1538e3fd1167d70e4a3d57c3b5d7b0 Mon Sep 17 00:00:00 2001 From: Randy Lai Date: Wed, 29 Apr 2020 19:41:21 -0700 Subject: [PATCH 3/5] fix serialzation of deque by using external pointers --- R/deque.R | 7 +- src/collections.c | 3 + src/deque.c | 130 ++++++++++++++++++++++++++++-------- src/deque.h | 8 +-- src/queue.c | 37 +++++++--- tests/testthat/test-deque.R | 16 +++++ 6 files changed, 154 insertions(+), 47 deletions(-) diff --git a/R/deque.R b/R/deque.R index ee35f9d..83e1678 100644 --- a/R/deque.R +++ b/R/deque.R @@ -59,8 +59,8 @@ deque <- function(items = NULL) { .Call(C_deque_popleft, self) } peek <- function() { - if (is.null(last)) stop("deque is empty") - .Call(C_pairlist_car, last)[[2]] + if (is.null(q)) stop("deque is empty") + .Call(C_deque_peek, self) } peekleft <- function() { if (is.null(q)) stop("deque is empty") @@ -85,8 +85,7 @@ deque <- function(items = NULL) { invisible(self) } clear <- function() { - q <<- NULL - last <<- NULL + .Call(C_deque_clear, self) invisible(self) } remove <- function(item) { diff --git a/src/collections.c b/src/collections.c index 9198747..32661d9 100644 --- a/src/collections.c +++ b/src/collections.c @@ -5,6 +5,7 @@ #include "deque.h" #include "dict.h" #include "priority_queue.h" +#include "utils.h" SEXP missing_arg() { @@ -23,7 +24,9 @@ static const R_CallMethodDef CallEntries[] = { {"deque_pushleft", (DL_FUNC) &deque_pushleft, 2}, {"deque_pop", (DL_FUNC) &deque_pop, 1}, {"deque_popleft", (DL_FUNC) &deque_popleft, 1}, + {"deque_peek", (DL_FUNC) &deque_peek, 1}, {"deque_remove", (DL_FUNC) &deque_remove, 2}, + {"deque_clear", (DL_FUNC) &deque_clear, 1}, {"dict_get", (DL_FUNC) &dict_get, 3}, {"dict_set", (DL_FUNC) &dict_set, 3}, {"dict_remove", (DL_FUNC) &dict_remove, 2}, diff --git a/src/deque.c b/src/deque.c index fe179b5..171ecbe 100644 --- a/src/deque.c +++ b/src/deque.c @@ -1,62 +1,101 @@ #include "deque.h" #include "utils.h" +#if !defined(static_inline) +#if defined(_MSC_VER) || defined(__GNUC__) +#define static_inline static __inline +#else +#define static_inline static +#endif +#endif + + +static_inline SEXP get_last_cons(SEXP q, SEXP last_ptr) { + SEXP last = PROTECT(R_ExternalPtrAddr(last_ptr)); + SEXP nextq; + if (last == NULL) { + nextq = CDR(q); + while (!Rf_isNull(nextq)) { + R_SetExternalPtrAddr(VECTOR_ELT(CAR(nextq), 0), q); + q = nextq; + nextq = CDR(q); + } + R_SetExternalPtrAddr(last_ptr, q); + last = q; + } + UNPROTECT(1); + return last; +} + SEXP deque_push(SEXP self, SEXP value) { + PROTECT(value); SEXP q = PROTECT(get_sexp_value(self, "q")); - SEXP last; - SEXP v; + SEXP last_ptr = PROTECT(get_sexp_value(self, "last")); SEXP x = PROTECT(Rf_allocVector(VECSXP ,2)); + SEXP last = PROTECT(get_last_cons(q, last_ptr)); + SEXP v; if (q == R_NilValue) { SET_VECTOR_ELT(x, 0, R_NilValue); SET_VECTOR_ELT(x, 1, value); v = PROTECT(Rf_cons(x, R_NilValue)); set_sexp_value(self, "q", v); - set_sexp_value(self, "last", v); + R_SetExternalPtrAddr(last_ptr, v); + UNPROTECT(1); } else { - last = get_sexp_value(self, "last"); - SET_VECTOR_ELT(x, 0, last); + SET_VECTOR_ELT(x, 0, PROTECT(R_MakeExternalPtr(last, R_NilValue, R_NilValue))); SET_VECTOR_ELT(x, 1, value); v = PROTECT(Rf_cons(x, R_NilValue)); SETCDR(last, v); - set_sexp_value(self, "last", v); + R_SetExternalPtrAddr(last_ptr, v); + UNPROTECT(2); } - UNPROTECT(3); + UNPROTECT(5); return value; } + SEXP deque_pushleft(SEXP self, SEXP value) { + PROTECT(value); SEXP q = PROTECT(get_sexp_value(self, "q")); - SEXP v; + SEXP last_ptr = PROTECT(get_sexp_value(self, "last")); SEXP x = PROTECT(Rf_allocVector(VECSXP ,2)); + SEXP v; if (q == R_NilValue) { SET_VECTOR_ELT(x, 0, R_NilValue); SET_VECTOR_ELT(x, 1, value); v = PROTECT(Rf_cons(x, R_NilValue)); set_sexp_value(self, "q", v); - set_sexp_value(self, "last", v); + R_SetExternalPtrAddr(last_ptr, v); + UNPROTECT(1); } else { SET_VECTOR_ELT(x, 0, R_NilValue); SET_VECTOR_ELT(x, 1, value); v = PROTECT(Rf_cons(x, q)); - SET_VECTOR_ELT(CAR(q), 0, v); + SET_VECTOR_ELT(CAR(q), 0, PROTECT(R_MakeExternalPtr(v, R_NilValue, R_NilValue))); set_sexp_value(self, "q", v); + UNPROTECT(2); } - UNPROTECT(3); + UNPROTECT(4); return value; } + SEXP deque_pop(SEXP self) { - SEXP last = PROTECT(get_sexp_value(self, "last")); - if (last == R_NilValue) Rf_error("deque is empty"); - SEXP prev = VECTOR_ELT(CAR(last), 0); - if (prev == R_NilValue) { + SEXP q = PROTECT(get_sexp_value(self, "q")); + if (q == R_NilValue) Rf_error("deque is empty"); + SEXP last_ptr = PROTECT(get_sexp_value(self, "last")); + SEXP last = PROTECT(get_last_cons(q, last_ptr)); + SEXP prev_ptr = VECTOR_ELT(CAR(last), 0); + if (prev_ptr == R_NilValue) { set_sexp_value(self, "q", R_NilValue); + R_SetExternalPtrAddr(last_ptr, NULL); } else { + SEXP prev = R_ExternalPtrAddr(prev_ptr); + R_SetExternalPtrAddr(last_ptr, prev); SETCDR(prev, R_NilValue); } - set_sexp_value(self, "last", prev); - UNPROTECT(1); + UNPROTECT(3); return VECTOR_ELT(CAR(last), 1); } @@ -65,40 +104,75 @@ SEXP deque_popleft(SEXP self) { if (q == R_NilValue) Rf_error("deque is empty"); SEXP nextq = CDR(q); if (nextq == R_NilValue) { - set_sexp_value(self, "last", R_NilValue); + set_sexp_value(self, "q", nextq); + SEXP last_ptr = PROTECT(get_sexp_value(self, "last")); + R_SetExternalPtrAddr(last_ptr, NULL); + UNPROTECT(1); } else { + set_sexp_value(self, "q", nextq); SET_VECTOR_ELT(CAR(nextq), 0, R_NilValue); } - set_sexp_value(self, "q", nextq); UNPROTECT(1); return VECTOR_ELT(CAR(q), 1); } + +SEXP deque_peek(SEXP self) { + SEXP last_ptr = PROTECT(get_sexp_value(self, "last")); + SEXP q = PROTECT(get_sexp_value(self, "q")); + if (Rf_isNull(q)) { + Rf_error("deque is empty"); + } + SEXP last = PROTECT(get_last_cons(q, last_ptr)); + SEXP value = VECTOR_ELT(CAR(last), 1); + UNPROTECT(3); + return value; +} + + SEXP deque_remove(SEXP self, SEXP value) { - SEXP q = get_sexp_value(self, "q"); - SEXP v, nextq, prev; + SEXP q = PROTECT(get_sexp_value(self, "q")); + SEXP last_ptr = PROTECT(get_sexp_value(self, "last")); + // make sure the pointers are resolved after serialization/unserialization + get_last_cons(q, last_ptr); + SEXP v, nextq, prev_ptr; while (q != R_NilValue) { v = CAR(q); nextq = CDR(q); if (R_compute_identical(VECTOR_ELT(v, 1), value, 16)) { - prev = VECTOR_ELT(v, 0); - if (nextq == R_NilValue && prev == R_NilValue) { + prev_ptr = VECTOR_ELT(v, 0); + if (nextq == R_NilValue && prev_ptr == R_NilValue) { set_sexp_value(self, "q", R_NilValue); - set_sexp_value(self, "last", R_NilValue); + R_SetExternalPtrAddr(last_ptr, NULL); } else if (nextq == R_NilValue) { + // last item + SEXP prev = R_ExternalPtrAddr(prev_ptr); SETCDR(prev, R_NilValue); - set_sexp_value(self, "last", prev); - } else if (prev == R_NilValue) { - set_sexp_value(self, "q", nextq); + R_SetExternalPtrAddr(last_ptr, prev); + } else if (prev_ptr == R_NilValue) { + // first item SET_VECTOR_ELT(CAR(nextq), 0, R_NilValue); + set_sexp_value(self, "q", nextq); } else { + SEXP prev = R_ExternalPtrAddr(prev_ptr); SETCDR(prev, nextq); - SET_VECTOR_ELT(CAR(nextq), 0, prev); + SET_VECTOR_ELT(CAR(nextq), 0, prev_ptr); } + UNPROTECT(2); return R_NilValue; } q = nextq; } + UNPROTECT(2); Rf_error("value not found"); return R_NilValue; } + + +SEXP deque_clear(SEXP self) { + set_sexp_value(self, "q", R_NilValue); + SEXP last = PROTECT(R_MakeExternalPtr(NULL, R_NilValue, R_NilValue)); + set_sexp_value(self, "last", last); + UNPROTECT(1); + return R_NilValue; +} diff --git a/src/deque.h b/src/deque.h index 39030ed..5fb376e 100644 --- a/src/deque.h +++ b/src/deque.h @@ -4,10 +4,6 @@ #include #include -SEXP pairlist_car(SEXP x); - -SEXP pairlist_cdr(SEXP x); - SEXP deque_push(SEXP self, SEXP value); SEXP deque_pushleft(SEXP self, SEXP value); @@ -16,6 +12,10 @@ SEXP deque_pop(SEXP self); SEXP deque_popleft(SEXP self); +SEXP deque_peek(SEXP self); + SEXP deque_remove(SEXP self, SEXP value); +SEXP deque_clear(SEXP self); + #endif diff --git a/src/queue.c b/src/queue.c index 1f5c6e9..aea1b6e 100644 --- a/src/queue.c +++ b/src/queue.c @@ -1,30 +1,45 @@ #include "queue.h" #include "utils.h" +#if !defined(static_inline) +#if defined(_MSC_VER) || defined(__GNUC__) +#define static_inline static __inline +#else +#define static_inline static +#endif +#endif + + +static_inline SEXP get_last_cons(SEXP q, SEXP last_ptr) { + SEXP last = PROTECT(R_ExternalPtrAddr(last_ptr)); + if (last == NULL) { + last = pairlist_last(q); + R_SetExternalPtrAddr(last_ptr, last); + } + UNPROTECT(1); + return last; +} + SEXP queue_push(SEXP self, SEXP value) { PROTECT(value); - SEXP q = get_sexp_value(self, "q"); - SEXP last_ptr, last; + SEXP q = PROTECT(get_sexp_value(self, "q")); + SEXP last_ptr = PROTECT(get_sexp_value(self, "last")); + SEXP last; SEXP v; if (q == R_NilValue) { v = PROTECT(Rf_cons(value, R_NilValue)); set_sexp_value(self, "q", v); - R_SetExternalPtrAddr(get_sexp_value(self, "last"), v); + R_SetExternalPtrAddr(last_ptr, v); UNPROTECT(1); } else { - last_ptr = PROTECT(get_sexp_value(self, "last")); - last = PROTECT(R_ExternalPtrAddr(last_ptr)); - if (last == NULL) { - last = pairlist_last(q); - R_SetExternalPtrAddr(get_sexp_value(self, "last"), last); - } + last = PROTECT(get_last_cons(q, last_ptr)); v = PROTECT(Rf_cons(value, R_NilValue)); SETCDR(last, v); R_SetExternalPtrAddr(last_ptr, v); - UNPROTECT(3); // last + UNPROTECT(2); } - UNPROTECT(1); + UNPROTECT(3); return value; } diff --git a/tests/testthat/test-deque.R b/tests/testthat/test-deque.R index eb1ffa6..5e75329 100644 --- a/tests/testthat/test-deque.R +++ b/tests/testthat/test-deque.R @@ -132,3 +132,19 @@ test_that("pushleft NULL", { expect_null(q$popleft()) expect_equal(q$size(), 1) }) + + +test_that("serialization", { + q <- deque() + q$push(1)$push(2) + q2 <- unserialize(serialize(q, NULL)) + expect_equal(q2$size(), 2) + q2$push(3) + expect_equal(q2$size(), 3) + q2$pushleft(4) + expect_equal(q2$size(), 4) + expect_equal(q2$pop(), 3) + expect_equal(q2$size(), 3) + expect_equal(q2$popleft(), 4) + expect_equal(q2$size(), 2) +}) From 0a6655a5abfd8f4c3dfc847007e4a5e791e3f1ab Mon Sep 17 00:00:00 2001 From: Randy Lai Date: Wed, 29 Apr 2020 19:46:50 -0700 Subject: [PATCH 4/5] add codecov.yml --- .Rbuildignore | 1 + codecov.yml | 1 + 2 files changed, 2 insertions(+) create mode 100644 codecov.yml diff --git a/.Rbuildignore b/.Rbuildignore index bd06b94..7330c5e 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -12,3 +12,4 @@ vignettes .*\.o ^.github$ ^.covrignore$ +^codecov.yml$ diff --git a/codecov.yml b/codecov.yml new file mode 100644 index 0000000..69cb760 --- /dev/null +++ b/codecov.yml @@ -0,0 +1 @@ +comment: false From 221cb01d264b729f4b8e6b49957b58769cd74a0c Mon Sep 17 00:00:00 2001 From: Randy Lai Date: Wed, 29 Apr 2020 19:54:09 -0700 Subject: [PATCH 5/5] add serialization test for ordered_dict --- tests/testthat/test-ordered_dict.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/testthat/test-ordered_dict.R b/tests/testthat/test-ordered_dict.R index 31b805e..261f58d 100644 --- a/tests/testthat/test-ordered_dict.R +++ b/tests/testthat/test-ordered_dict.R @@ -114,3 +114,18 @@ test_that("object indexing works", { expect_equal(d$get(f), 3) expect_equal(d$keys(), list(s, q, f)) }) + + +test_that("serialize and unserialized", { + d <- ordered_dict() + d$set("b", 2) + d$set("a", 1) + d$set("c", 3) + d$remove("c") + d2 <- unserialize(serialize(d, NULL)) + expect_equal(d2$get("a"), 1) + + d$remove("a") + d2 <- unserialize(serialize(d, NULL)) + expect_error(d2$get("a"), "not found") +})