A lock-free starvation avoiding bag

article.md

A lock-free starvation avoiding bag

module type Bag = sig
  type 'a t
  val create : unit -> 'a t
  val to_list : 'a t -> 'a list
  type 'a handle
  val add : 'a t -> 'a -> 'a handle
  val remove : 'a t -> 'a handle -> unit
end

type 'a state = {
  balance : int;
  handles : 'a option Atomic.t list;
}

let create () =
  Atomic.make { balance = 0; handles = [] }

let to_list t =
  List.filter_map Atomic.get (Atomic.get t).handles

let rec gc length handles = function
  | [] -> { balance = length; handles }
  | h :: hs ->
    if Atomic.get h == None then gc length handles hs
    else gc (length + 1) (h :: handles) hs

let rec add t handle backoff =
  let before = Atomic.get t in
  let after =
    if 0 <= before.balance then
      { balance = before.balance + 1;
        handles = handle :: before.handles }
    else gc 1 [ handle ] before.handles
  in
  if Atomic.compare_and_set t before after then handle
  else add t handle (Backoff.once backoff)

let add t value =
  add t (Atomic.make (Some value)) Backoff.default

let rec remove t backoff =
  let before = Atomic.get t in
  let after =
    if 0 <= before.balance then
      { before with balance = before.balance - 2 }
    else gc 0 [] before.handles
  in
  if not (Atomic.compare_and_set t before after) then
    remove t (Backoff.once backoff)

let remove t handle =
  if Atomic.exchange handle None != None then
    remove t Backoff.default

module Bag : Bag = struct
  type 'a t = 'a state Atomic.t
  let create = create
  let to_list = to_list
  type 'a handle = 'a option Atomic.t
  let add = add
  let remove = remove
end

dune

(mdx
 (files article.md)
 (libraries backoff))

dune-project

(lang dune 3.8)

(using mdx 0.4)