Lazily restore serialized S7 classes

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

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)

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
 }
 

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}
 };
 

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;
 }
 

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()`:
+      ! <pkg::Foo> object is invalid:
+      - x is no longer valid
+
 # new_object() errors if `_parent` doesn't inherit from the parent class (#409)
 
     Code