Add compositional lock-free doubly-linked list

src/kcas_data/dllist.ml

@@ -0,0 +1,176 @@
+open Kcas
+
+type 'a t = { prev : 'a t Loc.t; next : 'a t Loc.t }
+type 'a node = { node_prev : 'a t Loc.t; node_next : 'a t Loc.t; value : 'a }
+
+external as_list : 'a node -> 'a t = "%identity"
+external as_node : 'a t -> 'a node = "%identity"
+
+let get { value; _ } = value [@@inline]
+
+let create () =
+  let prev = Loc.make (Obj.magic ()) and next = Loc.make (Obj.magic ()) in
+  let list = { prev; next } in
+  Loc.set prev list;
+  Loc.set next list;
+  list
+
+let create_node ~prev ~next value =
+  { node_prev = Loc.make prev; node_next = Loc.make next; value }
+
+module Xt = struct
+  let remove ~xt node =
+    let list = as_list node in
+    let next = Xt.exchange ~xt list.next list in
+    if next != list then (
+      let prev = Xt.exchange ~xt list.prev list in
+      Xt.set ~xt next.prev prev;
+      Xt.set ~xt prev.next next)
+
+  let is_empty ~xt list = Xt.get ~xt list.prev == list
+
+  let add_node_l ~xt node list =
+    let next = Xt.get ~xt list.next in
+    assert (Loc.get node.node_prev == list);
+    Loc.set node.node_next next;
+    Xt.set ~xt list.next (as_list node);
+    Xt.set ~xt next.prev (as_list node);
+    node
+
+  let add_l ~xt value list =
+    let next = Xt.get ~xt list.next in
+    let node = create_node ~prev:list ~next value in
+    Xt.set ~xt list.next (as_list node);
+    Xt.set ~xt next.prev (as_list node);
+    node
+
+  let add_node_r ~xt node list =
+    let prev = Xt.get ~xt list.prev in
+    Loc.set node.node_prev prev;
+    assert (Loc.get node.node_next == list);
+    Xt.set ~xt list.prev (as_list node);
+    Xt.set ~xt prev.next (as_list node);
+    node
+
+  let add_r ~xt value list =
+    let prev = Xt.get ~xt list.prev in
+    let node = create_node ~prev ~next:list value in
+    Xt.set ~xt list.prev (as_list node);
+    Xt.set ~xt prev.next (as_list node);
+    node
+
+  let take_opt_l ~xt list =
+    let next = Xt.get ~xt list.next in
+    if next == list then None
+    else
+      let node = as_node next in
+      remove ~xt node;
+      Some node.value
+
+  let take_opt_r ~xt list =
+    let prev = Xt.get ~xt list.prev in
+    if prev == list then None
+    else
+      let node = as_node prev in
+      remove ~xt node;
+      Some node.value
+
+  let take_blocking_l ~xt list = Xt.to_blocking ~xt (take_opt_l list)
+  let take_blocking_r ~xt list = Xt.to_blocking ~xt (take_opt_r list)
+
+  let transfer_l ~xt t1 t2 =
+    let t1_next = Xt.exchange ~xt t1.next t1 in
+    if t1_next != t1 then (
+      let t1_prev = Xt.exchange ~xt t1.prev t1 in
+      let t2_next = Xt.exchange ~xt t2.next t1_next in
+      Xt.set ~xt t2_next.prev t1_prev;
+      Xt.set ~xt t1_next.prev t2;
+      Xt.set ~xt t1_prev.next t2_next)
+
+  let transfer_r ~xt t1 t2 =
+    let t1_next = Xt.exchange ~xt t1.next t1 in
+    if t1_next != t1 then (
+      let t1_prev = Xt.exchange ~xt t1.prev t1 in
+      let t2_prev = Xt.exchange ~xt t2.prev t1_prev in
+      Xt.set ~xt t2_prev.next t1_next;
+      Xt.set ~xt t1_prev.next t2;
+      Xt.set ~xt t1_next.prev t2_prev)
+
+  let swap ~xt t1 t2 =
+    let t1_next = Xt.get ~xt t1.next in
+    if t1_next == t1 then transfer_l ~xt t2 t1
+    else
+      let t2_prev = Xt.get ~xt t2.prev in
+      if t2_prev == t2 then transfer_l ~xt t1 t2
+      else
+        let t1_prev = Xt.exchange ~xt t1.prev t2_prev
+        and t2_next = Xt.exchange ~xt t2.next t1_next in
+        Xt.set ~xt t2.prev t1_prev;
+        Xt.set ~xt t1.next t2_next;
+        Xt.set ~xt t2_next.prev t1;
+        Xt.set ~xt t2_prev.next t1;
+        Xt.set ~xt t1_next.prev t2;
+        Xt.set ~xt t1_prev.next t2
+
+  let[@tail_mod_cons] rec to_list_as_l ~xt f list node =
+    if node == list then []
+    else f (as_node node) :: to_list_as_l ~xt f list (Xt.get ~xt node.next)
+
+  let to_list_as_l ~xt f list = to_list_as_l ~xt f list (Xt.get ~xt list.next)
+  let to_list_l ~xt list = to_list_as_l ~xt get list
+  let to_nodes_l ~xt list = to_list_as_l ~xt Fun.id list
+
+  let[@tail_mod_cons] rec to_list_as_r ~xt f list node =
+    if node == list then []
+    else f (as_node node) :: to_list_as_r ~xt f list (Xt.get ~xt node.prev)
+
+  let to_list_as_r ~xt f list = to_list_as_r ~xt f list (Xt.get ~xt list.prev)
+  let to_list_r ~xt list = to_list_as_r ~xt get list
+  let to_nodes_r ~xt list = to_list_as_r ~xt Fun.id list
+end
+
+let remove node = Kcas.Xt.commit { tx = Xt.remove node }
+let is_empty list = Loc.get list.prev == list
+
+let add_l value list =
+  let node = create_node ~prev:list ~next:list value in
+  Kcas.Xt.commit { tx = Xt.add_node_l node list }
+
+let add_r value list =
+  let node = create_node ~prev:list ~next:list value in
+  Kcas.Xt.commit { tx = Xt.add_node_r node list }
+
+let take_opt_l list = Kcas.Xt.commit { tx = Xt.take_opt_l list }
+let take_opt_r list = Kcas.Xt.commit { tx = Xt.take_opt_r list }
+let take_blocking_l list = Kcas.Xt.commit { tx = Xt.take_blocking_l list }
+let take_blocking_r list = Kcas.Xt.commit { tx = Xt.take_blocking_r list }
+let swap t1 t2 = Kcas.Xt.commit { tx = Xt.swap t1 t2 }
+let transfer_l t1 t2 = Kcas.Xt.commit { tx = Xt.transfer_l t1 t2 }
+let transfer_r t1 t2 = Kcas.Xt.commit { tx = Xt.transfer_r t1 t2 }
+let to_list_l list = Kcas.Xt.commit { tx = Xt.to_list_l list }
+let to_list_r list = Kcas.Xt.commit { tx = Xt.to_list_r list }
+let to_nodes_l list = Kcas.Xt.commit { tx = Xt.to_nodes_l list }
+let to_nodes_r list = Kcas.Xt.commit { tx = Xt.to_nodes_r list }
+
+exception Empty
+
+let take_l list = match take_opt_l list with None -> raise Empty | Some v -> v
+let take_r list = match take_opt_r list with None -> raise Empty | Some v -> v
+
+let take_all list =
+  let copy = { prev = Loc.make list; next = Loc.make list } in
+  let open Kcas in
+  let tx ~xt =
+    let prev = Xt.exchange ~xt list.prev list in
+    if prev == list then (
+      Loc.set copy.prev copy;
+      Loc.set copy.next copy)
+    else
+      let next = Xt.exchange ~xt list.next list in
+      Xt.set ~xt prev.next copy;
+      Xt.set ~xt next.prev copy;
+      Loc.set copy.prev prev;
+      Loc.set copy.next next
+  in
+  Xt.commit { tx };
+  copy

src/kcas_data/dllist.mli

@@ -0,0 +1,79 @@
+open Kcas
+
+(** Doubly-linked list.
+
+    The interface provides a subset of the operations of the doubly-linked list
+    data structure provided by the
+    {{:https://opam.ocaml.org/packages/lwt-dllist/}lwt-dllist} package with some
+    omissions:
+
+    - The sequence iterators, e.g. [iter_l], [iter_node_l], [fold_l],
+      [find_node_opt_l], and [find_node_l], are not provided.
+    - The [length] operation is not provided.
+    - The [set] operation is not provided.
+
+    A non-compositional {!take_all} operation is added for {{:
+    https://en.wikipedia.org/wiki/Privatization_(computer_programming)}privatization}
+    as well as conversions to a list of nodes ({!to_nodes_l} and {!to_nodes_r})
+    and to a list of values ({!to_list_l} and {!to_list_r}).
+
+    Probably the main reason to use a doubly-linked list like this rather than
+    e.g. a ['a list Loc.t] is the ability to remove a node without having to
+    potentially iterate through the list:
+
+    {[
+      let node_of_x = add_l x list in
+      (* ... and then later somewhere else ... *)
+      remove node_of_x
+    ]}
+
+    A doubly-linked list can also be used as a deque or double-ended queue, but
+    a deque implementation that doesn't allow individual nodes to be removed is
+    likely to be faster. *)
+
+(** {1 Common interface} *)
+
+type 'a t
+(** Type of a doubly-linked list containing {!node}s of type ['a]. *)
+
+type 'a node
+(** Type of a node containing a value of type ['a]. *)
+
+val get : 'a node -> 'a
+(** [get node] returns the value stored in the {!node}. *)
+
+val create : unit -> 'a t
+(** [create ()] return a new doubly-linked list. *)
+
+(** {1 Compositional interface} *)
+
+module Xt :
+  Dllist_intf.Ops
+    with type 'a t := 'a t
+    with type 'a node := 'a node
+    with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn
+(** Explicit transaction log passing on doubly-linked lists. *)
+
+(** {1 Non-compositional interface} *)
+
+include
+  Dllist_intf.Ops
+    with type 'a t := 'a t
+    with type 'a node := 'a node
+    with type ('x, 'fn) fn := 'fn
+
+val take_all : 'a t -> 'a t
+(** [take_all l] removes all nodes of the doubly-linked list [l] and returns a
+    new doubly-linked list containing the removed nodes. *)
+
+exception Empty
+(** Raised when {!take_l} or {!take_r} is applied to an empty doubly-linked
+    list. *)
+
+val take_l : 'a t -> 'a
+(** [take_l l] removes and returns the value of the leftmost node of the
+    doubly-linked list [l], or raises {!Empty} if the list is empty. *)
+
+val take_r : 'a t -> 'a
+(** [take_r l] removes and returns the value of the rightmost node of the
+    doubly-linked list [l], or raises {!Empty} if the list is empty. *)

src/kcas_data/dllist_intf.ml

@@ -0,0 +1,79 @@
+module type Ops = sig
+  type 'a t
+  type 'a node
+  type ('x, 'fn) fn
+
+  val remove : ('x, 'a node -> unit) fn
+  (** [remove n] removes the node [n] from the doubly-linked list it is part of.
+      [remove] is idempotent. *)
+
+  val is_empty : ('x, 'a t -> bool) fn
+  (** [is_empty l] determines whether the doubly-linked list [l] is empty or
+      not. *)
+
+  val add_l : ('x, 'a -> 'a t -> 'a node) fn
+  (** [add_l v l] creates and returns a new node with the value [v] and adds the
+      node to the left of the doubly-linked list [l]. *)
+
+  val add_r : ('x, 'a -> 'a t -> 'a node) fn
+  (** [add_r v l] creates and returns a new node with the value [v] and adds the
+      node to the right of the doubly-linked list [l]. *)
+
+  val take_opt_l : ('x, 'a t -> 'a option) fn
+  (** [take_opt_l l] removes and returns the value of leftmost node of the
+      doubly-linked list [l], or return [None] if the list is empty. *)
+
+  val take_opt_r : ('x, 'a t -> 'a option) fn
+  (** [take_opt_r l] removes and returns the value of rightmost node of the
+      doubly-linked list [l], or return [None] if the list is empty. *)
+
+  val take_blocking_l : ('x, 'a t -> 'a) fn
+  (** [take_blocking_l l] removes and returns the value of leftmost node of the
+      doubly-linked list [l], or blocks waiting for the list to become
+      non-empty. *)
+
+  val take_blocking_r : ('x, 'a t -> 'a) fn
+  (** [take_blocking_r l] removes and returns the value of rightmost node of the
+      doubly-linked list [l], or blocks waiting for the list to become
+      non-empty. *)
+
+  val swap : ('x, 'a t -> 'a t -> unit) fn
+  (** [swap l1 l2] exchanges the nodes of the doubly-linked lists [l1] and
+      [l2]. *)
+
+  val transfer_l : ('x, 'a t -> 'a t -> unit) fn
+  (** [transfer_l l1 l2] removes all nodes of [l1] and adds them to the left of
+      [l2]. *)
+
+  val transfer_r : ('x, 'a t -> 'a t -> unit) fn
+  (** [transfer_r l1 l2] removes all nodes of [l1] and adds them to the right of
+      [l2]. *)
+
+  val to_list_l : ('x, 'a t -> 'a list) fn
+  (** [to_list_l l] collects the values of the nodes of the doubly-linked list
+      [l] to a list in left-to-right order.
+
+      {b NOTE}: This operation is linear time, [O(n)], and should typically be
+      avoided unless the list is privatized, e.g. by using {!take_all}. *)
+
+  val to_list_r : ('x, 'a t -> 'a list) fn
+  (** [to_list_r l] collects the values of the nodes of the doubly-linked list
+      [l] to a list in right-to-left order.
+
+      {b NOTE}: This operation is linear time, [O(n)], and should typically be
+      avoided unless the list is privatized, e.g. by using {!take_all}. *)
+
+  val to_nodes_l : ('x, 'a t -> 'a node list) fn
+  (** [to_nodes_l l] collects the nodes of the doubly-linked list [l] to a list
+      in left-to-right order.
+
+      {b NOTE}: This operation is linear time, [O(n)], and should typically be
+      avoided unless the list is privatized, e.g. by using {!take_all}. *)
+
+  val to_nodes_r : ('x, 'a t -> 'a node list) fn
+  (** [to_nodes_r l] collects the nodes of the doubly-linked list [l] to a list
+      in right-to-left order.
+
+      {b NOTE}: This operation is linear time, [O(n)], and should typically be
+      avoided unless the list is privatized, e.g. by using {!take_all}. *)
+end

src/kcas_data/kcas_data.ml

@@ -58,6 +58,10 @@ module Stack = Stack
 
 module Promise = Promise
 
+(** {1 Linked data structures} *)
+
+module Dllist = Dllist
+
 (** {1 Utilities} *)
 
 module Accumulator = Accumulator

test/kcas_data/dllist_test.ml

@@ -0,0 +1,40 @@
+open Kcas_data
+
+let[@tail_mod_cons] rec take_as_list take l =
+  match take l with None -> [] | Some x -> x :: take_as_list take l
+
+let () =
+  let t1 = Dllist.create () in
+  let t1' = Dllist.take_all t1 in
+  assert (Dllist.to_list_r t1 = [] && Dllist.to_list_l t1' = []);
+  Dllist.transfer_r t1' t1';
+  Dllist.add_r 2 t1' |> ignore;
+  Dllist.add_r 3 t1' |> ignore;
+  Dllist.swap t1' t1';
+  Dllist.add_l 1 t1' |> ignore;
+  Dllist.transfer_r t1' t1';
+  let t1 = Dllist.take_all t1' in
+  assert (Dllist.to_list_l t1' = [] && Dllist.to_list_r t1 = [ 3; 2; 1 ]);
+  let t2 = Dllist.create () in
+  Dllist.transfer_r t2 t1;
+  Dllist.transfer_l t2 t1;
+  Dllist.swap t1 t2;
+  Dllist.swap t1 t2;
+  Dllist.transfer_l t2 t2;
+  Dllist.add_r 4 t2 |> ignore;
+  Dllist.swap t1 t2;
+  Dllist.swap t1 t2;
+  Dllist.transfer_l t2 t2;
+  Dllist.transfer_l t1 t2;
+  Dllist.transfer_l t1 t2;
+  Dllist.swap t1 t2;
+  assert (Dllist.take_opt_l t2 = None);
+  assert (Dllist.take_opt_l t2 = None);
+  assert (take_as_list Dllist.take_opt_r t1 = [ 4; 3; 2; 1 ])
+
+let () =
+  let l = Dllist.create () in
+  Dllist.add_l 1 l |> ignore;
+  Dllist.add_l 3 l |> ignore;
+  Dllist.add_r 4 l |> ignore;
+  assert (take_as_list Dllist.take_opt_l l = [ 3; 1; 4 ])

test/kcas_data/dune

@@ -1,4 +1,4 @@
 (tests
- (names hashtbl_test hashtbl_bench queue_test stack_test)
+ (names dllist_test hashtbl_test hashtbl_bench queue_test stack_test)
  (libraries kcas kcas_data unix)
  (package kcas_data))