Add root_precious_list()

DESCRIPTION

@@ -20,6 +20,7 @@ Imports:
  vctrs
 Suggests: 
  cli,
+ cpp11,
  covr,
  crayon,
  igraph,

NAMESPACE

@@ -24,5 +24,6 @@ export(mem_stash)
 export(obj_address)
 export(root_cpp11)
 export(root_ns_registry)
+export(root_precious_list)
 import(rlang)
 useDynLib(memtools, .registration = TRUE)

NEWS.md

@@ -1,5 +1,10 @@
 # memtools (development version)
 
+- Added `root_precious_list()` to retrieve the R precious list. This
+ requires a custom build of R where `R_PreciousList` is redefined as
+ a non-static symbol.
+
+
 # memtools 0.1.0
 
 Initial release

R/snapshot.R

@@ -173,13 +173,17 @@ mem_stash <- function(...) {
 #' @description
 #' These functions return useful starting points to supply to
 #' [mem_snapshot()].
-#' 
+#'
 #' * `root_ns_registry()` returns R's namespace registry as a list. It
 #' contains all the namespaces currently loaded in the R session.
 #'
 #' * `root_cpp11()` returns the precious list of cpp11. This is a
 #' doubly linked list preserved in R's own precious list.
 #'
+#' * `root_precious_list()` returns R's precious list. However this
+#' requires a custom build of R where `R_PreciousList` is exposed as a
+#' non-static symbol.
+#'
 #' @section The precious list:
 #' The R precious list is (as currently implemented) a pairlist of
 #' objects currently protected via the C API function
@@ -193,9 +197,11 @@ mem_stash <- function(...) {
 #'
 #' R currently does not provide an easy way to get the precious list.
 #' So you will need to either patch R to expose it (e.g. remove its
-#' `static` qualifier) or run R though a debugger like `gdb` or
-#' `lldb`. The latter option is simpler. Once in the debugger, use `p`
-#' to print the address of the list:
+#' `static` qualifier) so that you can call `root_precious_list()`, or
+#' run R though a debugger like `gdb` or `lldb`.
+#'
+#' If you choose to use a debugger, use `p` to print the address of
+#' the list:
 #'
 #' ```
 #' p R_PreciousList
@@ -240,6 +246,32 @@ root_ns_registry <- function() {
  as.list(.Call(ffi_root_ns_registry))
 }
 
+the <- new_environment()
+
+precious_list_source <- "
+ #define R_NO_REMAP
+ #include <Rinternals.h>
+
+ extern SEXP R_PreciousList;
+
+ [[cpp11::register]]
+ SEXP precious_list() {
+ return R_PreciousList;
+ }
+"
+#' rdname roots
+#' @export
+root_precious_list <- function() {
+ check_installed(c("cpp11", "decor"))
+
+ if (is_null(the$precious_list)) {
+ cpp11::cpp_source(code = precious_list_source)
+ the$precious_list <- precious_list
+ }
+
+ the$precious_list()
+}
+
 #' Find all shortest or simple paths
 #'
 #' Wrappers around [igraph::all_shortest_paths()] and