diff --git a/NEWS.md b/NEWS.md index ca2e5c91..92768e1c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,6 +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). * `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 390e59eb..c39765a2 100644 --- a/R/class.R +++ b/R/class.R @@ -34,8 +34,10 @@ #' argument for each property. #' #' A custom constructor should call `new_object()` to create the S7 object. -#' The first argument, `.data`, should be an instance of the parent class -#' (if used). The subsequent arguments are used to set the properties. +#' `new_class()` automatically associates a custom constructor with its class, +#' so no additional class argument is needed. The first argument to +#' `new_object()`, `_parent`, should be an instance of the parent class (if +#' used). The subsequent arguments are used to set the properties. #' @param validator A function taking a single argument, `self`, the object #' to validate. #' @@ -174,6 +176,11 @@ new_class <- function( ) } + class_ref <- new_class_ref() + constructor_env <- new.env(parent = environment(constructor)) + constructor_env$.S7_class_ref <- class_ref + environment(constructor) <- constructor_env + object <- constructor # A class's metadata is stored as plain attributes on the class object. # Must synchronise with prop_names(). @@ -192,6 +199,7 @@ 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 (S7_extends_S4(object)) { S4_register_subclass(object, env = parent.frame()) @@ -384,7 +392,12 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { #' @rdname new_class #' @export new_object <- function(`_parent`, ...) { - class <- sys.function(sys.parent()) + class_ref <- get_class_ref(parent.frame()) + if (inherits(class_ref, "S7_class_ref")) { + class <- class_ref$class + } else { + class <- sys.function(sys.parent()) + } if (!inherits(class, "S7_class")) { stop2("`new_object()` must be called from within a constructor.") } @@ -417,7 +430,10 @@ new_object <- function(`_parent`, ...) { # variable; since otherwise the extra binding causes ALTREP-wrapped values to # be materialised when byte-compiled (#607). attrs <- c( - list(class = class_dispatch(class), `_S7_class` = class), + list( + class = class_dispatch(class), + `_S7_class` = if (S7_extends_S4(class)) class else class_ref %||% class + ), self_attrs, attributes(`_parent`) ) @@ -514,6 +530,33 @@ S7_class <- function(object) { ) } +S7_class_storage <- function(class) { + get_class_ref(environment(class), default = 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()) + class(ref) <- "S7_class_ref" + ref +} + +get_class_ref <- function(env, default = NULL) { + get0( + ".S7_class_ref", + envir = env, + inherits = TRUE, + ifnotfound = default + ) +} + check_prop_names <- function(properties, call = sys.call(-1L)) { nms <- names2(properties) diff --git a/R/convert.R b/R/convert.R index afae5071..a9d435ad 100644 --- a/R/convert.R +++ b/R/convert.R @@ -229,7 +229,7 @@ convert_up <- function(from, to, call = sys.call(-1L)) { } from <- zap_attr(from, c(setdiff(from_props, to_props), "S7_class")) - attr(from, "_S7_class") <- to + attr(from, "_S7_class") <- if (isS4(from)) to else S7_class_storage(to) class(from) <- class_dispatch(to) } else if (is_S4_coerce(from, to)) { from <- convert_S4(from, to) diff --git a/R/utils.R b/R/utils.R index cea489fa..ae3105a1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -12,6 +12,10 @@ global_variables <- function(names) { assign(".__global__", current, envir = env) } +obj_addr <- function(x) { + .Call(obj_addr_, x) +} + vlapply <- function(X, FUN, ...) { vapply(X = X, FUN = FUN, FUN.VALUE = logical(1), ...) } diff --git a/bench/constructor.R b/bench/constructor.R index 2683e8ab..96bea946 100644 --- a/bench/constructor.R +++ b/bench/constructor.R @@ -12,18 +12,12 @@ # 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,memory (default: both). +# Run a subset with --only=calls,classes,memory (default: all). # pkgload::load_all(quiet = TRUE) # helpers --------------------------------------------------------------------- -# Marginal bytes retained per object. The first value includes the shared class -# graph; the second includes only the new object's contribution. -bytes_per_object <- function(f) { - as.numeric(lobstr::obj_sizes(f(), f())[[2]]) -} - # A chain of `depth` classes. By default each level adds nothing, so cost scales # with the number of `new_object()` calls rather than the number of properties. # With `add_property = TRUE`, each level adds one uniquely named property. @@ -139,23 +133,62 @@ bench_calls <- function() { ) } +bench_classes <- function() { + Class <- deep_class(5) + x <- Class() + y <- Class() + x_class <- S7_class(x) + y_class <- S7_class(y) + + exprs <- list( + get = quote(S7_class(x)), + identical = quote(identical(x_class, y_class)), + extends = quote(class_extends(x_class, y_class)) + ) + + res <- bench::mark( + exprs = exprs, + env = environment(), + check = FALSE, + filter_gc = FALSE, + min_iterations = 200 + ) + data.frame( + case = names(exprs), + us = round(as.numeric(res$median) * 1e6, 1), + row.names = NULL + ) +} + # Per-instance memory, by hierarchy depth. Flat is correct: every instance # should reference one shared class object. bench_memory <- function() { depths <- c(1, 5, 10, 20) - bytes <- vapply(depths, \(d) bytes_per_object(\() deep_class(d)), numeric(1)) + bytes <- vapply( + depths, + function(d) { + Class <- deep_class(d) + # The first value includes the shared class graph; the second includes + # only the new object's contribution. + as.numeric(lobstr::obj_sizes(Class(), Class())[[2]]) + }, + numeric(1) + ) data.frame(depth = depths, bytes_per_object = round(bytes)) } # reporting ------------------------------------------------------------------- -all_benchmarks <- c("calls", "memory") +all_benchmarks <- c("calls", "classes", "memory") run_all <- function(only = all_benchmarks) { out <- list() if ("calls" %in% only) { out$calls <- bench_calls() } + if ("classes" %in% only) { + out$classes <- bench_classes() + } if ("memory" %in% only) { out$memory <- bench_memory() } diff --git a/man/new_class.Rd b/man/new_class.Rd index ecb7b018..dc8db3e5 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -55,8 +55,10 @@ on the default constructor, which will generate a function with one argument for each property. A custom constructor should call \code{new_object()} to create the S7 object. -The first argument, \code{.data}, should be an instance of the parent class -(if used). The subsequent arguments are used to set the properties.} +\code{new_class()} automatically associates a custom constructor with its class, +so no additional class argument is needed. The first argument to +\code{new_object()}, \verb{_parent}, should be an instance of the parent class (if +used). The subsequent arguments are used to set the properties.} \item{validator}{A function taking a single argument, \code{self}, the object to validate. diff --git a/src/init.c b/src/init.c index 4a880f96..4c241325 100644 --- a/src/init.c +++ b/src/init.c @@ -13,6 +13,7 @@ extern SEXP prop_set_(SEXP, SEXP, SEXP, SEXP); extern SEXP prop_storage_rename_(SEXP); extern SEXP S7_eval_bare_(SEXP, SEXP); extern SEXP class_type_(SEXP); +extern SEXP obj_addr_(SEXP); extern void prop_init(void); extern void class_type_init(void); @@ -27,6 +28,7 @@ static const R_CallMethodDef CallEntries[] = { CALLDEF(prop_storage_rename_, 1), CALLDEF(S7_eval_bare_, 2), CALLDEF(class_type_, 1), + CALLDEF(obj_addr_, 1), {NULL, NULL, 0} }; @@ -38,6 +40,7 @@ static const R_ExternalMethodDef ExternalEntries[] = { SEXP sym_ANY; SEXP sym_S7_class; SEXP sym_S7_class_legacy; +SEXP sym_class; SEXP sym_name; SEXP sym_parent; @@ -102,6 +105,7 @@ void R_init_S7(DllInfo *dll) sym_S7_class = Rf_install("_S7_class"); // Legacy name used by objects created with an older version of S7. sym_S7_class_legacy = Rf_install("S7_class"); + sym_class = Rf_install("class"); sym_name = Rf_install("name"); sym_parent = Rf_install("parent"); sym_package = Rf_install("package"); diff --git a/src/prop.c b/src/prop.c index 91045f32..c0b7135a 100644 --- a/src/prop.c +++ b/src/prop.c @@ -1,8 +1,10 @@ #include "compat.h" +#include #include extern SEXP sym_S7_class; extern SEXP sym_S7_class_legacy; +extern SEXP sym_class; extern SEXP sym_name; extern SEXP sym_parent; @@ -40,6 +42,8 @@ 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")) + S7_class = s7_get_var_in_frame(S7_class, sym_class, R_NilValue); return S7_class; } @@ -48,6 +52,12 @@ SEXP S7_class_(SEXP object) { return get_S7_class(object); } +SEXP obj_addr_(SEXP object) { + char address[2 * sizeof(void *) + 3]; + snprintf(address, sizeof(address), "%p", (void *) object); + return Rf_mkString(address); +} + static inline SEXP eval_here(SEXP lang) { PROTECT(lang); diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 869b0b26..7d25dc58 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -363,6 +363,87 @@ 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)", { + 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_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)", { + Foo := new_class( + constructor = function(x) new_object(S7_object(), x = x), + properties = list(x = class_double), + package = NULL + ) + + 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_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)", { + 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]])) + ) + + 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)", { + pkg := local_package({ + Foo := new_class() + }) + Foo <- pkg$Foo + x <- Foo() + y <- Foo() + + 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(Foo)) + expect_equal(obj_addr(S7_class(y)), obj_addr(Foo)) +}) + +test_that("new_object() supports constructors without a class reference", { + Foo := new_class(package = NULL) + environment(Foo) <- parent.env(environment(Foo)) + + x <- Foo() + expect_type(attr(x, "_S7_class", exact = TRUE), "closure") + expect_equal(S7_class(x), Foo) +}) + test_that("new_object() can be forced lazily from a constructor", { Foo := new_class( constructor = function() identity(new_object(S7_object())),