Reduce copies of S7 class objects

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).

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)

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)

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), ...)
 }

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()
   }

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");

src/prop.c

@@ -1,8 +1,10 @@
 #include "compat.h"
+#include <stdio.h>
 #include <string.h>
 
 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);

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())),