Simulating doubly-linked lists with hashtables

lru.r

library(microbenchmark)

lru_cache <- function(cache.size = 1000) {
  lru <- new.env(hash=TRUE, parent=emptyenv(), size=cache.size)
  pred <- new.env(hash=TRUE, parent=emptyenv(), size=cache.size)
  succ <- new.env(hash=TRUE, parent=emptyenv(), size=cache.size)

  pred$TAIL <- "HEAD"
  succ$HEAD <- "TAIL"

  COUNT <- 0

  function(key, value) {
    #value lazily forced if not found
    if (exists(key, lru)) {
      #move accessed value to front
      new_succ <- succ[[key]]
      new_pred <- pred[[key]]
      succ[[new_pred]] <<- new_succ
      pred[[new_succ]] <<- new_pred
      pred[[succ$HEAD]] <<- key
      pred[[key]] <<- "HEAD"
      succ[[key]] <<- succ$HEAD
      succ$HEAD <<- key
      lru[[key]]
    } else {
      lru[[key]] <<- value
      #drop if count exceeded
      if (COUNT >= cache.size) {
        last <- pred$TAIL
        succ[[pred[[last]]]] <<- "TAIL"
        pred$TAIL <<- pred[[last]]
        del(last, lru)
        del(last, pred)
        del(last, succ)
      } else {
        COUNT <<- COUNT + 1
      }
      succ[[key]] <<- succ$HEAD
      pred[[succ$HEAD]] <<- key
      succ$HEAD <<- key
      pred[[key]] <<- "HEAD"
      value
    }
  }
}

del <- function(x, envir=parent.frame()) {
  #fast removal from hashtable
  .Internal(remove(x, envir, FALSE))
}

list_cache <- function(fn) {
  e <- environment(fn)
  ptr <- "HEAD"
  nm <- vector("character", vars$COUNT)
  val <- vector("list", vars$COUNT)
  for (i in seq_len(vars$COUNT)) {
    ptr <- e$succ[[ptr]]
    nm[[i]] <- ptr
    val[[i]] <- e$lru[[ptr]]
  }
}

dumb_cache <- function() {
  # just store values, no clean up, leak memory
  dumb.cache <- new.env(hash=TRUE, parent=emptyenv(), size=cache.size)

  function(key, value) {
    if (exists(key, dumb.cache)) {
      dumb.cache[[key]]
    } else {
      dumb.cache[[key]] <<- value
      value
    }
  }
}

no_cache <- function() {
  function(key, value) value
}

bench_cache <- function(x) {
  cache_accessor <- function(cache) {
    function() {
      x <- sample(letters, 1)
      cache(x, toupper(x))
    }
  }

  nothing <- function() sample(LETTERS, 1)
  none <- cache_accessor(no_cache())
  dumb <- cache_accessor(dumb_cache())
  lru_nodelete <- cache_accessor(lru_cache(30))
  lru_delete <- cache_accessor(lru_cache(10))

  microbenchmark(
    nothing = nothing(),
    none = none(),
    dumb = dumb(),
    nodelete = lru_nodelete(),
    delete = lru_delete(),
    times=10000
    )
}