diff --git a/README.md b/README.md index b8338749..59ef6aa7 100644 --- a/README.md +++ b/README.md @@ -1024,7 +1024,12 @@ We can then test that the cache works as expected: # let a_cache : (int, string) cache = cache 2 val a_cache : (int, string) cache = {space = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; - table = ; order = } + table = ; + order = + Kcas_data.Dllist.List + {Kcas_data.Dllist.lhs = + Kcas.Loc.Loc {Kcas.Loc.state = ; id = }; + rhs = Kcas.Loc.Loc {Kcas.Loc.state = ; id = }}} # Xt.commit { tx = set_blocking a_cache 101 "basics" } - : unit = () diff --git a/src/kcas_data/dllist.ml b/src/kcas_data/dllist.ml index 4b93cd48..58c330d1 100644 --- a/src/kcas_data/dllist.ml +++ b/src/kcas_data/dllist.ml @@ -70,6 +70,9 @@ let create_node_with ~lhs ~rhs value = Node { lhs = Loc.make (At lhs); rhs = Loc.make (At rhs); value } module Xt = struct + let get_l ~xt (At at) = Xt.get ~xt (lhs_of at) + let get_r ~xt (At at) = Xt.get ~xt (rhs_of at) + let remove ~xt node = let (At rhs) = Xt.exchange ~xt (rhs_of node) (At node) in if At rhs != At node then begin @@ -210,6 +213,8 @@ module Xt = struct let to_nodes_r ~xt list = to_list_as_r ~xt Fun.id list end +let get_l (At at) = Loc.get (lhs_of at) +let get_r (At at) = Loc.get (rhs_of at) let remove node = Kcas.Xt.commit { tx = Xt.remove node } let is_empty list = Loc.get (lhs_of list) == At list diff --git a/src/kcas_data/dllist.mli b/src/kcas_data/dllist.mli index de21e093..9f385098 100644 --- a/src/kcas_data/dllist.mli +++ b/src/kcas_data/dllist.mli @@ -33,10 +33,27 @@ open Kcas (** {1 Common interface} *) -type !'a t +(** Tagged GADT for doubly-linked lists. *) +type ('a, _) tdt = + | List : { + lhs : 'a cursor Loc.t; + rhs : 'a cursor Loc.t; + } + -> ('a, [> `List ]) tdt + | Node : { + lhs : 'a cursor Loc.t; + rhs : 'a cursor Loc.t; + value : 'a; + } + -> ('a, [> `Node ]) tdt + +(** Refers to either a {!Node} or to a doubly-linked {!List}. *) +and 'a cursor = At : ('a, [< `List | `Node ]) tdt -> 'a cursor [@@unboxed] + +type 'a t = ('a, [ `List ]) tdt (** Type of a doubly-linked list containing {!node}s of type ['a]. *) -type !'a node +type 'a node = ('a, [ `Node ]) tdt (** Type of a node containing a value of type ['a]. *) val create : unit -> 'a t @@ -58,6 +75,7 @@ module Xt : Dllist_intf.Ops with type 'a t := 'a t with type 'a node := 'a node + with type 'a cursor := 'a cursor with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn (** Explicit transaction log passing on doubly-linked lists. *) @@ -68,6 +86,7 @@ include Dllist_intf.Ops with type 'a t := 'a t with type 'a node := 'a node + with type 'a cursor := 'a cursor with type ('x, 'fn) fn := 'fn with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn diff --git a/src/kcas_data/dllist_intf.ml b/src/kcas_data/dllist_intf.ml index 738fda2c..eacbbc88 100644 --- a/src/kcas_data/dllist_intf.ml +++ b/src/kcas_data/dllist_intf.ml @@ -1,6 +1,7 @@ module type Ops = sig type 'a t type 'a node + type 'a cursor type ('x, 'fn) fn type ('x, 'fn) blocking_fn @@ -95,4 +96,12 @@ module type Ops = sig {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}. *) + + (** {2 Operations on cursors} *) + + val get_l : ('x, 'a cursor -> 'a cursor) fn + (** [get_l c] returns the cursor to the left of the current position. *) + + val get_r : ('x, 'a cursor -> 'a cursor) fn + (** [get_r c] returns the cursor to the right of the current position. *) end diff --git a/test/kcas_data/dllist_test.ml b/test/kcas_data/dllist_test.ml index 993c45d8..3269bdd6 100644 --- a/test/kcas_data/dllist_test.ml +++ b/test/kcas_data/dllist_test.ml @@ -1,5 +1,13 @@ open Kcas_data +let[@tail_mod_cons] rec to_list get_lr cursor = + match get_lr cursor with + | Dllist.At (List _) -> [] + | Dllist.At (Node _ as node) -> + Dllist.get node :: to_list get_lr (Dllist.At node) + +let to_list get_lr list = to_list get_lr (Dllist.At list) + let[@tail_mod_cons] rec take_as_list take l = match take l with None -> [] | Some x -> x :: take_as_list take l @@ -37,7 +45,7 @@ let add () = 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 ]) + assert (to_list Dllist.get_r l = [ 3; 1; 4 ]) let move () = let t1 = Dllist.create () in