diff --git a/NEWS.md b/NEWS.md index 26f7e7bb..639cb851 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,7 +20,7 @@ * `method<-` now gives a clear error when assigning a primitive function (e.g. `log`) as a method (#608). * `method<-` and `method()` now accept a length-1 list as `signature` for single-dispatch generics, matching the list-of-classes form required for multi-dispatch (#555). * `new_object()` now names its first argument `_parent` to minimise the chance of a clash with a property (#423). It also accepts a single unnamed named list as a shortcut for splicing property values, making it easier to programmatically construct an object from a list of properties (#497). -* `new_object()` no longer copies an S7 class each time a default or custom constructor creates an object. New objects instead store a shared internal class reference, which also preserves sharing when multiple objects are serialised together. Constructors created by older versions of S7 continue to work through the previous fallback (#742). +* `new_object()` no longer copies an S7 class each time a default or custom constructor creates an object. New objects instead store an external-pointer class reference, so package class definitions are not serialized with their instances. After restoration, the reference lazily resolves the current class definition and validates the object once before caching it. Classes with `package = NULL`, which cannot be looked up after restoration, are serialized with their instances. Constructors created by older versions of S7 continue to work through the previous fallback (#742). * `method<-` can now register methods on S3 and S4 generics with base types (e.g. `class_character`), S3 classes (`new_S3_class()`, `class_factor`, etc.), S7 unions (expanded to one registration per class), `class_any` (registered as the `default` method), and `NULL` (registered as the `NULL` method) (#455). * `method<-` no longer emits an "Overwriting method" message when re-registering an identical method, eliminating spurious messages from `devtools::load_all()` (#474). * `new_class()` now errors if a child class overrides a parent property with a type that doesn't extend the parent's type, since such a class could never be instantiated (#352, #708). diff --git a/R/class.R b/R/class.R index c39765a2..d1fd39d1 100644 --- a/R/class.R +++ b/R/class.R @@ -176,7 +176,7 @@ new_class <- function( ) } - class_ref <- new_class_ref() + class_ref <- new_class_ref(name = name, package = package) constructor_env <- new.env(parent = environment(constructor)) constructor_env$.S7_class_ref <- class_ref environment(constructor) <- constructor_env @@ -199,7 +199,17 @@ new_class <- function( attr(object, "S7_class_name") <- class_name attr(object, "S7_dispatch") <- S7_class_dispatch(class_name, parent_resolved) class(object) <- c("S7_class", "S7_object") - class_ref$class <- object + if (typeof(class_ref) == "externalptr") { + if (is.null(package)) { + holder <- new.env(parent = emptyenv()) + holder$class <- object + .Call(class_ref_set_serialized_, class_ref, object, holder) + } else { + .Call(class_ref_set_weak_, class_ref, object) + } + } else { + class_ref$class <- object + } if (S7_extends_S4(object)) { S4_register_subclass(object, env = parent.frame()) @@ -394,7 +404,15 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { new_object <- function(`_parent`, ...) { class_ref <- get_class_ref(parent.frame()) if (inherits(class_ref, "S7_class_ref")) { - class <- class_ref$class + if (typeof(class_ref) == "externalptr") { + class <- .Call(class_ref_get_, class_ref) + if (is.null(class)) { + class <- sys.function(sys.parent()) + .Call(class_ref_set_weak_, class_ref, class) + } + } else { + class <- class_ref$class + } } else { class <- sys.function(sys.parent()) } @@ -432,7 +450,11 @@ new_object <- function(`_parent`, ...) { attrs <- c( list( class = class_dispatch(class), - `_S7_class` = if (S7_extends_S4(class)) class else class_ref %||% class + `_S7_class` = if (S7_extends_S4(class)) { + class + } else { + class_ref_storage(class_ref, class) + } ), self_attrs, attributes(`_parent`) @@ -531,19 +553,32 @@ S7_class <- function(object) { } S7_class_storage <- function(class) { - get_class_ref(environment(class), default = class) + class_ref <- get_class_ref(environment(class)) + class_ref_storage(class_ref, class) } # Class objects are closures, which leads to two problems: # * `sys.function()` does deep copies # * `serialize()`/`saveRDS()` only de-dups environments -# We solve both problems with an environment-backed class reference. The -# reference is bound as `.S7_class_ref` in the constructor's environment and -# points back to the completed class through `$class`. Ordinary S7 objects store -# the reference instead of the closure, avoiding `sys.function()` and ensuring -# that objects serialized together share a single copy of their class. -new_class_ref <- function() { - ref <- new.env(parent = emptyenv()) +# We solve both problems with an external-pointer class reference. The reference +# is bound as `.S7_class_ref` in the constructor's environment and points to the +# completed class. Each object stores its own reference. On unserialization, the +# pointer is null and its tag is used to find the current package class +# definition. The object is validated once before the resolved class is cached +# in the pointer. Classes with `package = NULL` cannot be looked up, so they are +# stored in the pointer's protected field and serialized with it. +new_class_ref <- function(name, package) { + # Needed while S7's own classes are created before the DLL is loaded. + if (!exists("class_ref_new_", inherits = TRUE)) { + ref <- new.env(parent = emptyenv()) + class(ref) <- "S7_class_ref" + return(ref) + } + + ref <- .Call( + class_ref_new_, + list(name = name, package = package) + ) class(ref) <- "S7_class_ref" ref } @@ -557,6 +592,46 @@ get_class_ref <- function(env, default = NULL) { ) } +class_ref_storage <- function(ref, class) { + if (typeof(ref) == "externalptr") { + clone <- .Call(class_ref_clone_, ref) + class(clone) <- "S7_class_ref" + clone + } else { + ref %||% class + } +} + +class_ref_resolve <- function(object, ref) { + identity <- .Call(class_ref_tag_, ref) + package <- identity$package + name <- identity$name + + class <- if (is.null(package)) { + .Call(class_ref_serialized_, ref)$class + } else { + get0(name, envir = asNamespace(package), inherits = FALSE) + } + + if (!inherits(class, "S7_class")) { + class_name <- paste(c(package, name), collapse = "::") + stop2( + sprintf("Can't restore an object of class <%s>.", class_name), + call = NULL + ) + } + + .Call(class_ref_resolve_set_, object, ref, class) + tryCatch( + validate(object), + error = function(cnd) { + .Call(class_ref_clear_, ref) + stop(cnd) + } + ) + class +} + check_prop_names <- function(properties, call = sys.call(-1L)) { nms <- names2(properties) diff --git a/bench/constructor.R b/bench/constructor.R index 96bea946..f4686cc1 100644 --- a/bench/constructor.R +++ b/bench/constructor.R @@ -12,7 +12,7 @@ # git stash pop && Rscript bench/constructor.R --save=/tmp/after.rds # Rscript bench/constructor.R --compare=/tmp/before.rds,/tmp/after.rds # -# Run a subset with --only=calls,classes,memory (default: all). +# Run a subset with --only=calls,classes,memory,serialization (default: all). # pkgload::load_all(quiet = TRUE) @@ -22,7 +22,12 @@ pkgload::load_all(quiet = TRUE) # with the number of `new_object()` calls rather than the number of properties. # With `add_property = TRUE`, each level adds one uniquely named property. # Built programmatically, hence `new_class(name = )` rather than `:=`. -deep_class <- function(depth, abstract = FALSE, add_property = FALSE) { +deep_class <- function( + depth, + abstract = FALSE, + add_property = FALSE, + package = NULL +) { class <- S7_object for (i in seq_len(depth)) { properties <- if (add_property) { @@ -34,7 +39,8 @@ deep_class <- function(depth, abstract = FALSE, add_property = FALSE) { name = paste0("Deep", i), parent = class, abstract = abstract, - properties = properties + properties = properties, + package = package ) } class @@ -177,9 +183,27 @@ bench_memory <- function() { data.frame(depth = depths, bytes_per_object = round(bytes)) } +bench_serialization <- function() { + PackageDeep1 <- deep_class(1, package = "bench") + PackageDeep10 <- deep_class(10, package = "bench") + LocalDeep10 <- deep_class(10) + + objects <- list( + package_depth1 = PackageDeep1(), + package_depth10 = PackageDeep10(), + package_depth10_100 = replicate(100, PackageDeep10(), simplify = FALSE), + local_depth10_100 = replicate(100, LocalDeep10(), simplify = FALSE) + ) + data.frame( + case = names(objects), + bytes = vapply(objects, \(x) length(serialize(x, NULL)), integer(1)), + row.names = NULL + ) +} + # reporting ------------------------------------------------------------------- -all_benchmarks <- c("calls", "classes", "memory") +all_benchmarks <- c("calls", "classes", "memory", "serialization") run_all <- function(only = all_benchmarks) { out <- list() @@ -192,6 +216,9 @@ run_all <- function(only = all_benchmarks) { if ("memory" %in% only) { out$memory <- bench_memory() } + if ("serialization" %in% only) { + out$serialization <- bench_serialization() + } out } diff --git a/src/init.c b/src/init.c index 4c241325..b418f07f 100644 --- a/src/init.c +++ b/src/init.c @@ -14,6 +14,16 @@ extern SEXP prop_storage_rename_(SEXP); extern SEXP S7_eval_bare_(SEXP, SEXP); extern SEXP class_type_(SEXP); extern SEXP obj_addr_(SEXP); +extern SEXP class_ref_new_(SEXP); +extern SEXP class_ref_clone_(SEXP); +extern SEXP class_ref_get_(SEXP); +extern SEXP class_ref_set_(SEXP, SEXP); +extern SEXP class_ref_set_weak_(SEXP, SEXP); +extern SEXP class_ref_set_serialized_(SEXP, SEXP, SEXP); +extern SEXP class_ref_resolve_set_(SEXP, SEXP, SEXP); +extern SEXP class_ref_clear_(SEXP); +extern SEXP class_ref_tag_(SEXP); +extern SEXP class_ref_serialized_(SEXP); extern void prop_init(void); extern void class_type_init(void); @@ -29,6 +39,16 @@ static const R_CallMethodDef CallEntries[] = { CALLDEF(S7_eval_bare_, 2), CALLDEF(class_type_, 1), CALLDEF(obj_addr_, 1), + CALLDEF(class_ref_new_, 1), + CALLDEF(class_ref_clone_, 1), + CALLDEF(class_ref_get_, 1), + CALLDEF(class_ref_set_, 2), + CALLDEF(class_ref_set_weak_, 2), + CALLDEF(class_ref_set_serialized_, 3), + CALLDEF(class_ref_resolve_set_, 3), + CALLDEF(class_ref_clear_, 1), + CALLDEF(class_ref_tag_, 1), + CALLDEF(class_ref_serialized_, 1), {NULL, NULL, 0} }; diff --git a/src/prop.c b/src/prop.c index c0b7135a..71013f2e 100644 --- a/src/prop.c +++ b/src/prop.c @@ -13,6 +13,7 @@ extern SEXP sym_properties; extern SEXP sym_abstract; extern SEXP sym_constructor; extern SEXP sym_validator; +extern SEXP sym_S7_dispatch; extern SEXP ns_S7; @@ -34,6 +35,94 @@ extern SEXP fn_base_quote; extern SEXP R_TRUE; extern SEXP R_FALSE; +static +void class_ref_finalizer(SEXP ref) { + SEXP class = (SEXP) R_ExternalPtrAddr(ref); + if (class == NULL) + return; + + R_ReleaseObject(class); + R_ClearExternalPtr(ref); +} + +SEXP class_ref_new_(SEXP tag) { + return R_MakeExternalPtr(NULL, tag, R_NilValue); +} + +SEXP class_ref_get_(SEXP ref) { + SEXP class = (SEXP) R_ExternalPtrAddr(ref); + return class == NULL ? R_NilValue : class; +} + +SEXP class_ref_set_(SEXP ref, SEXP class) { + SEXP old = (SEXP) R_ExternalPtrAddr(ref); + if (old == NULL) { + R_RegisterCFinalizerEx(ref, class_ref_finalizer, TRUE); + } else { + R_ReleaseObject(old); + } + + R_SetExternalPtrAddr(ref, class); + R_PreserveObject(class); + return ref; +} + +SEXP class_ref_set_weak_(SEXP ref, SEXP class) { + R_SetExternalPtrAddr(ref, class); + return ref; +} + +SEXP class_ref_set_serialized_(SEXP ref, SEXP class, SEXP holder) { + class_ref_set_weak_(ref, class); + R_SetExternalPtrProtected(ref, holder); + return ref; +} + +SEXP class_ref_resolve_set_(SEXP object, SEXP ref, SEXP class) { + class_ref_set_(ref, class); + SEXP dispatch = Rf_getAttrib(class, sym_S7_dispatch); + Rf_setAttrib(object, R_ClassSymbol, dispatch); + return ref; +} + +SEXP class_ref_clear_(SEXP ref) { + class_ref_finalizer(ref); + return ref; +} + +SEXP class_ref_tag_(SEXP ref) { + return R_ExternalPtrTag(ref); +} + +SEXP class_ref_serialized_(SEXP ref) { + return R_ExternalPtrProtected(ref); +} + +SEXP class_ref_clone_(SEXP ref) { + SEXP clone = PROTECT(R_MakeExternalPtr( + NULL, + R_ExternalPtrTag(ref), + R_ExternalPtrProtected(ref) + )); + SEXP class = class_ref_get_(ref); + if (class != R_NilValue) + class_ref_set_(clone, class); + UNPROTECT(1); + return clone; +} + +static +SEXP class_ref_resolve(SEXP object, SEXP ref) { + SEXP call = PROTECT(Rf_lang3( + Rf_install("class_ref_resolve"), + object, + ref + )); + SEXP class = Rf_eval(call, ns_S7); + UNPROTECT(1); + return class; +} + // Read the stored S7 class object, falling back to the legacy "S7_class" // attribute name so objects created with an older version of S7 keep working. // Can be removed >1 year after S7 0.3.0 @@ -42,8 +131,15 @@ SEXP get_S7_class(SEXP object) { SEXP S7_class = Rf_getAttrib(object, sym_S7_class); if (S7_class == R_NilValue) S7_class = Rf_getAttrib(object, sym_S7_class_legacy); - if (TYPEOF(S7_class) == ENVSXP && Rf_inherits(S7_class, "S7_class_ref")) + if (TYPEOF(S7_class) == ENVSXP && Rf_inherits(S7_class, "S7_class_ref")) { S7_class = s7_get_var_in_frame(S7_class, sym_class, R_NilValue); + } + if (TYPEOF(S7_class) == EXTPTRSXP && Rf_inherits(S7_class, "S7_class_ref")) { + SEXP ref = S7_class; + S7_class = class_ref_get_(ref); + if (S7_class == R_NilValue) + S7_class = class_ref_resolve(object, ref); + } return S7_class; } diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 9fb56fa6..f030d033 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -184,6 +184,15 @@ Error in `new_object()`: ! `new_object()` must be called from within a constructor. +# restored objects must be valid under the current class + + Code + S7_class(x) + Condition + Error in `validate()`: + ! object is invalid: + - x is no longer valid + # new_object() errors if `_parent` doesn't inherit from the parent class (#409) Code diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 7d25dc58..beaa878c 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -363,20 +363,20 @@ test_that("new_object() gives useful error if called directly", { expect_snapshot(new_object(), error = TRUE) }) -test_that("new_object() stores a shared class reference (#742)", { +test_that("new_object() stores an external class reference (#742)", { Foo := new_class(package = NULL) x <- Foo() y <- Foo() x_ref <- attr(x, "_S7_class", exact = TRUE) y_ref <- attr(y, "_S7_class", exact = TRUE) - expect_type(x_ref, "environment") - expect_equal(obj_addr(x_ref), obj_addr(y_ref)) + expect_type(x_ref, "externalptr") + expect_type(y_ref, "externalptr") expect_equal(obj_addr(S7_class(x)), obj_addr(Foo)) expect_equal(obj_addr(S7_class(y)), obj_addr(Foo)) }) -test_that("custom constructors use a shared class reference (#742)", { +test_that("custom constructors use external class references (#742)", { Foo := new_class( constructor = function(x) new_object(S7_object(), x = x), properties = list(x = class_double), @@ -385,41 +385,33 @@ test_that("custom constructors use a shared class reference (#742)", { x <- Foo(1) y <- Foo(2) - expect_equal( - obj_addr(attr(x, "_S7_class", exact = TRUE)), - obj_addr(attr(y, "_S7_class", exact = TRUE)) - ) + expect_type(attr(x, "_S7_class", exact = TRUE), "externalptr") + expect_type(attr(y, "_S7_class", exact = TRUE), "externalptr") expect_equal(obj_addr(S7_class(x)), obj_addr(Foo)) expect_equal(obj_addr(S7_class(y)), obj_addr(Foo)) }) -test_that("serialisation preserves shared class references (#742)", { +test_that("serialisation lazily restores class references (#742)", { Foo := new_class(package = NULL) xy <- unserialize(serialize(list(Foo(), Foo()), NULL)) - expect_equal( - obj_addr(attr(xy[[1]], "_S7_class", exact = TRUE)), - obj_addr(attr(xy[[2]], "_S7_class", exact = TRUE)) - ) - expect_equal( - obj_addr(S7_class(xy[[1]])), - obj_addr(S7_class(xy[[2]])) - ) + x_ref <- attr(xy[[1]], "_S7_class", exact = TRUE) + y_ref <- attr(xy[[2]], "_S7_class", exact = TRUE) + expect_null(.Call(class_ref_get_, x_ref)) + expect_null(.Call(class_ref_get_, y_ref)) + expect_equal(obj_addr(S7_class(xy[[1]])), obj_addr(S7_class(xy[[2]]))) + expect_equal(S7_class(xy[[1]])@name, Foo@name) Foo_rds <- unserialize(serialize(Foo, NULL)) x <- Foo_rds() y <- Foo_rds() - expect_equal( - obj_addr(attr(x, "_S7_class", exact = TRUE)), - obj_addr(attr(y, "_S7_class", exact = TRUE)) - ) expect_equal( obj_addr(S7_class(x)), obj_addr(S7_class(y)) ) }) -test_that("classes in namespaces use shared class references (#742)", { +test_that("classes in namespaces use external class references (#742)", { pkg := local_package({ Foo := new_class() }) @@ -427,14 +419,84 @@ test_that("classes in namespaces use shared class references (#742)", { x <- Foo() y <- Foo() - expect_equal( - obj_addr(attr(x, "_S7_class", exact = TRUE)), - obj_addr(attr(y, "_S7_class", exact = TRUE)) - ) + expect_type(attr(x, "_S7_class", exact = TRUE), "externalptr") + expect_type(attr(y, "_S7_class", exact = TRUE), "externalptr") expect_equal(obj_addr(S7_class(x)), obj_addr(Foo)) expect_equal(obj_addr(S7_class(y)), obj_addr(Foo)) }) +test_that("external class references keep local classes alive", { + Foo := new_class(package = NULL) + class_address <- obj_addr(Foo) + x <- Foo() + rm(Foo) + gc() + + expect_equal(obj_addr(S7_class(x)), class_address) +}) + +test_that("restored objects resolve and validate the current class once", { + pkg := local_package({ + Foo := new_class(properties = list(x = class_double)) + }) + raw <- serialize(list(pkg$Foo(x = 1), pkg$Foo(x = 2)), NULL) + + counter <- new.env(parent = emptyenv()) + counter$n <- 0 + pkg$counter <- counter + eval( + quote({ + Parent := new_class() + Foo := new_class( + parent = Parent, + properties = list(x = class_double), + validator = function(self) { + counter$n <- counter$n + 1 + NULL + } + ) + }), + pkg + ) + + restored <- unserialize(raw) + x <- restored[[1]] + y <- restored[[2]] + ref <- attr(x, "_S7_class", exact = TRUE) + expect_null(.Call(class_ref_get_, ref)) + expect_equal(obj_addr(S7_class(x)), obj_addr(pkg$Foo)) + expect_equal(class(x), class_dispatch(pkg$Foo)) + expect_equal(counter$n, 1) + + expect_equal(obj_addr(S7_class(x)), obj_addr(pkg$Foo)) + expect_equal(counter$n, 1) + + expect_equal(obj_addr(S7_class(y)), obj_addr(pkg$Foo)) + expect_equal(counter$n, 2) + expect_equal(obj_addr(S7_class(y)), obj_addr(pkg$Foo)) + expect_equal(counter$n, 2) +}) + +test_that("restored objects must be valid under the current class", { + pkg := local_package({ + Foo := new_class(properties = list(x = class_double)) + }) + raw <- serialize(pkg$Foo(x = 1), NULL) + + eval( + quote( + Foo := new_class( + properties = list(x = class_double), + validator = function(self) "x is no longer valid" + ) + ), + pkg + ) + + x <- unserialize(raw) + expect_snapshot(S7_class(x), error = TRUE) +}) + test_that("new_object() supports constructors without a class reference", { Foo := new_class(package = NULL) environment(Foo) <- parent.env(environment(Foo)) @@ -679,7 +741,8 @@ test_that("can round trip to disk and back", { saveRDS(f, path) f2 <- readRDS(path) - expect_equal(f, f2) + expect_equal(f2@x@y, 1L) + expect_equal(S7_class(f2)@name, globalenv()[["foo2"]]@name) rm(foo1, foo2, f, envir = globalenv()) })