diff --git a/AGENTS.md b/AGENTS.md index 83d0036..b63b798 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -52,7 +52,7 @@ All writers are count-then-write pairs: `mori_serialize_count`/`mori_serialize_i Declared in `mori.h`, C-level only (not `.Call`) — for packages embedding mori layouts under their own SHM management: -- **Layout oracle + writer**: `mori_layout_size(x)` → region size, or 0 for what the writer must not take (non-mori ALTREP nodes — would materialize via `DATAPTR_RO`; S4 bits — don't survive the layouts). Vetoes ride the size recursion (`mori_layout_size_impl` with `ok != NULL`); the host path passes `NULL` and vetoes nothing. `mori_layout_write(base, x)` emits exactly `mori_layout_size` bytes and zeroes reserved header bytes [24-63] on every write (embedders may recycle regions). +- **Layout oracle + writer**: `mori_layout_size(x)` → region size, or 0 for what the writer must not take (non-mori ALTREP nodes — would materialize via `DATAPTR_RO`). The S4 object bit rides the layouts: header flags word at offset 32 (`MORI_FLAG_S4`) for MORH/MORS/MORL roots and nested lists, bit 30 of the directory entry's `sexptype` (`MORI_ELEM_S4`) for vector/string leaves; applied with `Rf_asS4` after attributes land. Vetoes ride the size recursion (`mori_layout_size_impl` with `ok != NULL`); the host path passes `NULL` and vetoes nothing. `mori_layout_write(base, x)` emits exactly `mori_layout_size` bytes and zeroes reserved header bytes [24-63] on every write (embedders may recycle regions). - **Wrap constructors**: `mori_vec_wrap` / `mori_str_wrap` / `mori_list_wrap` build views over embedder memory, pinning `keeper` via the data1 extptr's protected slot; each takes a `release` once-hook (see Internal State). `mori_restore_attrs` reapplies trailing serialized attributes. - **Introspection + path walk**: `mori_view_check`, `mori_shm_name`, `mori_parse_id`, `mori_walk_path` (walks an index path over an open region; the caller's keeper flows into the result's chain). - **Wire hooks**: `mori_set_wire_hooks(emit, resolve)` — see Serialization Hooks. @@ -92,7 +92,7 @@ int1 ::= [1-9][0-9]* # 1-based, no leading zeros ## SHM Region Layouts -Magic in the first 4 bytes (`MORI_MAGIC_*`): MORH `0x4D4F5248` vector, MORL `0x4D4F524C` list, MORS `0x4D4F5253` string. Every layout opens with a 64-byte header; bytes [24-63] are reserved (zeroed on every write — embedders may recycle regions) for embedder cross-process state. Tables are the canonical spec; `mori_nested_write` / `morh_write` / `mors_write` (with `mori_serialize_into` for fallbacks and attrs) are the implementations. Attributes are serialized R objects (pairlist on R < 4.6, named list otherwise); `mori_restore_attrs` reapplies them on the consumer. +Magic in the first 4 bytes (`MORI_MAGIC_*`): MORH `0x4D4F5248` vector, MORL `0x4D4F524C` list, MORS `0x4D4F5253` string. Every layout opens with a 64-byte header; bytes [24-31] are reserved for embedder cross-process state, [32-35] hold a mori flags word (bit 0: S4 object bit), [36-63] are reserved (all zeroed on every write — embedders may recycle regions). Tables are the canonical spec; `mori_nested_write` / `morh_write` / `mors_write` (with `mori_serialize_into` for fallbacks and attrs) are the implementations. Attributes are serialized R objects (pairlist on R < 4.6, named list otherwise); `mori_restore_attrs` reapplies them on the consumer. **MORH — atomic vector.** Data at byte 64 (64-byte aligned for SIMD); trailing attrs after the data. @@ -102,7 +102,9 @@ Magic in the first 4 bytes (`MORI_MAGIC_*`): MORH `0x4D4F5248` vector, MORL `0x4 | 4 | 4 | sexptype | | 8 | 8 | length (int64) | | 16 | 8 | attrs_size (int64, 0 if none) | -| 24 | 40 | reserved (zero) | +| 24 | 8 | reserved (zero) — embedder cross-process state | +| 32 | 4 | flags (bit 0: S4 object bit) | +| 36 | 28 | reserved (zero) | | 64+ | | raw vector data | | 64 + length×elt_size | | serialized attributes (if `attrs_size` > 0) | @@ -114,11 +116,13 @@ Magic in the first 4 bytes (`MORI_MAGIC_*`): MORH `0x4D4F5248` vector, MORL `0x4 | 4 | 4 | n_elements (int32) | | 8 | 8 | attrs_offset (int64) | | 16 | 8 | attrs_size (int64) | -| 24 | 40 | reserved (zero) | +| 24 | 8 | reserved (zero) — embedder cross-process state | +| 32 | 4 | flags (bit 0: S4 object bit) | +| 36 | 28 | reserved (zero) | | 64 | 32×n | element directory | | varies | | element data (64-byte aligned), then serialized attributes | -Directory entry (32 bytes): `data_offset(8) + data_size(8) + sexptype(4) + attrs_size(4) + length(8)`. `sexptype`: `0` → serialized bytes (serialize.c); `STRSXP` → offset table + packed strings at `data_offset`; `VECSXP` → nested MORL region inlined at `data_offset` of size `data_size` (child header/directory/elements/attrs all inline; parent's `attrs_size` always 0 for VECSXP children); other → raw zero-copy data. Non-VECSXP attrs sit at `data_offset + data_size - attrs_size`. +Directory entry (32 bytes): `data_offset(8) + data_size(8) + sexptype(4) + attrs_size(4) + length(8)`. `sexptype`: `0` → serialized bytes (serialize.c); `STRSXP` → offset table + packed strings at `data_offset`; `VECSXP` → nested MORL region inlined at `data_offset` of size `data_size` (child header/directory/elements/attrs all inline; parent's `attrs_size` always 0 for VECSXP children); other → raw zero-copy data, with bit 30 of `sexptype` (`MORI_ELEM_S4`) flagging an S4 leaf (masked off at read). Non-VECSXP attrs sit at `data_offset + data_size - attrs_size`. **MORS — ALTSTRING.** Header + offset table + packed string bytes + optional trailing attrs. @@ -128,7 +132,9 @@ Directory entry (32 bytes): `data_offset(8) + data_size(8) + sexptype(4) + attrs | 4 | 4 | attrs_size (int32, 0 if none) | | 8 | 8 | n_strings (int64) | | 16 | 8 | str_data_size (int64: offset-table start → end of packed strings, incl. padding) | -| 24 | 40 | reserved (zero) | +| 24 | 8 | reserved (zero) — embedder cross-process state | +| 32 | 4 | flags (bit 0: S4 object bit) | +| 36 | 28 | reserved (zero) | | 64 | 16×n | offset table | | 64 + align64(16×n) | | packed string bytes | | 64 + str_data_size | | serialized attributes (if `attrs_size` > 0) | diff --git a/DESCRIPTION b/DESCRIPTION index 39a6667..5ee13d9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,6 +23,6 @@ Suggests: testthat (>= 3.0.0) Config/build/compilation-database: true Config/roxygen2/markdown: TRUE -Config/roxygen2/version: 8.0.0 +Config/roxygen2/version: 8.1.0 Config/testthat/edition: 3 Encoding: UTF-8 diff --git a/NEWS.md b/NEWS.md index e026a25..f668929 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,7 @@ # mori (development version) * Region layouts now open with a 64-byte header. +* `share()` now supports S4 objects built on vectors or lists (previously the S4 object bit was silently dropped). * `share()` of attribute-heavy objects and nested lists is faster: the write pass no longer re-serializes each element just to measure its size. * Fixed type confusion on unserialize when a shared string's content resembled a shared memory identifier (e.g. a stored `shared_name()` value). * Fixed a forked child process (e.g. `parallel::mclapply`) unlinking the parent's live region when garbage-collecting an inherited shared object. diff --git a/R/share.R b/R/share.R index 862fe5f..26d9735 100644 --- a/R/share.R +++ b/R/share.R @@ -7,7 +7,7 @@ #' #' @return For atomic vectors (including character vectors and those with #' attributes such as names, dim, class, or levels) and lists or data -#' frames whose elements are such vectors, an ALTREP-backed object that +#' frames, an ALTREP-backed object that #' reads directly from shared memory. For any other object (environments, #' closures, language objects, `NULL`), the input is returned unchanged #' with no shared memory region created. @@ -20,6 +20,17 @@ #' compactly by its shared memory name (~30 bytes) rather than by its #' contents. #' +#' An S4 object whose data part is an atomic vector, a character vector, +#' or a list stays an S4 object when it is shared. The class and the slots +#' are preserved, and S4 method dispatch works on the shared object. The +#' data part is shared without a copy. The slots are serialised and +#' restored on the consumer side as copies. +#' +#' A shared list can hold elements of any type. An element that is not an +#' atomic vector, a character vector, or a list is serialised and restored +#' as a copy on access. This applies to environments, closures, and +#' language objects. +#' #' The shared memory region is managed automatically. It stays alive as long #' as the returned object (or any element extracted from it) is referenced #' in R, and is freed automatically when no references remain or the session diff --git a/man/share.Rd b/man/share.Rd index c8f83b3..5f4b581 100644 --- a/man/share.Rd +++ b/man/share.Rd @@ -12,7 +12,7 @@ share(x) \value{ For atomic vectors (including character vectors and those with attributes such as names, dim, class, or levels) and lists or data -frames whose elements are such vectors, an ALTREP-backed object that +frames, an ALTREP-backed object that reads directly from shared memory. For any other object (environments, closures, language objects, \code{NULL}), the input is returned unchanged with no shared memory region created. @@ -29,6 +29,17 @@ elements are materialised lazily on access. When serialised (e.g. by compactly by its shared memory name (~30 bytes) rather than by its contents. +An S4 object whose data part is an atomic vector, a character vector, +or a list stays an S4 object when it is shared. The class and the slots +are preserved, and S4 method dispatch works on the shared object. The +data part is shared without a copy. The slots are serialised and +restored on the consumer side as copies. + +A shared list can hold elements of any type. An element that is not an +atomic vector, a character vector, or a list is serialised and restored +as a copy on access. This applies to environments, closures, and +language objects. + The shared memory region is managed automatically. It stays alive as long as the returned object (or any element extracted from it) is referenced in R, and is freed automatically when no references remain or the session diff --git a/src/altrep.c b/src/altrep.c index 3fa19d1..e4afc58 100644 --- a/src/altrep.c +++ b/src/altrep.c @@ -34,6 +34,10 @@ typedef struct { int64_t length; } mori_elem; +/* S4 flag riding a directory entry's sexptype: SEXPTYPEs are small + positive values, so bit 30 is free. Set at write, masked off at read. */ +#define MORI_ELEM_S4 0x40000000 + /* ALTSTRING offset table entry (16 bytes per string). str_length < 0 sentinel means NA_STRING. str_encoding is a cetype_t. */ @@ -507,6 +511,8 @@ static SEXP mori_unwrap_element(unsigned char *base, int64_t region_size, int64_t data_offset = entry.data_offset, data_size = entry.data_size; int64_t length = entry.length; int32_t sexptype = entry.sexptype, attrs_size = entry.attrs_size; + int s4 = sexptype & MORI_ELEM_S4; + sexptype &= ~MORI_ELEM_S4; if (mori_oob(data_offset, data_size, region_size)) Rf_error("mori: invalid element data"); @@ -547,6 +553,7 @@ static SEXP mori_unwrap_element(unsigned char *base, int64_t region_size, size_t attrs_off = (size_t)(data_offset + data_size - attrs_size); mori_restore_attrs(result, base + attrs_off, (size_t) attrs_size); } + if (s4) result = Rf_asS4(result, TRUE, 0); UNPROTECT(1); return result; @@ -566,7 +573,9 @@ static SEXP mori_unwrap_element(unsigned char *base, int64_t region_size, * Bytes 4-7: int32_t n_elements * Bytes 8-15: int64_t attrs_offset * Bytes 16-23: int64_t attrs_size - * Bytes 24-63: reserved (zero) — embedder cross-process state + * Bytes 24-31: reserved (zero) — embedder cross-process state + * Bytes 32-35: uint32_t flags (bit 0: S4 object bit) + * Bytes 36-63: reserved (zero) * Byte 64+: element directory (32 bytes per element) */ @@ -636,6 +645,7 @@ SEXP mori_list_wrap(unsigned char *base, int64_t region_size, int32_t index, if (attrs_size > 0) mori_restore_attrs(result, base + (size_t) attrs_offset, (size_t) attrs_size); + result = mori_apply_s4(result, base); UNPROTECT(2); return result; @@ -841,8 +851,7 @@ static size_t mori_nested_write(unsigned char *base, SEXP x); ok is NULL on the host path. When non-NULL (the embedder layout oracle), each node is vetted before sizing and the first rejection sets *ok = 0 and bails out with return 0: a non-mori ALTREP node would materialize through - DATAPTR_RO at write (a compact 1:1e8 becomes an 800 MB memcpy), and S4 - bits do not survive the layouts. */ + DATAPTR_RO at write (a compact 1:1e8 becomes an 800 MB memcpy). */ static size_t mori_nested_size(SEXP x, int *ok) { R_xlen_t n = XLENGTH(x); @@ -852,17 +861,13 @@ static size_t mori_nested_size(SEXP x, int *ok) { SEXP elt = VECTOR_ELT(x, i); if (ok != NULL) { - if (ALTREP(elt)) { - if (!mori_view_check(elt)) { *ok = 0; return 0; } - } else if (Rf_isS4(elt)) { - *ok = 0; return 0; - } + if (ALTREP(elt) && !mori_view_check(elt)) { *ok = 0; return 0; } } int type = TYPEOF(elt); size_t elt_size; - if (type == LISTSXP || type == VECSXP) { + if (type == VECSXP || (type == LISTSXP && !Rf_isS4(elt))) { SEXP coerced = (type == LISTSXP) ? Rf_coerceVector(elt, VECSXP) : elt; PROTECT(coerced); elt_size = mori_nested_size(coerced, ok); @@ -906,6 +911,8 @@ static size_t mori_nested_write(unsigned char *base, SEXP x) { /* Reserved header bytes [24-63] are zeroed on every write: an embedder may recycle regions, so no stale field may survive a reuse. */ memset(base + 24, 0, MORI_HEADER_SIZE - 24); + uint32_t flags = Rf_isS4(x) ? MORI_FLAG_S4 : 0u; + memcpy(base + MORI_FLAGS_OFF, &flags, 4); for (R_xlen_t i = 0; i < n; i++) { SEXP elt = VECTOR_ELT(x, i); @@ -913,7 +920,7 @@ static size_t mori_nested_write(unsigned char *base, SEXP x) { mori_elem entry; entry.data_offset = (int64_t) cur; - if (type == LISTSXP || type == VECSXP) { + if (type == VECSXP || (type == LISTSXP && !Rf_isS4(elt))) { SEXP coerced = (type == LISTSXP) ? Rf_coerceVector(elt, VECSXP) : elt; PROTECT(coerced); size_t written = mori_nested_write(base + cur, coerced); @@ -936,7 +943,7 @@ static size_t mori_nested_write(unsigned char *base, SEXP x) { if (elt_attrs != R_NilValue) attrs_size = mori_serialize_into(base + cur + raw_size, elt_attrs); - entry.sexptype = type; + entry.sexptype = type | (Rf_isS4(elt) ? MORI_ELEM_S4 : 0); entry.attrs_size = (int32_t) attrs_size; entry.length = (int64_t) XLENGTH(elt); entry.data_size = (int64_t) (raw_size + attrs_size); @@ -1033,10 +1040,12 @@ static void morh_write(unsigned char *base, SEXP x) { int32_t sexptype = (int32_t) type; int64_t length = (int64_t) n; int64_t as64 = (int64_t) attrs_size; + uint32_t flags = Rf_isS4(x) ? MORI_FLAG_S4 : 0u; memcpy(base, &magic, 4); memcpy(base + 4, &sexptype, 4); memcpy(base + 8, &length, 8); memcpy(base + 16, &as64, 8); + memcpy(base + MORI_FLAGS_OFF, &flags, 4); UNPROTECT(1); } @@ -1069,10 +1078,12 @@ static void mors_write(unsigned char *base, SEXP x) { int32_t as32 = (int32_t) attrs_size; int64_t n64 = (int64_t) n; int64_t sd = (int64_t) str_size; + uint32_t flags = Rf_isS4(x) ? MORI_FLAG_S4 : 0u; memcpy(base, &magic, 4); memcpy(base + 4, &as32, 4); memcpy(base + 8, &n64, 8); memcpy(base + 16, &sd, 8); + memcpy(base + MORI_FLAGS_OFF, &flags, 4); UNPROTECT(1); } @@ -1087,13 +1098,11 @@ static void mors_write(unsigned char *base, SEXP x) { header. */ static size_t mori_layout_size_impl(SEXP x, int *ok) { if (ok != NULL) { - if (ALTREP(x)) { - if (!mori_view_check(x)) { *ok = 0; return 0; } - } else if (Rf_isS4(x)) { - *ok = 0; return 0; - } + if (ALTREP(x) && !mori_view_check(x)) { *ok = 0; return 0; } } int type = TYPEOF(x); + /* An S4 pairlist root passes through: VECSXP coercion drops the bit. */ + if (type == LISTSXP && Rf_isS4(x)) return 0; if (type == VECSXP || type == LISTSXP) { if (type == LISTSXP) { x = PROTECT(Rf_coerceVector(x, VECSXP)); @@ -1196,6 +1205,7 @@ static SEXP mori_open_vector(SEXP shm_ptr) { mori_restore_attrs(result, base + MORI_HEADER_SIZE + data_bytes, (size_t) attrs_size); } + result = mori_apply_s4(result, base); UNPROTECT(1); return result; @@ -1227,6 +1237,7 @@ static SEXP mori_open_string(SEXP shm_ptr) { if (attrs_size > 0) mori_restore_attrs(result, base + MORI_HEADER_SIZE + (size_t) str_data_size, (size_t) attrs_size); + result = mori_apply_s4(result, base); UNPROTECT(1); return result; @@ -1468,7 +1479,7 @@ SEXP mori_walk_path(unsigned char *base, int64_t region_size, mori_elem entry; memcpy(&entry, dir, sizeof(mori_elem)); int64_t data_offset = entry.data_offset, data_size = entry.data_size; - int32_t sexptype = entry.sexptype; + int32_t sexptype = entry.sexptype & ~MORI_ELEM_S4; if (sexptype != VECSXP) Rf_error("mori: path step is not a nested list"); diff --git a/src/mori.h b/src/mori.h index 8f287a2..ff136a1 100644 --- a/src/mori.h +++ b/src/mori.h @@ -19,6 +19,13 @@ #define MORI_TAG_HOST "mori_host" #define MORI_TAG_OWNED "mori_owned" +/* Region header flags word at byte offset 32 of the 64-byte header — + bytes [24-31] remain embedder cross-process state, [36-63] reserved. + Bit 0 records the S4 object bit, which the layouts otherwise cannot + carry. */ +#define MORI_FLAGS_OFF 32 +#define MORI_FLAG_S4 0x1u + // Types ----------------------------------------------------------------------- typedef struct mori_buf_s { @@ -73,6 +80,18 @@ static inline size_t mori_sizeof_elt(int type) { } } +/* Apply a region header's S4 flag to a freshly wrapped view — after + attributes land, so a read never consults a class definition + (Rf_asS4 with complete = 0 sets the bit in place on a fresh object). + Call on a validated region (>= MORI_HEADER_SIZE bytes); embedders + wrapping MORH / MORS roots through the raw constructors call this + last. */ +static inline SEXP mori_apply_s4(SEXP x, const unsigned char *base) { + uint32_t flags; + memcpy(&flags, base + MORI_FLAGS_OFF, 4); + return (flags & MORI_FLAG_S4) ? Rf_asS4(x, TRUE, 0) : x; +} + // altrep.c -------------------------------------------------------------------- void mori_altrep_init(DllInfo *dll); @@ -98,9 +117,9 @@ void mori_restore_attrs(SEXP result, unsigned char *buf, size_t size); /* Layout oracle and writer for embedder-managed regions: the size pass walks the tree and returns 0 for anything the layout writer must not - take (a non-mori ALTREP node would materialize through DATAPTR_RO; S4 - bits do not survive the layouts). The write emits exactly - mori_layout_size bytes and zeroes header reserved bytes. */ + take (a non-mori ALTREP node would materialize through DATAPTR_RO). + The write emits exactly mori_layout_size bytes and zeroes header + reserved bytes. */ size_t mori_layout_size(SEXP x); void mori_layout_write(unsigned char *base, SEXP x); diff --git a/tests/testthat/test-corruption.R b/tests/testthat/test-corruption.R index b3567bf..632b834 100644 --- a/tests/testthat/test-corruption.R +++ b/tests/testthat/test-corruption.R @@ -311,3 +311,30 @@ test_that("root string access errors on an out-of-bounds offset table entry", { s <- map_shared(name) expect_error(s[1], "invalid string data") }) + +test_that("map_shared() errors on an unsupported vector sexptype", { + if (Sys.info()[["sysname"]] != "Linux") { + skip("requires file-backed /dev/shm (Linux only)") + } + + # A MORH header claiming a sexptype with no element size passes the header + # checks (the size checks skip such types) but the wrap constructor + # rejects it. + name <- write_corrupt(morh_header(99L, length = 1)) + expect_error(map_shared(name), "unsupported ALTREP type") +}) + +test_that("element access errors when string table alignment exceeds its data", { + if (Sys.info()[["sysname"]] != "Linux") { + skip("requires file-backed /dev/shm (Linux only)") + } + + # n = 1: the 16-byte offset table fits the entry's 16-byte data claim, but + # the table's 64-byte alignment padding does not. + name <- write_corrupt(c( + morl_header(n = 1L), + morl_entry(data_offset = 96, data_size = 16, sexptype = STRSXP, length = 1), + raw(16L) + )) + expect_error(map_shared(name)[[1]], "invalid string data") +}) diff --git a/tests/testthat/test-create.R b/tests/testthat/test-create.R index f178b91..3750bd0 100644 --- a/tests/testthat/test-create.R +++ b/tests/testthat/test-create.R @@ -6,8 +6,9 @@ # pre-create (Linux /dev/shm). test_that("share() errors when the name it would use is already taken", { - if (Sys.info()[["sysname"]] != "Linux") + if (Sys.info()[["sysname"]] != "Linux") { skip("requires file-backed /dev/shm (Linux only)") + } x <- share(1:10) nm <- shared_name(x) # "/mori__" @@ -40,8 +41,9 @@ test_that("share() errors when the name it would use is already taken", { # live create failure. The mapped category varies by platform (ENOMEM on macOS, # ENOSPC on Linux's size-capped tmpfs), so we assert only the size envelope. test_that("share() errors cleanly when the region is too large to back", { - if (.Machine$sizeof.pointer < 8) + if (.Machine$sizeof.pointer < 8) { skip("long vectors unsupported on 32-bit; PB-region path unreachable") + } expect_error( share(1:1e15), diff --git a/tests/testthat/test-prune.R b/tests/testthat/test-prune.R index 31c9620..24cb215 100644 --- a/tests/testthat/test-prune.R +++ b/tests/testthat/test-prune.R @@ -8,7 +8,9 @@ skip_on_os("windows") # any trailing slash stripped, plus "/mori"). mori_registry_dir <- function() { tmp <- Sys.getenv("TMPDIR") - if (!nzchar(tmp)) skip("TMPDIR unset; cannot locate mori registry directory") + if (!nzchar(tmp)) { + skip("TMPDIR unset; cannot locate mori registry directory") + } file.path(sub("/+$", "", tmp), "mori") } @@ -17,10 +19,11 @@ mori_registry_dir <- function() { # the process's registry log /mori/mori_, whose lines name that # process's regions. Pruning classifies purely by the PID in the name. orphan_record_path <- function(pid, shm_name) { - if (Sys.info()[["sysname"]] == "Linux") + if (Sys.info()[["sysname"]] == "Linux") { file.path("/dev/shm", sub("^/", "", shm_name)) - else + } else { file.path(mori_registry_dir(), sprintf("mori_%x", pid)) + } } # Fabricate such a record on disk, returning its path and the "/mori_..." name. @@ -28,10 +31,11 @@ fabricate_orphan_record <- function(pid, counter = "0") { shm_name <- sprintf("/mori_%x_%s", pid, counter) record <- orphan_record_path(pid, shm_name) if (Sys.info()[["sysname"]] == "Linux") { - file.create(record) # the region file itself - } else { # Darwin: a per-process log + file.create(record) # the region file itself + } else { + # Darwin: a per-process log dir.create(dirname(record), showWarnings = FALSE, mode = "0700") - writeLines(shm_name, record) # one region name per line + writeLines(shm_name, record) # one region name per line } list(record = record, shm_name = shm_name) } @@ -50,7 +54,7 @@ test_that("prune_shared() leaves live regions untouched", { }) test_that("prune_shared() returns NULL when nothing is orphaned", { - prune_shared() # clear any pre-existing orphans + prune_shared() # clear any pre-existing orphans expect_null(prune_shared()) # a second prune finds nothing to remove }) @@ -71,10 +75,11 @@ test_that("prune_shared() removes a dead process's orphan", { # a log naming a region that does not exist, so shm_unlink finds nothing to # reclaim and the name is not reported (reported only when a region was). expect_false(file.exists(orphan$record)) - if (Sys.info()[["sysname"]] == "Linux") + if (Sys.info()[["sysname"]] == "Linux") { expect_true(orphan$shm_name %in% pruned) - else + } else { expect_false(orphan$shm_name %in% pruned) + } }) test_that("prune_shared() keeps a live process's record", { @@ -104,7 +109,7 @@ test_that("a live region keeps the registry directory", { skip_on_os(c("linux", "solaris")) dir <- mori_registry_dir() - x <- share(rnorm(10)) # holds the process's log, and so the dir, open + x <- share(rnorm(10)) # holds the process's log, and so the dir, open expect_true(dir.exists(dir)) rm(x) @@ -121,14 +126,15 @@ test_that("the registry directory is pruned once the last region is finalised", # assert racily. gc() prune_shared() - if (length(list.files(dir, pattern = "^mori_")) != 0) + if (length(list.files(dir, pattern = "^mori_")) != 0) { skip("registry not empty; cannot isolate the prune assertion") + } - x <- share(rnorm(10)) # the sole live region; holds the log open + x <- share(rnorm(10)) # the sole live region; holds the log open expect_true(dir.exists(dir)) rm(x) - gc() # finalise it -> last region gone -> dir pruned + gc() # finalise it -> last region gone -> dir pruned expect_false(dir.exists(dir)) }) @@ -136,13 +142,13 @@ test_that("share() recreates the registry directory on demand", { skip_on_os(c("linux", "solaris")) dir <- mori_registry_dir() - x <- share(rnorm(10)) # present whether or not the dir was just pruned + x <- share(rnorm(10)) # present whether or not the dir was just pruned nm <- shared_name(x) expect_true(dir.exists(dir)) log <- file.path(dir, sprintf("mori_%x", Sys.getpid())) - expect_true(file.exists(log)) # this process's registry log - expect_true(nm %in% readLines(log)) # the region is recorded for pruning + expect_true(file.exists(log)) # this process's registry log + expect_true(nm %in% readLines(log)) # the region is recorded for pruning rm(x) gc() @@ -152,12 +158,90 @@ test_that("pruning an idle process does not create the registry directory", { skip_on_os(c("linux", "solaris")) dir <- mori_registry_dir() - gc() # finalise unreferenced shared objects (prunes their dir) - prune_shared() # prune dead-process orphans - if (dir.exists(dir)) + gc() # finalise unreferenced shared objects (prunes their dir) + prune_shared() # prune dead-process orphans + if (dir.exists(dir)) { skip("registry still present; cannot isolate") + } # Path resolution is pure: a prune that finds no registry must not create one. expect_null(prune_shared()) expect_false(dir.exists(dir)) }) + +test_that("prune_shared() reaps regions of a SIGKILLed process", { + # A process killed with SIGKILL runs no finalizers, leaving a genuine + # orphan: the region still exists when pruned, so unlinking it succeeds and + # its name is reported (a gracefully-exited process's record names regions + # already gone, which exercises only the skip path). The subprocess is + # detached — reparented to init — so the OS, not this session, reaps it. + rbin <- file.path(R.home("bin"), "R") + info <- tempfile() + script <- sprintf( + paste( + "x <- mori::share(1:10);", + "writeLines(c(Sys.getpid(), mori::shared_name(x)), %s);", + "Sys.sleep(120)" + ), + shQuote(info) + ) + system2( + "sh", + c( + "-c", + shQuote(paste( + shQuote(rbin), + "--vanilla", + "-q", + "-e", + shQuote(script), + ">/dev/null 2>&1 &" + )) + ), + env = paste0("R_LIBS=", paste(.libPaths(), collapse = .Platform$path.sep)) + ) + + deadline <- Sys.time() + 15 + while (!file.exists(info) && Sys.time() < deadline) { + Sys.sleep(0.05) + } + if (!file.exists(info)) { + skip("detached process did not create a region in time") + } + l <- readLines(info) + pid <- as.integer(l[1L]) + nm <- l[2L] + + tools::pskill(pid, tools::SIGKILL) + deadline <- Sys.time() + 5 + while (tools::pskill(pid, 0) && Sys.time() < deadline) { + Sys.sleep(0.05) + } + if (tools::pskill(pid, 0)) { + skip("killed process not reaped by the OS in time") + } + + pruned <- prune_shared() + expect_true(nm %in% pruned) + expect_error(map_shared(nm), "not found") +}) + +test_that("share() works with TMPDIR unset (confstr fallback)", { + skip_on_os(c("linux", "solaris")) + # With TMPDIR empty the macOS registry dir resolves via confstr's per-user + # temp dir; sharing must still work (and the region is released normally at + # exit, so nothing leaks into the registry). + rbin <- file.path(R.home("bin"), "R") + script <- "library(mori); x <- share(1:5); stopifnot(is_shared(x)); cat('OK\n')" + out <- system2( + rbin, + c("--vanilla", "-q", "-e", shQuote(script)), + stdout = TRUE, + stderr = TRUE, + env = c( + "TMPDIR=", + paste0("R_LIBS=", paste(.libPaths(), collapse = .Platform$path.sep)) + ) + ) + expect_true(any(grepl("OK", out, fixed = TRUE))) +}) diff --git a/tests/testthat/test-s4.R b/tests/testthat/test-s4.R new file mode 100644 index 0000000..163a89d --- /dev/null +++ b/tests/testthat/test-s4.R @@ -0,0 +1,101 @@ +test_that("S4 integer vector round-trips through share()", { + methods::setClass("moriS4Int", contains = "integer") + x <- methods::new("moriS4Int", 1:5) + y <- share(x) + expect_true(is_shared(y)) + expect_true(isS4(y)) + expect_identical(x, y) +}) + +test_that("S4 object with slots round-trips", { + methods::setClass("moriS4Slotted", contains = "numeric", + slots = c(note = "character")) + x <- methods::new("moriS4Slotted", c(1.5, 2.5), note = "hello") + y <- share(x) + expect_true(isS4(y)) + expect_identical(x, y) + expect_identical(methods::slot(y, "note"), "hello") +}) + +test_that("S4 character vector round-trips", { + methods::setClass("moriS4Chr", contains = "character") + x <- methods::new("moriS4Chr", c("a", "b")) + y <- share(x) + expect_true(is_shared(y)) + expect_true(isS4(y)) + expect_identical(x, y) +}) + +test_that("S4 list round-trips", { + methods::setClass("moriS4List", contains = "list") + x <- methods::new("moriS4List", list(a = 1:3, b = "x")) + y <- share(x) + expect_true(is_shared(y)) + expect_true(isS4(y)) + expect_identical(x, y) +}) + +test_that("S4 vector element of a shared list keeps the bit", { + methods::setClass("moriS4Elem", contains = "integer") + x <- methods::new("moriS4Elem", 1:3) + y <- share(list(a = x, b = 2:4)) + expect_true(isS4(y[[1]])) + expect_identical(x, y[[1]]) + expect_identical(2:4, y[[2]][]) +}) + +test_that("S4 element two levels deep keeps the bit", { + methods::setClass("moriS4Deep", contains = "integer") + x <- methods::new("moriS4Deep", 1:3) + y <- share(list(list(x))) + expect_true(isS4(y[[1]][[1]])) + expect_identical(x, y[[1]][[1]]) +}) + +test_that("map_shared on a path-form S4 element keeps the bit", { + methods::setClass("moriS4Path", contains = "integer") + x <- methods::new("moriS4Path", 1:3) + y <- share(list(x)) + z <- map_shared(shared_name(y[[1]])) + expect_true(isS4(z)) + expect_identical(x, z) +}) + +test_that("map_shared on S4 vector and list roots keeps the bit", { + methods::setClass("moriS4Root", contains = "integer") + methods::setClass("moriS4RootList", contains = "list") + x <- methods::new("moriS4Root", 1:3) + xl <- methods::new("moriS4RootList", list(1:3)) + y <- map_shared(shared_name(share(x))) + yl <- map_shared(shared_name(share(xl))) + expect_true(isS4(y)) + expect_true(isS4(yl)) + expect_identical(x, y) + expect_identical(xl, yl) +}) + +test_that("data-less S4 object passes through unchanged", { + methods::setClass("moriS4Bare", slots = c(x = "numeric")) + x <- methods::new("moriS4Bare", x = 42) + y <- share(x) + expect_false(is_shared(y)) + expect_true(isS4(y)) + expect_identical(x, y) +}) + +test_that("serialize round-trip of a shared S4 vector keeps the bit", { + methods::setClass("moriS4Ser", contains = "integer") + x <- methods::new("moriS4Ser", 1:5) + z <- unserialize(serialize(share(x), NULL)) + expect_true(isS4(z)) + expect_identical(x, z) +}) + +test_that("mutating a shared S4 vector keeps the bit after COW", { + methods::setClass("moriS4Cow", contains = "integer") + x <- methods::new("moriS4Cow", 1:5) + y <- share(x) + y[1] <- 99L + expect_true(isS4(y)) + expect_identical(as.integer(y), c(99L, 2:5)) +}) diff --git a/tests/testthat/test-serialization.R b/tests/testthat/test-serialization.R index ae7f92c..44b9f25 100644 --- a/tests/testthat/test-serialization.R +++ b/tests/testthat/test-serialization.R @@ -246,3 +246,33 @@ test_that("sub-list beyond MORI_MAX_PATH falls back to materialization", { } expect_identical(final$leaf[], 1:3) }) + +# Corrupt-stream guards: for the vector and list classes a STRSXP state is +# always an SHM identifier, and for the string class a bare STRSXP state is — +# one that no longer parses as an identifier means a corrupt stream, and +# unserialize must error rather than fall through. The identifier is rewritten +# in place (same length, so the stream stays structurally valid). + +test_that("unserialize errors on a tampered vector identifier", { + x <- share(1:10) + blob <- serialize(x, NULL) + pos <- grepRaw(shared_name(x), blob, fixed = TRUE, all = TRUE) + expect_length(pos, 1L) + blob[pos[[1]] + 6L] <- charToRaw("z") # first hex digit -> non-hex + expect_error( + unserialize(blob), + "invalid serialized state for a shared object" + ) +}) + +test_that("unserialize errors on a tampered string identifier", { + x <- share(c("alpha", "beta")) + blob <- serialize(x, NULL) + pos <- grepRaw(shared_name(x), blob, fixed = TRUE, all = TRUE) + expect_length(pos, 1L) + blob[pos[[1]] + 6L] <- charToRaw("z") + expect_error( + unserialize(blob), + "invalid serialized state for a shared string vector" + ) +}) diff --git a/tests/testthat/test-strings.R b/tests/testthat/test-strings.R index 1cbd03a..b282ad1 100644 --- a/tests/testthat/test-strings.R +++ b/tests/testthat/test-strings.R @@ -111,3 +111,24 @@ test_that("order() materializes string ALTREP and re-reads the private copy", { expect_identical(y[[1]], "delta") expect_identical(y[], v) }) + +test_that("print() exercises Dataptr_or_null on string ALTREP", { + # print() asks the ALTSTRING class for a full data pointer; mori declines + # (returns NULL) and R falls back to per-element access. + x <- share(c("hello", "world")) + y <- map_shared(shared_name(x)) + expect_output(print(y), '"hello"') + expect_true(is_shared(y)) +}) + +test_that("string Dataptr re-reads the materialized copy once COW'd", { + # order() (radix sort) takes the vector's DATAPTR, materializing to a + # private copy; a second order() and print() re-read that copy through the + # data2 branches of Dataptr and Dataptr_or_null. + v <- c("delta", "alpha", "gamma", "beta") + y <- map_shared(shared_name(share(v))) + expect_identical(order(y), order(v)) + expect_identical(order(y), order(v)) + expect_output(print(y), '"delta"') + expect_identical(y[], v) +})