Nothing
# Rtinycc - TinyCC for R
# Copyright (C) 2025-2026 Sounkou Mahamane Toure
# SPDX-License-Identifier: GPL-3.0-or-later
# Callback Registration and Invocation
# Allow R functions to be passed as callbacks to compiled C code
#' Register an R function as a callback
#'
#' Wraps an R function so it can be passed as a C function pointer
#' to compiled code. The callback will be invoked via a trampoline
#' that marshals arguments between C and R.
#'
#' @details
#' Thread safety: callbacks are executed on the R main thread only. Invoking
#' a callback from a worker thread is unsupported and may crash R. The
#' \code{threadsafe} flag is currently informational only.
#'
#' If a callback raises an error, a warning is emitted and a type-appropriate
#' default value is returned.
#'
#' When binding callbacks with `tcc_bind()`, use a `callback:<signature>`
#' argument type so a synchronous trampoline is generated. The trampoline
#' expects a `void*` user-data pointer as its first argument; pass
#' `tcc_callback_ptr(cb)` as the user-data argument to the C API. For
#' thread-safe usage from worker threads, use `callback_async:<signature>`
#' which schedules the call on the main thread and returns a default value.
#'
#' Pointer arguments (e.g., \code{double*}, \code{int*}) are passed as
#' external pointers. Lengths must be supplied separately if needed.
#'
#' The return type may be any scalar type supported by the FFI mappings
#' (e.g., \code{i32}, \code{f64}, \code{bool}, \code{cstring}), or
#' \code{SEXP} to return an R object directly.
#'
#' Callback lifetime: callbacks are eventually released by finalizers and
#' package unload. Call `tcc_callback_close()` when you want deterministic
#' invalidation and earlier release of the preserved R function.
#'
#' @param fun An R function to be called from C
#' @param signature C function signature string (e.g., "double (*)(int, double)")
#' @param threadsafe Whether to enable thread-safe invocation (experimental)
#' @return A tcc_callback object (externalptr wrapper)
#' @export
tcc_callback <- function(fun, signature, threadsafe = FALSE) {
if (!is.function(fun)) {
stop("fun must be a function", call. = FALSE)
}
if (!is.character(signature) || length(signature) != 1) {
stop("signature must be a single string", call. = FALSE)
}
# Parse signature to get return type and argument types
sig <- parse_callback_signature(signature)
# Register with C runtime
callback_ext <- .Call(
RC_register_callback,
fun,
sig$return_type,
sig$arg_types,
as.integer(threadsafe)
)
# Add metadata as attributes
attr(callback_ext, "signature") <- sig
attr(callback_ext, "threadsafe") <- threadsafe
attr(callback_ext, "fun") <- fun
class(callback_ext) <- c("tcc_callback", "externalptr")
callback_ext
}
#' Close/unregister a callback
#'
#' Invalidates a callback immediately, releases the preserved R function
#' reference, and cleans up callback resources as early as possible.
#' This is recommended for deterministic lifetime management, but callbacks
#' are also eventually released by finalizers if you simply drop all references.
#'
#' @param callback A tcc_callback object returned by tcc_callback()
#' @return NULL (invisible)
#' @export
tcc_callback_close <- function(callback) {
if (!inherits(callback, "tcc_callback")) {
stop("Expected tcc_callback object", call. = FALSE)
}
.Call(RC_unregister_callback, callback)
invisible(NULL)
}
#' Get the C-compatible function pointer
#'
#' Returns an external pointer that can be passed to compiled C code
#' as user data for trampolines. Keep this handle (and the original
#' `tcc_callback`) alive for as long as C may call back.
#' The pointer handle keeps the underlying token storage alive until it is
#' garbage collected. Closing the original callback still invalidates the
#' callback registry entry, so C must not continue invoking it after
#' `tcc_callback_close()`.
#'
#' Pointer arguments and return values are treated as external pointers.
#' Use \code{tcc_read_bytes()}, \code{tcc_read_u8()}, or \code{tcc_read_f64()}
#' to inspect pointed data when needed.
#'
#' @param callback A tcc_callback object
#' @return An external pointer (address of the callback token)
#' @export
tcc_callback_ptr <- function(callback) {
if (!inherits(callback, "tcc_callback")) {
stop("Expected tcc_callback object", call. = FALSE)
}
# Get the token address as external pointer
.Call(RC_get_callback_ptr, callback)
}
#' Print tcc_callback object
#'
#' @param x A tcc_callback object
#' @param ... Ignored
#' @return The input `tcc_callback` object, invisibly. Called for its
#' side effect of printing the callback signature, thread-safety flag,
#' and validity status.
#' @export
print.tcc_callback <- function(x, ...) {
sig <- attr(x, "signature")
threadsafe <- attr(x, "threadsafe")
cat("<tcc_callback>\n")
cat(" Signature: ", format_signature(sig), "\n", sep = "")
cat(" Thread-safe: ", if (threadsafe) "yes" else "no", "\n", sep = "")
cat(
" Status: ",
if (is_callback_valid(x)) "valid" else "invalid",
"\n",
sep = ""
)
invisible(x)
}
#' Check if callback is still valid
#'
#' @param callback A tcc_callback object
#' @return Logical indicating if callback can be invoked
#' @export
tcc_callback_valid <- function(callback) {
if (!inherits(callback, "tcc_callback")) {
return(FALSE)
}
is_callback_valid(callback)
}
# Internal function to check validity
is_callback_valid <- function(callback) {
tryCatch(
{
.Call(RC_callback_is_valid, callback)
},
error = function(e) FALSE
)
}
new_rtinycc_callback_signature <- function(
return_type,
arg_types,
raw,
mode = "sync"
) {
structure(
list(
return_type = return_type,
arg_types = arg_types,
raw = raw,
mode = mode
),
class = c(
paste0("rtinycc_callback_signature_", mode),
"rtinycc_callback_signature"
)
)
}
is_rtinycc_callback_signature <- function(x) {
inherits(x, "rtinycc_callback_signature")
}
# Parse a C function signature string
# Returns classed signature object with return_type and arg_types.
parse_callback_signature <- function(signature, mode = "sync") {
# Remove whitespace
sig <- gsub("\\s+", " ", trimws(signature))
# Pattern: return_type (*)(arg1, arg2, ...)
# or: return_type (*name)(arg1, arg2, ...)
# or: return_type(arg1, arg2, ...)
patterns <- c(
"^(.*?)\\s*\\(\\*[^)]*\\)\\s*\\((.*)\\)$",
"^(.*?)\\((.*)\\)$"
)
for (pat in patterns) {
m <- regexec(pat, sig, perl = TRUE)
if (m[[1]][1] != -1) {
matches <- regmatches(sig, m)[[1]]
return_type <- trimws(matches[2])
args_str <- trimws(matches[3])
# Parse argument types
if (args_str == "" || args_str == "void") {
arg_types <- character(0)
} else {
# Split by comma, handling function pointers and nested parens
arg_types <- parse_arg_list(args_str)
}
return(new_rtinycc_callback_signature(
return_type = return_type,
arg_types = arg_types,
raw = signature,
mode = mode
))
}
}
# If no pattern matched, try simple fallback
stop("Unable to parse callback signature: ", signature, call. = FALSE)
}
# Parse a comma-separated argument list, handling nested structures
parse_arg_list <- function(args_str) {
if (args_str == "" || args_str == "void") {
return(character(0))
}
args <- character(0)
depth_paren <- 0L
depth_bracket <- 0L
start <- 1L
n <- nchar(args_str, type = "chars")
for (i in seq_len(n)) {
ch <- substr(args_str, i, i)
if (ch == "," && depth_paren == 0L && depth_bracket == 0L) {
args <- c(args, trimws(substr(args_str, start, i - 1L)))
start <- i + 1L
next
}
if (ch == "(") {
depth_paren <- depth_paren + 1L
} else if (ch == ")") {
depth_paren <- max(0L, depth_paren - 1L)
} else if (ch == "[") {
depth_bracket <- depth_bracket + 1L
} else if (ch == "]") {
depth_bracket <- max(0L, depth_bracket - 1L)
}
}
args <- c(args, trimws(substr(args_str, start, n)))
args <- args[nzchar(args)]
# Remove parameter names (keep only type)
# e.g., "int x" -> "int", "double* ptr" -> "double*"
result <- character(length(args))
for (i in seq_along(args)) {
arg <- args[i]
# Handle function pointer types: void (*)(int)
# Keep them as-is, they'll be treated as "callback" type
if (grepl("\\(", arg)) {
result[i] <- "callback"
} else {
result[i] <- strip_callback_arg_name(arg)
}
}
result
}
strip_callback_arg_name <- function(arg) {
arg <- trimws(gsub("\\s+", " ", arg))
if (!nzchar(arg)) {
return(arg)
}
# Pointer declarators often attach the parameter name directly to the last
# asterisk, for example `const char *name` or `int **out`.
ptr_match <- regexec(
"^(.*?)(\\*+)\\s*([A-Za-z_][A-Za-z0-9_]*)$",
arg,
perl = TRUE
)[[1]]
if (ptr_match[[1]] != -1) {
pieces <- regmatches(arg, list(ptr_match))[[1]]
return(trimws(paste0(pieces[[2]], pieces[[3]])))
}
parts <- strsplit(arg, "\\s+")[[1]]
if (
length(parts) > 1 &&
grepl("^[A-Za-z_][A-Za-z0-9_]*$", parts[[length(parts)]])
) {
parts <- parts[-length(parts)]
}
trimws(paste(parts, collapse = " "))
}
# Format signature for display
format_signature <- function(sig) {
if (is.null(sig)) {
return("unknown")
}
args <- if (length(sig$arg_types) == 0) {
"void"
} else {
paste(sig$arg_types, collapse = ", ")
}
paste0(sig$return_type, " (*)(", args, ")")
}
# ============================================================================
# FFI Integration - Allow callbacks in tcc_bind()
# ============================================================================
#' Check if a type represents a callback
#'
#' @param type Type string to check
#' @return Logical
is_callback_type <- function(type) {
if (is_rtinycc_ffi_type(type)) {
return(ffi_type_family(type) %in% c("callback", "callback_async"))
}
if (!is.character(type)) {
return(FALSE)
}
type == "callback" ||
startsWith(type, "callback:") ||
startsWith(type, "callback_async:")
}
is_callback_async_type <- function(type) {
if (is_rtinycc_ffi_type(type)) {
return(identical(ffi_type_family(type), "callback_async"))
}
if (!is.character(type)) {
return(FALSE)
}
startsWith(type, "callback_async:")
}
#' Parse callback type specification
#'
#' @param type Type string like "callback:double(int,int)"
#' @return Parsed signature list or NULL
parse_callback_type <- function(type) {
if (is_rtinycc_ffi_type(type)) {
type <- type$name
}
if (type == "callback") {
# Generic callback without signature - will need runtime determination
return(NULL)
}
if (startsWith(type, "callback:")) {
# Extract signature after "callback:"
sig_str <- sub("^callback:", "", type)
return(parse_callback_signature(sig_str, mode = "sync"))
}
if (startsWith(type, "callback_async:")) {
sig_str <- sub("^callback_async:", "", type)
return(parse_callback_signature(sig_str, mode = "async"))
}
NULL
}
#' Schedule a callback to run on the main thread
#'
#' Enqueue a callback for main-thread execution. Arguments must be basic
#' scalars or external pointers.
#'
#' @param callback A tcc_callback object
#' @param args List of arguments to pass to the callback
#' @return NULL (invisible)
#' @export
tcc_callback_async_schedule <- function(callback, args = list()) {
if (!inherits(callback, "tcc_callback")) {
stop("Expected tcc_callback object", call. = FALSE)
}
if (!is.list(args)) {
stop("args must be a list", call. = FALSE)
}
.Call(RC_callback_async_schedule, callback, args)
invisible(NULL)
}
#' Drain the async callback queue
#'
#' Execute any pending async callbacks immediately on the main R thread.
#' Normally callbacks fire automatically via R's event loop (input
#' handler on POSIX, message pump on Windows), so explicit draining is
#' only needed in test harnesses or tight batch loops that never yield
#' to R's event loop.
#'
#' TCC-compiled C code running on the main thread can call
#' \code{RC_callback_async_drain_c()} directly instead of returning to R.
#'
#' @return NULL (invisible)
#' @export
tcc_callback_async_drain <- function() {
.Call(RC_callback_async_drain)
invisible(NULL)
}
#' Generate trampoline code for a callback argument
#'
#' @param trampoline_name Name of the trampoline function
#' @param sig Parsed signature
#' @return C code string for the trampoline
generate_trampoline <- function(trampoline_name, sig) {
# Generate a trampoline function that:
# 1. Takes a user data pointer + C arguments
# 2. Calls RC_invoke_callback_id() to invoke the R function
# 3. Returns the result
n_args <- length(sig$arg_types)
# Build argument list for C function signature
c_args <- c("void* cb")
if (n_args > 0) {
for (i in seq_len(n_args)) {
c_args <- c(
c_args,
sprintf("%s arg%d", callback_c_decl_type(sig$arg_types[i]), i)
)
}
}
# Build the trampoline
lines <- c(
sprintf("// Trampoline %s", trampoline_name),
sprintf(
"%s %s(%s) {",
callback_c_decl_type(sig$return_type),
trampoline_name,
if (length(c_args) > 0) paste(c_args, collapse = ", ") else "void"
),
" callback_token_t* tok = (callback_token_t*)cb;",
" if (!tok || tok->id < 0) {",
sprintf(
" Rf_warning(\"Invalid callback token in %s\");",
trampoline_name
),
get_c_default_return(sig$return_type, indent = 4L),
" }"
)
# Build argument conversion
if (n_args > 0) {
lines <- c(
lines,
sprintf(" SEXP args = PROTECT(allocVector(VECSXP, %d));", n_args)
)
for (i in seq_len(n_args)) {
lines <- c(
lines,
sprintf(
" SET_VECTOR_ELT(args, %d, %s);",
i - 1,
get_sexp_constructor_call(sig$arg_types[i], paste0("arg", i))
)
)
}
} else {
lines <- c(lines, " SEXP args = R_NilValue;")
}
# Call the runtime
lines <- c(lines, " SEXP result = RC_invoke_callback_id(tok->id, args);")
if (n_args > 0) {
lines <- c(lines, " UNPROTECT(1);")
}
# Convert result back to C type
lines <- c(
lines,
get_r_to_c_return_lines(sig$return_type, "result", indent = 2L)
)
lines <- c(lines, "}")
paste(lines, collapse = "\n")
}
# Generate async trampoline that schedules callbacks on the main thread.
#
# void return -> fire-and-forget via RC_callback_async_schedule_c
# (PostMessage on Windows, write-to-pipe on Linux).
# Auto-drains through R's input handler / message pump.
# non-void return -> synchronous via RC_callback_async_schedule_sync_c
# (SendMessage on Windows, pthread_cond on Linux).
# Blocks the worker thread until the main thread
# services the callback. C code on the main thread
# can call RC_callback_async_drain_c() in a loop
# rather than returning to R.
generate_async_trampoline <- function(trampoline_name, sig) {
unsupported <- vapply(sig$arg_types, async_type_unsupported, logical(1))
if (any(unsupported)) {
bad <- unique(trimws(sig$arg_types[unsupported]))
stop(
"callback_async unsupported argument type(s): ",
paste(bad, collapse = ", "),
call. = FALSE
)
}
is_void_return <- identical(sig$return_type, "void")
if (!is_void_return) {
ret_kind <- async_result_kind(sig$return_type)
if (is.null(ret_kind)) {
stop(
"callback_async unsupported return type: ",
sig$return_type,
" (supported: void, int variants, double/float, bool/logical, ptr)",
call. = FALSE
)
}
}
n_args <- length(sig$arg_types)
c_args <- c("void* cb")
if (n_args > 0) {
for (i in seq_len(n_args)) {
c_args <- c(
c_args,
sprintf("%s arg%d", callback_c_decl_type(sig$arg_types[i]), i)
)
}
}
lines <- c(
sprintf("// Async trampoline %s", trampoline_name),
sprintf(
"%s %s(%s) {",
callback_c_decl_type(sig$return_type),
trampoline_name,
if (length(c_args) > 0) paste(c_args, collapse = ", ") else "void"
),
" callback_token_t* tok = (callback_token_t*)cb;",
" if (!tok || tok->id < 0) {",
sprintf(
" Rf_warning(\"Invalid callback token in %s\");",
trampoline_name
),
get_c_default_return(sig$return_type, indent = 4L),
" }"
)
if (n_args > 0) {
lines <- c(lines, sprintf(" cb_arg_t args[%d];", n_args))
for (i in seq_len(n_args)) {
lines <- c(lines, generate_cb_arg_assignment(i, sig$arg_types[i]))
}
} else {
lines <- c(lines, " cb_arg_t* args = NULL;")
}
if (is_void_return) {
lines <- c(
lines,
sprintf(
" int rc = RC_callback_async_schedule_c(tok->id, %d, %s);",
n_args,
if (n_args > 0) "args" else "NULL"
),
" if (rc != 0) {",
sprintf(
" Rf_warning(\"Async schedule failed (rc=%%d) in %s\", rc);",
trampoline_name
),
" }",
" return;"
)
} else {
lines <- c(
lines,
" cb_result_t result;",
sprintf(
" int rc = RC_callback_async_schedule_sync_c(tok->id, %d, %s, &result);",
n_args,
if (n_args > 0) "args" else "NULL"
),
" if (rc != 0) {",
sprintf(
" Rf_warning(\"Async schedule failed (rc=%%d) in %s\", rc);",
trampoline_name
),
get_c_default_return(sig$return_type, indent = 4L),
" }",
get_async_result_return(sig$return_type)
)
}
lines <- c(lines, "}")
paste(lines, collapse = "\n")
}
# Determine the CB_RESULT_* kind that a C return type maps to.
# Returns NULL if the type cannot be returned from an async sync callback.
async_result_kind <- function(return_type) {
rt <- trimws(return_type)
if (
rt %in%
c(
"int",
"i32",
"int32_t",
"i16",
"int16_t",
"i8",
"int8_t",
"u8",
"uint8_t",
"u16",
"uint16_t"
)
) {
return("int")
}
if (
rt %in%
c(
"double",
"f64",
"float",
"f32",
"i64",
"int64_t",
"u32",
"uint32_t",
"u64",
"uint64_t"
)
) {
return("real")
}
if (rt %in% c("bool", "logical")) {
return("logical")
}
if (is_ptr_type(rt)) {
return("ptr")
}
NULL
}
# Generate the C return statement that extracts a value from cb_result_t.
get_async_result_return <- function(return_type) {
kind <- async_result_kind(return_type)
rt <- callback_c_decl_type(return_type)
switch(
kind,
"int" = sprintf(" return (%s)result.v.i;", rt),
"real" = sprintf(" return (%s)result.v.d;", rt),
"logical" = sprintf(" return (%s)result.v.i;", rt),
"ptr" = sprintf(" return (%s)result.v.p;", rt),
stop(
"BUG: unhandled async result kind for return type: ",
return_type,
call. = FALSE
)
)
}
async_type_unsupported <- function(c_type) {
key <- normalize_cb_kind_key(c_type)
if (key %in% c("ptr", "cstring", "real", "logical")) {
return(FALSE)
}
if (!identical(key, "int")) {
return(TRUE)
}
type_name <- trimws(c_type)
!type_name %in%
c(
"int",
"int32_t",
"i32",
"int16_t",
"i16",
"int8_t",
"i8",
"uint8_t",
"u8",
"uint16_t",
"u16"
)
}
generate_cb_arg_assignment <- function(index, c_type) {
kind <- map_c_to_cb_arg_kind(c_type)
value <- map_c_to_cb_arg_value(c_type, paste0("arg", index))
c(
sprintf(" args[%d].kind = %s;", index - 1, kind),
sprintf(" args[%d].v.%s = %s;", index - 1, value$field, value$expr)
)
}
is_ptr_type <- function(c_type) {
c_type <- trimws(c_type)
grepl("\\*", c_type) && !is_cstring_type(c_type)
}
is_cstring_type <- function(c_type) {
c_type <- trimws(c_type)
grepl("^const\\s+char\\s*\\*$", c_type) || grepl("^char\\s*\\*$", c_type)
}
normalize_cb_kind_key <- function(c_type) {
cb_kind_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}
normalize_sexp_type_key <- function(c_type) {
sexp_type_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}
normalize_r_type_key <- function(c_type) {
c_r_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}
normalize_sexp_ctor_key <- function(c_type) {
sexp_ctor_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}
normalize_r_to_c_key <- function(c_type) {
r_to_c_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}
normalize_default_key <- function(c_type) {
default_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}
normalize_return_key <- function(c_type) {
return_key_rule(trimws(c_type), is_ptr_type(trimws(c_type)))
}
# Normalize callback signature spellings into concrete C declaration types.
# This keeps trampoline ABI faithful to the declared callback type while still
# accepting internal alias forms like i8/f32/sexp in callback signatures.
callback_c_decl_type <- function(c_type) {
type_name <- trimws(gsub("\\s+", " ", c_type))
if (!nzchar(type_name)) {
return(type_name)
}
alias_map <- c(
callback = "void*",
ptr = "void*",
cstring = "const char*",
string = "const char*",
sexp = "SEXP",
logical = "bool",
i8 = "int8_t",
i16 = "int16_t",
i32 = "int32_t",
i64 = "int64_t",
u8 = "uint8_t",
u16 = "uint16_t",
u32 = "uint32_t",
u64 = "uint64_t",
f32 = "float",
f64 = "double"
)
if (type_name %in% names(alias_map)) {
mapped <- unname(alias_map[[type_name]])
return(mapped)
}
type_name
}
map_c_to_cb_arg_kind <- function(c_type) {
cb_arg_kind_rule(normalize_cb_kind_key(c_type))
}
map_c_to_cb_arg_value <- function(c_type, arg_expr) {
cb_arg_value_rule(normalize_cb_kind_key(c_type), arg_expr)
}
# Get default C return statement for a type
get_c_default_return <- function(c_type, indent = 2L) {
c_default_return_rule(normalize_default_key(c_type), indent)
}
# Map C types to R SEXP types for trampoline arguments
map_c_to_sexp_type <- function(c_type) {
c_sexp_type_rule(normalize_sexp_type_key(c_type))
}
# Map C types to FFI types
map_c_to_r_type <- function(c_type) {
c_r_type_rule(normalize_r_type_key(c_type))
}
# Get SEXP constructor for C type
get_sexp_constructor <- function(c_type) {
sexp_constructor_rule(normalize_sexp_ctor_key(c_type))
}
# Get SEXP constructor call for a C expression
get_sexp_constructor_call <- function(c_type, arg_expr) {
sexp_constructor_call_rule(normalize_sexp_ctor_key(c_type), arg_expr)
}
# Get R to C converter function
get_r_to_c_converter <- function(c_type) {
r_to_c_converter_rule(normalize_r_to_c_key(c_type))
}
get_r_to_c_return_lines <- function(c_type, result_var, indent = 2L) {
r_to_c_return_lines_rule(
normalize_return_key(c_type),
c_type,
result_var,
indent
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.