Skip to content

Commit

Permalink
Expose Dllist type to allow matchable cursors
Browse files Browse the repository at this point in the history
Being able to freely point to locations in a double-linked list allows more uses
for a double-linked list.
  • Loading branch information
polytypic committed Feb 8, 2024
1 parent b3b3c41 commit 037f13b
Show file tree
Hide file tree
Showing 5 changed files with 50 additions and 4 deletions.
7 changes: 6 additions & 1 deletion README.md
Original file line number Diff line number Diff line change
Expand Up @@ -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 = <poly>; id = <poly>};
table = <abstr>; order = <abstr>}
table = <abstr>;
order =
Kcas_data.Dllist.List
{Kcas_data.Dllist.lhs =
Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
rhs = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}}}
# Xt.commit { tx = set_blocking a_cache 101 "basics" }
- : unit = ()
Expand Down
5 changes: 5 additions & 0 deletions src/kcas_data/dllist.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down
23 changes: 21 additions & 2 deletions src/kcas_data/dllist.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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. *)
Expand All @@ -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

Expand Down
9 changes: 9 additions & 0 deletions src/kcas_data/dllist_intf.ml
Original file line number Diff line number Diff line change
@@ -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

Expand Down Expand Up @@ -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
10 changes: 9 additions & 1 deletion test/kcas_data/dllist_test.ml
Original file line number Diff line number Diff line change
@@ -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

Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 037f13b

Please sign in to comment.