R/zzz-finalizers.R

In dipsaus: A Dipping Sauce for Data Analysis and Visualizations

memory_address <- function(x) {
  .Call("_dipsaus_object_address", x)
}

DipsausSessionFinalizer <- R6::R6Class(
  classname = 'DipsausSessionFinalizer',
  portable = FALSE,
  parent_env = asNamespace('dipsaus'),
  cloneable = FALSE,
  private = list(
    counts = NULL,
    finalizers = NULL,
    signatures = NULL
  ),
  public = list(
    initialize = function(){
      private$counts <- fastmap2()
      private$finalizers <- fastmap2()
      private$signatures <- fastmap2()
    },
    finalize = function(){
      .subset2(private$counts, 'reset')()
      .subset2(private$signatures, 'reset')()
      .subset2(private$finalizers, 'reset')()
    },
    register = function(key, object, finalizer, onexit = FALSE,
                        replace_if_exists = c('ignore', 'flag', 'finalizer', 'both')){
      stopifnot(is.function(finalizer))
      stopifnot(is.environment(object) || inherits(object, c('externalptr')))
      replace_if_exists <- match.arg(replace_if_exists)

      object_signature <- memory_address(object)
      # have to remove the object so that there won't
      # be any reference to the object in this function
      rm(object)

      if(!.subset2(private$counts, 'has')(key)){
        private$counts[[key]] <- 1L
        private$finalizers[[key]] <- list( finalizer = finalizer, onexit = onexit )
        private$signatures[[object_signature]] <- c(private$signatures[[object_signature]], key)
      } else {
        registered_keys <- private$signatures[[object_signature]]
        registered <- key %in% registered_keys
        if(!registered){
          private$counts[[key]] <- private$counts[[key]] + 1L
          private$signatures[[object_signature]] <- c(private$signatures[[object_signature]], key)
        }

        switch (
          replace_if_exists,
          'flag' = {
            private$finalizers[[key]]$onexit <- onexit
          },
          'finalizer' = {
            private$finalizers[[key]]$finalizer <- finalizer
          },
          'both' = {
            private$finalizers[[key]]$onexit <- onexit
            private$finalizers[[key]]$finalizer <- finalizer
          }
        )

      }
      rm(finalizer)
      return(self$.generate_finalizer(key, object_signature))

    },
    .generate_finalizer = function(key, object_signature){
      new_function2(alist(e=), {
        object_signature <- !!object_signature
        key <- !!key
        registered <- private$signatures[[object_signature]]
        if(!key %in% registered){
          return()
        }
        registered <- registered[!registered %in% key]
        if(length(registered)){
          private$signatures[[object_signature]] <- registered
        } else {
          # this object is no longer used
          .subset2(private$signatures, 'remove')(object_signature)
        }
        # counting reference - 1
        new_count <- private$counts[[!!key]] - 1L
        if(new_count > 0){
          private$counts[[!!key]] <- new_count
          return()
        }

        # No reference, the key
        .subset2(private$counts, 'remove')(!!key)

        # run finalizer
        tryCatch({
          private$finalizers[[!!key]]$finalizer(e)
        }, error = function(e){
          cat2('Error occurs during finalizing an object with key ', !!key, '\nReasons: ',
               e$message, level = 'DEFAULT')
        })

        if(!isFALSE(private$finalizers[[!!key]]$onexit)){
          .subset2(private$finalizers, 'remove')(!!key)
        }
      }, env = self)
    }
  )
)


dipsaus_sessionfinalizer <- DipsausSessionFinalizer$new()


#' @title Create Shared Finalization to Avoid Over Garbage Collection
#' @description Generates a function to be passed to
#' \code{\link{reg.finalizer}}
#' @param key characters that should be identical if
#' finalization method is to be shared
#' @param x object to finalize
#' @param fin Shared finalization: function to call on finalization;
#' see \code{\link{reg.finalizer}}. See details.
#' @param onexit logical: should the finalization be run if the
#' object is still uncollected at the end of the R session?
#' See \code{\link{reg.finalizer}}
#' @param ... passed to other methods
#' @details The main purpose of this function is to allow multiple
#' objects that point to a same source (say a temporary file) to
#' perform clean up when all the objects are garbage collected.
#'
#' Base function \code{\link{reg.finalizer}} provides finalization
#' to to garbage collect single R environment. However, when multiple
#' environments share the same file, finalizing one single environment
#' will result in removing the file so that all the other environment
#' lose the reference. (See example "Native \code{reg.finalizer}
#' fails example")
#'
#' The argument of \code{fin} varies according to different types of
#' \code{x}. For environments, \code{fin} contains and only contains
#' one parameter, which is the environment itself. This is the same
#' as \code{reg.finalizer}. For \code{R6} classes, \code{fin} is
#' ignored if class has \code{"shared_finalize"} method defined.
#' For \code{\link[fastmap]{fastmap}} or \code{\link[dipsaus]{fastmap2}}
#' instances, \code{fin} accepts no argument.
#'
#' @examples
#'
#' # ------------ Environment example ------------
#' file_exists <- TRUE
#' clear_files <- function(e){
#'   print('Clean some shared files')
#'   # do something to remove files
#'   file_exists <<- FALSE
#' }
#'
#' # e1, e2 both require file existence
#' e1 <- new.env()
#' e1$valid <- function(){ file_exists }
#' e2 <- new.env()
#' e2$valid <- function(){ file_exists }
#'
#' e1$valid(); e2$valid()
#'
#' # we don't want to remove files when either e1,e2 gets
#' # garbage collected, however, we want to run `clear_files`
#' # when system garbage collecting *both* e1 and e2
#'
#' # Make sure `key`s are identical
#' shared_finalizer(e1, 'cleanXXXfiles', clear_files)
#' shared_finalizer(e2, 'cleanXXXfiles', clear_files)
#'
#' # Now remove e1, files are not cleaned, and e2 is still valid
#' rm(e1); invisible(gc(verbose = FALSE))
#' e2$valid()  # TRUE
#' file_exists # TRUE
#'
#' # remove both e1 and e2, and file gets removed
#' rm(e2); invisible(gc(verbose = FALSE))
#' file_exists  # FALSE
#'
#' # ------------ R6 example ------------
#'
#' cls <- R6::R6Class(
#'   classname = '...demo...',
#'   cloneable = TRUE,
#'   public = list(
#'     file_path = character(0),
#'     shared_finalize = function(){
#'       cat('Finalize shared resource - ', self$file_path, '\n')
#'     },
#'     finalize = function(){
#'       cat('Finalize private resource\n')
#'     },
#'     initialize = function(file_path){
#'       self$file_path = file_path
#'       shared_finalizer(self, key = self$file_path)
#'     }
#'   )
#' )
#' e1 <- cls$new('file1')
#' rm(e1); invisible(gc(verbose = FALSE))
#'
#' e1 <- cls$new('file2')
#'
#' # A copy of e1
#' e2 <- e1$clone()
#' # unfortunately, we have to manually register
#' shared_finalizer(e2, key = e2$file_path)
#'
#' # Remove e1, gc only free private resource
#' rm(e1); invisible(gc(verbose = FALSE))
#'
#' # remove e1 and e2, run shared finalize
#' rm(e2); invisible(gc(verbose = FALSE))
#'
#' # ------------ fastmap/fastmap2 example -----------
#'
#' # No formals needed for fastmap/fastmap2
#' fin <- function(){
#'   cat('Finalizer is called\n')
#' }
#' # single reference case
#' e1 <- dipsaus::fastmap2()
#' shared_finalizer(e1, 'fin-fastmap2', fin = fin)
#' invisible(gc(verbose = FALSE)) # Not triggered
#' rm(e1); invisible(gc(verbose = FALSE)) # triggered
#'
#' # multiple reference case
#' e1 <- dipsaus::fastmap2()
#' e2 <- dipsaus::fastmap2()
#' shared_finalizer(e1, 'fin-fastmap2', fin = fin)
#' shared_finalizer(e2, 'fin-fastmap2', fin = fin)
#'
#' rm(e1); invisible(gc(verbose = FALSE)) # Not triggered
#' rm(e2); invisible(gc(verbose = FALSE)) # triggered
#'
#' # ------------ Native reg.finalizer fails example ------------
#'
#' # This example shows a failure case using base::reg.finalizer
#'
#' file_exists <- TRUE
#' clear_files <- function(e){
#'   print('Clean some shared files')
#'   # do something to remove files
#'   file_exists <<- FALSE
#' }
#'
#' # e1, e2 both require file existence
#' e1 <- new.env()
#' e1$valid <- function(){ file_exists }
#' e2 <- new.env()
#' e2$valid <- function(){ file_exists }
#'
#' reg.finalizer(e1, clear_files)
#' reg.finalizer(e2, clear_files)
#' gc()
#' file_exists
#'
#' # removing e1 will invalidate e2
#' rm(e1); gc()
#' e2$valid()    # FALSE
#'
#' # Clean-ups
#' rm(e2); gc()
#'
#' @export
shared_finalizer <- function(x, key, fin, onexit = FALSE, ...){
  UseMethod('shared_finalizer')
}

#' @rdname shared_finalizer
#' @export
shared_finalizer.default <- function(x, key, fin, onexit = FALSE, ...){
  re <- dipsaus_sessionfinalizer$register(
    key = key, object = x, finalizer = fin, onexit = onexit,
    replace_if_exists = 'both')
  assign('@@finalize@@', re, envir = x)

  finalizer_wrapper <- function(e) {
    .subset2(e, '@@finalize@@')(e)
    rm(e)
  }
  environment(finalizer_wrapper) <- baseenv()
  reg.finalizer(x, finalizer_wrapper, onexit = onexit)

  rm(key, x, fin, re, onexit)
  invisible()
}

#' @rdname shared_finalizer
#' @export
shared_finalizer.R6 <- function(x, key, fin, onexit = TRUE, ...){
  if(is.function(.subset2(x, 'shared_finalize'))){
    r6_finalize <- function(e) {
      .subset2(e, 'shared_finalize')()
    }
    environment(r6_finalize) <- baseenv()
  } else {
    r6_finalize <- fin
  }

  re <- dipsaus_sessionfinalizer$register(
    key = key, object = x, finalizer = r6_finalize, onexit = onexit,
    replace_if_exists = 'both')

  reg.finalizer(x, re, onexit = onexit)

  rm(key, x, re, onexit, r6_finalize)
  invisible()
}

#' @rdname shared_finalizer
#' @export
shared_finalizer.fastmap <- function(x, key, fin, onexit = FALSE, ...){
  cenv <- environment(.subset2(x, 'reset'))
  # create an wrapper
  if(!length(formals(fin))){
    formals(fin) <- alist(...=)
  }

  re <- dipsaus_sessionfinalizer$register(
    key = key, object = cenv$key_idx_map, finalizer = fin, onexit = onexit,
    replace_if_exists = 'both')

  reg.finalizer(cenv$key_idx_map, re, onexit = onexit)

  rm(key, x, re, onexit, cenv, fin)
  invisible()
}

#' @rdname shared_finalizer
#' @export
shared_finalizer.fastmap2 <- function(x, key, fin, onexit = FALSE, ...){
  shared_finalizer.fastmap(x, key, fin, onexit, ...)
  rm(key, x, onexit, fin)
  invisible()
}