cpp11 memory leak

memleak-basic.R

docker run --rm -ti --security-opt seccomp=unconfined wch1/r-debug

# =====================================================================
# Setup
# =====================================================================
RD -e 'install.packages(c("cpp11", "decor", "igraph"))'
RD -e 'remotes::install_github("r-lib/memtools", build_manual = FALSE, build_vignettes = FALSE)'


# ==============================================================================
# R code to reproduce issue
# ==============================================================================

RD -d gdb
r

# =================================================
# websocket test code
# =================================================
# This test results in an object not being GC'd, even though it should be.

library(cpp11)
library(memtools)
library(rlang)

cpp_function('void invoke(function fn) {
  fn();
}')

f <- local({
  e <- environment()
  # Save the address for later inspection
  e_addr <<- sexp_address(e)
  reg.finalizer(e, function(e) message(format(e), " finalized\n"))
  function() {
    message("Environment is ", format(e), "\n")
  }
})

invoke(f)

rm(f); invisible(gc())
invisible(gc())

# ==============================================================================
# Use memtools to investigate memory leak
# ==============================================================================

#### Press Ctrl-C ####
p R_PreciousList
c

### Copy and paste the R_PreciousList address here ###
pl_addr <- "0x5555578993d0"

# Look at first few items in precious list
deref(pl_addr)[1:3]
#> [[1]][[1]]
#> NULL
#> 
#> . 
#> 
#>  [1] 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
#> 
#> 
#> [[2]]
#> [[2]][[1]]
#> (function() {
#>     message("Environment is ", format(e), "\n")
#>   })()
#> 
#> . 
#> 
#>  [1] 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
#> 
#> 
#> [[3]]
#> [[3]][[1]]
#> NULL
#> 

# Inspect the vectors full of 00's
str(node_cdr(deref(pl_addr)[[1]]))
#>  raw [1:16] 00 00 00 00 ...



# Address of the environment has already been saved in the test code to a
# variable named e_addr. (Print it out to make sure)
deref(e_addr)

if(exists("s")) rm(s)
s <- mem_snapshot(deref(pl_addr))

(ns_i <- which(s$id == e_addr))
(node <- s$node[[ns_i]])
(dom <- node$dominator)


paths <- mem_paths_shortest(s, node, from = pl_addr)
length(paths)
p1 <- paths[[1]]
p1

memleak-websocket.R

# Code for reproducing weird memory leak issue with websocket and cpp11
# https://github.com/rstudio/websocket/pull/73

docker run --rm -ti --security-opt seccomp=unconfined wch1/r-debug

# =====================================================================
# Setup
# =====================================================================
git clone https://github.com/rstudio/websocket.git
cd websocket
git checkout cpp11
RD -e 'install.packages(c("httpuv", "igraph"))'
RD -e "remotes::install_local()"
RD -e 'remotes::install_github("r-lib/memtools", build_manual = FALSE, build_vignettes = FALSE)'


# ==============================================================================
# R code to reproduce issue
# ==============================================================================

RD -d gdb
r

# =================================================
# websocket test code
# =================================================
# This test results in an object not being GC'd, even though it should be.

library(memtools)
library(websocket)

echo_server <- function(port = httpuv::randomPort()) {
  httpuv::startServer("127.0.0.1", port,
    list(
      onWSOpen = function(ws) {
        ws$onMessage(function(binary, message) {
          ws$send(message)
        })
      }
    )
  )
}
shut_down_server <- function(s) {
  # Run the event loop a few more times to make sure httpuv handles the closed
  # websocket properly.
  for (i in 1:5) later::run_now(0.02)
  s$stop()
}
server_url <- function(server) {
  paste0("ws://", server$getHost(), ":", server$getPort(), "/")
}

local({
  s <- echo_server()
  on.exit(shut_down_server(s))
  url <- server_url(s)

  # Test closed WebSocket is GC'd
  collected <- FALSE
  local({
    ws <- WebSocket$new(url)
    ws$onOpen(function(event) {
      message("closing!!")
      ws$close()
    })
    reg.finalizer(ws, function(obj) {
      collected <<- TRUE
    })
    cat(paste0('==================\nws_addr <<- "', sexp_address(ws), '"'))
    ws_addr <<- sexp_address(ws)
    # Pump events until connection is closed, or up to 10 seconds.
    end_time <- as.numeric(Sys.time()) + 10
    while (ws$readyState() != 3L && as.numeric(Sys.time()) < end_time) {
      later::run_now(0.1)
    }
  })
  gc()
  if (!collected) {
    message("Not GC'd!")
  }
})


# ==============================================================================
# Use memtools to investigate memory leak
# ==============================================================================

#### Press Ctrl-C ####
p R_PreciousList
c

### Copy and paste the R_PreciousList address here ###
pl_addr <- "0x555557b77108"


# Address of the WebSocket object has already been saved in the test code to
# a variable named ws_addr. (Print it out to make sure)
deref(ws_addr)

s <- mem_snapshot(deref(pl_addr))
# s <- mem_snapshot(root_ns_registry())

(ns_i <- which(s$id == ws_addr))
(node <- s$node[[ns_i]])
(dom <- node$dominator)


paths <- mem_paths_shortest(s, node, from = dom)
length(paths)
p1 <- paths[[1]]


# At this point, p1[[7]] is the WebSocket object (which should have been GC'd).
p1[[7]]

# Looking at p1[[2]]
deref(p1[[2]])
#> [[1]]
#> function (eventName)
#> {
#>     callbacks <- private$callbacks[[eventName]]
#>     stopifnot(!is.null(callbacks))
#>     callbacks$invoke
#> }
#> <environment: 0x55555afb2e10>
#>
#> .
#>
#>  [1] 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00


# Calling str() on that object causes a segfault:
str(deref(p1[[2]]))
#> Thread 1 "R" received signal SIGSEGV, Segmentation fault.
#> 0x00007ffff7a77eaf in getAttrib0 (vec=0x55555b2129e8, name=0x555555570380) at attrib.c:132
#> 132     else if (isSymbol(TAG(vec))) {