inst/tinytest/test_fork_serialize.R

In Rtinycc: Builds the 'TinyCC' Command-Line Interface and Library for 'C' Scripting in 'R'

library(tinytest)
library(Rtinycc)

# ── Fork safety ──────────────────────────────────────────────────────────────
# TCC-compiled function pointers live in mmap'd memory owned by the parent
# process's TCC state.  After fork(), the child gets a copy-on-write mapping.
# Reads (calls) should work; the memory is still mapped.  But the TCC state
# external pointer itself might become invalid after serialization or if the
# parent frees it.

if (
  .Platform$OS.type != "windows" && requireNamespace("parallel", quietly = TRUE)
) {
  # --- Test 1: simple call across fork ----------------------------------
  ffi <- tcc_ffi() |>
    tcc_source("int add(int a, int b) { return a + b; }") |>
    tcc_bind(add = list(args = list("i32", "i32"), returns = "i32")) |>
    tcc_compile()

  # Verify it works in the parent
  expect_equal(ffi$add(2L, 3L), 5L, info = "Parent: add works before fork")

  # mclapply forks; each child should be able to call the compiled function
  results <- parallel::mclapply(
    1:4,
    function(i) {
      tryCatch(ffi$add(i, 10L), error = function(e) e)
    },
    mc.cores = 2
  )

  fork_ok <- vapply(results, is.integer, logical(1))
  expect_true(
    all(fork_ok),
    info = "Fork: compiled FFI callable works in forked children"
  )
  if (all(fork_ok)) {
    expect_equal(
      unlist(results),
      c(11L, 12L, 13L, 14L),
      info = "Fork: correct results from forked children"
    )
  }

  # --- Test 2: struct accessors across fork -----------------------------
  ffi2 <- tcc_ffi() |>
    tcc_source("struct pt { double x; double y; };") |>
    tcc_struct("pt", accessors = c(x = "f64", y = "f64")) |>
    tcc_compile()

  results2 <- parallel::mclapply(
    1:2,
    function(i) {
      tryCatch(
        {
          p <- ffi2$struct_pt_new()
          ffi2$struct_pt_set_x(p, as.double(i))
          val <- ffi2$struct_pt_get_x(p)
          ffi2$struct_pt_free(p)
          val
        },
        error = function(e) e
      )
    },
    mc.cores = 2
  )

  fork_struct_ok <- vapply(results2, is.double, logical(1))
  expect_true(
    all(fork_struct_ok),
    info = "Fork: struct accessors work in forked children"
  )

  # --- Test 2b: union accessors across fork ------------------------------
  ffi_union <- tcc_ffi() |>
    tcc_source("union duo { int i; float f; };") |>
    tcc_union(
      "duo",
      members = list(i = "i32", f = "f32"),
      active = "i"
    ) |>
    tcc_compile()

  results2b <- parallel::mclapply(
    1:2,
    function(i) {
      tryCatch(
        {
          u <- ffi_union$union_duo_new()
          ffi_union$union_duo_set_i(u, i * 10L)
          val <- ffi_union$union_duo_get_i(u)
          ffi_union$union_duo_free(u)
          val
        },
        error = function(e) e
      )
    },
    mc.cores = 2
  )

  fork_union_ok <- vapply(results2b, is.integer, logical(1))
  expect_true(
    all(fork_union_ok),
    info = "Fork: union accessors work in forked children"
  )
  if (all(fork_union_ok)) {
    expect_equal(
      unlist(results2b),
      c(10L, 20L),
      info = "Fork: union results correct"
    )
  }

  # --- Test 3: callback across fork (may be unsafe) ---------------------
  # Callbacks hold R function pointers which should survive fork
  # since R environments are duplicated by COW
  cb <- tcc_callback(function(x) x + 1, signature = "double (*)(double)")

  ffi3 <- tcc_ffi() |>
    tcc_source(
      "
      double apply_cb(double (*fn)(void* ctx, double), void* ctx, double x) {
        return fn(ctx, x);
      }
    "
    ) |>
    tcc_bind(
      apply_cb = list(
        args = list("callback:double(double)", "ptr", "f64"),
        returns = "f64"
      )
    ) |>
    tcc_compile()

  results3 <- parallel::mclapply(
    1:2,
    function(i) {
      tryCatch(
        ffi3$apply_cb(cb, tcc_callback_ptr(cb), as.double(i)),
        error = function(e) e
      )
    },
    mc.cores = 2
  )

  fork_cb_ok <- vapply(results3, is.double, logical(1))
  expect_true(
    all(fork_cb_ok),
    info = "Fork: callbacks work in forked children"
  )
  if (all(fork_cb_ok)) {
    expect_equal(
      unlist(results3),
      c(2.0, 3.0),
      info = "Fork: callback results correct"
    )
  }
  tcc_callback_close(cb)

  # --- Test 4: parent still works after children exit -------------------
  expect_equal(
    ffi$add(100L, 1L),
    101L,
    info = "Parent: compiled FFI still works after fork children exit"
  )
}


# ── Serialization: auto-recompile ─────────────────────────────────────────────
# tcc_compiled objects contain external pointers (TCC state, function pointers).
# These become nil after serialize/unserialize. The $.tcc_compiled method
# detects this and recompiles transparently from the stored FFI recipe.

ffi_ser <- tcc_ffi() |>
  tcc_source("int square(int x) { return x * x; }") |>
  tcc_bind(square = list(args = list("i32"), returns = "i32")) |>
  tcc_compile()

expect_equal(ffi_ser$square(7L), 49L, info = "Pre-serialization: square works")

# --- Test 5: serialize + unserialize auto-recompiles --------------------
raw_bytes <- serialize(ffi_ser, NULL)
ffi_restored <- unserialize(raw_bytes)

expect_true(
  inherits(ffi_restored, "tcc_compiled"),
  info = "Serialized object retains class"
)

# First access triggers recompilation; result should be correct
expect_equal(
  ffi_restored$square(7L),
  49L,
  info = "Deserialized FFI auto-recompiles and works"
)

# --- Test 6: saveRDS + readRDS auto-recompiles --------------------------
tmp <- tempfile(fileext = ".rds")
saveRDS(ffi_ser, tmp)
ffi_rds <- readRDS(tmp)
unlink(tmp)

expect_equal(
  ffi_rds$square(9L),
  81L,
  info = "readRDS FFI auto-recompiles and works"
)

# --- Test 7: original still works after serialization -------------------
expect_equal(
  ffi_ser$square(7L),
  49L,
  info = "Original FFI still works after serialization"
)

# --- Test 8: explicit tcc_recompile ------------------------------------
ffi_recomp <- unserialize(serialize(ffi_ser, NULL))
tcc_recompile(ffi_recomp)
expect_equal(
  ffi_recomp$square(11L),
  121L,
  info = "Explicit tcc_recompile works"
)

# --- Test 9: tcc_link round-trip ----------------------------------------
find_system_math_library <- function() {
  if (.Platform$OS.type == "windows") {
    return(NULL)
  }

  sysname <- as.character(unname(Sys.info()[["sysname"]]))
  paths <- unique(Rtinycc:::tcc_library_search_paths(sysname))
  # Prefer libm.so (GNU ld script on glibc) over the bare SONAME so TinyCC
  # can resolve through the script. Some minimal containers ship only the
  # versioned file, so keep that as a fallback.
  patterns <- switch(
    sysname,
    Linux = c("^libm\\.so$", "^libm\\.so(\\.[0-9]+)+$"),
    Darwin = c("^libSystem\\.B\\.dylib$", "^libm\\.dylib$"),
    character(0)
  )

  for (pattern in patterns) {
    for (path in paths) {
      if (!dir.exists(path)) {
        next
      }
      candidates <- list.files(
        path,
        pattern = pattern,
        full.names = TRUE
      )
      if (length(candidates) > 0L) {
        return(candidates[[1]])
      }
    }
  }

  NULL
}

math_lib_path <- find_system_math_library()
math <- if (!is.null(math_lib_path)) {
  tryCatch(
    tcc_link(
      math_lib_path,
      symbols = list(
        sqrt = list(args = list("f64"), returns = "f64")
      )
    ),
    error = function(e) NULL
  )
} else {
  NULL
}
if (!is.null(math)) {
  expect_equal(math$sqrt(25.0), 5.0, info = "tcc_link: original works")

  math2 <- unserialize(serialize(math, NULL))
  expect_equal(
    math2$sqrt(144.0),
    12.0,
    info = "tcc_link: auto-recompiles after deserialization"
  )

  if (identical(as.character(unname(Sys.info()[["sysname"]])), "Linux")) {
    tmp_lib_dir <- tempfile("rtinycc-libm-")
    dir.create(tmp_lib_dir)
    on.exit(unlink(tmp_lib_dir, recursive = TRUE), add = TRUE)

    # Regression guard: a full path to a versioned runtime shared object
    # must be linked as that exact file, not collapsed to -lm. We use the
    # actual SONAME file (resolving the ld script if necessary) so the
    # symlink/copy points at a real ELF object.
    src <- math_lib_path
    if (!isTRUE(file.info(src)$isdir)) {
      head_bytes <- tryCatch(
        readChar(src, 32, useBytes = TRUE),
        error = function(e) ""
      )
      if (!startsWith(as.character(head_bytes), "\x7fELF")) {
        soname <- file.path(dirname(src), "libm.so.6")
        if (file.exists(soname)) src <- soname
      }
    }

    isolated_math_path <- file.path(tmp_lib_dir, "libm_rtinycc_test.so.6")
    linked <- file.symlink(src, isolated_math_path)
    if (!isTRUE(linked)) {
      linked <- file.copy(src, isolated_math_path)
    }

    if (isTRUE(linked)) {
      math_exact <- tryCatch(
        tcc_link(
          isolated_math_path,
          symbols = list(
            sqrt = list(args = list("f64"), returns = "f64")
          )
        ),
        error = function(e) NULL
      )
      if (!is.null(math_exact)) {
        expect_equal(
          math_exact$sqrt(36.0),
          6.0,
          info = "tcc_link: versioned Linux shared object path links exactly"
        )
      }
    }
  }
}

# --- Test 10: raw pointers are still dead after deserialization ----------
ptr <- tcc_malloc(8)
raw_ptr <- serialize(ptr, NULL)
ptr_restored <- unserialize(raw_ptr)

res10 <- tryCatch(tcc_ptr_is_null(ptr_restored), error = function(e) e)
expect_true(
  inherits(res10, "error") || isTRUE(res10),
  info = "Deserialized pointer errors on use or reads as NULL"
)
tcc_free(ptr)

# --- Test 11: tcc_state external pointer still dead ---------------------
state <- tcc_state(output = "memory")
tcc_compile_string(state, "int one(void) { return 1; }")
tcc_relocate(state)
raw_state <- serialize(state, NULL)
state2 <- unserialize(raw_state)

res11 <- tryCatch(
  tcc_call_symbol(state2, "one", return = "int"),
  error = function(e) e
)
expect_true(
  inherits(res11, "error"),
  info = "Deserialized TCC state errors on use (no auto-recompile for raw state)"
)

# --- Test 12: callback tokens do not survive deserialization --------------
cb <- tcc_callback(function(x) x + 1L, signature = "int (*)(int)")
cb2 <- unserialize(serialize(cb, NULL))
expect_false(
  tcc_callback_valid(cb2),
  info = "Deserialized callback token is invalid in the new object"
)
expect_error(
  tcc_callback_ptr(cb2),
  info = "Deserialized callback cannot yield a fresh callback ptr"
)
tcc_callback_close(cb)

# --- Test 13: callback ptr wrappers do not survive deserialization --------
cb <- tcc_callback(function(x) x + 1L, signature = "int (*)(int)")
cb_ptr <- tcc_callback_ptr(cb)
cb_ptr2 <- unserialize(serialize(cb_ptr, NULL))
res13 <- tryCatch(tcc_ptr_is_null(cb_ptr2), error = function(e) e)
expect_true(
  inherits(res13, "error") || isTRUE(res13),
  info = "Deserialized callback ptr errors on use or reads as NULL"
)
tcc_callback_close(cb)