")
7 | (source (github tomjridge/tjr_kv))
8 | (homepage https://github.com/tomjridge/tjr_kv)
9 | (documentation https://tomjridge.github.io/ocamldocs/)
10 | (generate_opam_files true)
11 |
12 |
13 | (package
14 | (name tjr_kv)
15 | (synopsis "A Key-Value store for OCaml (part of ImpFS)")
16 | (depends
17 | tjr_btree
18 | tjr_lru_cache
19 | tjr_mem_queue
20 | tjr_pcache
21 | ))
22 |
23 |
--------------------------------------------------------------------------------
/misc/kv_store_diagram.graphml:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
23 |
24 |
25 | LRU
26 |
27 |
28 |
29 |
30 |
31 |
32 |
33 |
34 |
35 |
36 |
37 |
38 | Pcache
39 |
40 |
41 |
42 |
43 |
44 |
45 |
46 |
47 |
48 |
49 |
50 | Block device
51 | (uncached)
52 |
53 |
54 |
55 |
56 |
57 |
58 |
59 |
60 |
61 |
62 |
63 | B-tree
64 |
65 |
66 |
67 |
68 |
69 |
70 |
71 |
72 |
73 |
74 |
75 | Block device
76 |
77 |
78 |
79 |
80 |
81 |
82 |
83 |
84 |
85 |
86 |
87 |
88 | Either B-tree block device should be uncached
89 | or syncing should not interfere with Pcache block device.
90 |
91 |
92 |
93 |
94 |
95 |
96 |
97 |
98 |
99 |
100 |
101 | User API
102 |
103 |
104 |
105 |
106 |
107 |
108 |
109 |
110 |
111 |
112 |
113 | The pcache and following components
114 | are the uncached kv store.
115 |
116 | The kv store includes the frontend LRU cache.
117 |
118 |
119 |
120 |
121 |
122 |
123 |
124 |
125 |
126 |
127 |
128 |
129 |
130 |
131 |
132 |
133 |
134 |
135 |
136 |
137 |
138 |
139 | async; in another thread
140 |
141 |
142 |
143 |
144 |
145 |
146 |
147 |
148 |
149 |
150 |
151 |
152 |
153 |
154 |
155 |
156 |
157 |
158 |
159 |
160 |
161 |
162 |
163 |
164 |
165 |
166 |
167 |
168 |
169 |
170 |
171 |
172 |
173 |
174 |
175 |
176 |
177 |
178 |
179 |
180 |
181 |
182 |
183 |
184 |
185 |
186 | sync_key; sync_all
187 |
188 |
189 |
190 |
191 |
192 |
193 |
194 |
195 |
196 |
197 |
198 |
199 |
200 |
201 |
202 |
203 |
204 |
205 |
206 |
207 |
208 |
209 |
--------------------------------------------------------------------------------
/misc/kv_store_diagram.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tomjridge/tjr_kv/43c4c7ffcfcf0d5c825cd8ba74e12688f7966d4a/misc/kv_store_diagram.png
--------------------------------------------------------------------------------
/misc/tjr_kv_config.json:
--------------------------------------------------------------------------------
1 | {
2 | "test_thread_yield_iterations" : 50,
3 | "test_thread_delay_iterations" : 100,
4 | "test_thread_delay" : 1e-06,
5 | "lru_max_size" : 256,
6 | "lru_evict_count" : 128,
7 | "dmap_filename" : "dmap.store",
8 | "dmap_ops_per_block" : 200,
9 | "dmap_blocks_limit" : 10,
10 | "dmap_thread_delay" : 1e-06,
11 | "bt_filename" : "btree.store",
12 | "bt_thread_delay" : 1e-06,
13 | "root_man_filename" : "root_man.store"
14 | }
15 |
16 |
--------------------------------------------------------------------------------
/src/_archive/dummy_dmap_layer.ml:
--------------------------------------------------------------------------------
1 | (** {2 Archived dummy Pcache and pcache_thread; do not use } *)
2 |
3 | (*
4 | open Tjr_monad.With_lwt
5 | open Kv_intf
6 | open Lwt_aux (* provides various msg queues *)
7 |
8 | open Config
9 | open Kv_profilers
10 |
11 | module S = struct
12 | type k = string
13 | let compare: k -> k -> int = Pervasives.compare
14 | type v = string
15 | end
16 | open S
17 |
18 | module Queues = Lwt_aux.Make_queues(S)
19 | open Queues
20 |
21 | (* NOTE queues are mutable *)
22 | let q_lru_pc_state = q_lru_pc.initial_state
23 | let q_pcache_bt_state = q_pcache_bt.initial_state
24 |
25 | (** {2 Simple freespace impl using an incrementing int ref} *)
26 |
27 | module Alloc = struct
28 | let fv =
29 | let x = ref 0 in
30 | fun () -> (x:=!x+1; !x)
31 | end
32 | open Alloc
33 |
34 | module Pcache' : sig
35 | val pcache_thread :
36 | yield:(unit -> unit Lwt.t) ->
37 | sleep:(float -> unit Lwt.t) -> unit -> ('a, lwt) m
38 | end = struct
39 |
40 | open Pcache_profiler
41 | let [d2b_aa ;d2b_ab ;d2b_ca ;d2b_cb ;pcache_l2d_deq1 ;pcache_l2d_deq2 ;pcache_es] =
42 | ["d2b:aa" ;"d2b:ab" ;"d2b:ca" ;"d2b:cb" ;"pcache:l2d.deq1" ;"pcache:l2d.deq2" ;"pcache_es"]
43 | |> List.map allocate_int
44 | [@@warning "-8"]
45 |
46 | open Pcache_types
47 |
48 | (** Now we fill in the missing components: [pcache_ops,
49 | pcache_blocks_limit, bt_find, bt_detach].
50 |
51 | For the time being, we would like to use a dummy implementation
52 | of pcache_ops *)
53 |
54 |
55 | let pcache_state : (k,v,'ptr)Pcache_dummy_implementation.Dummy_state.t ref =
56 | Pcache_dummy_implementation.Dummy_state.init_dummy_state ~init_ptr:0
57 | |> ref
58 |
59 | let _ = pcache_state
60 |
61 | let with_state f =
62 | f
63 | ~state:(!pcache_state)
64 | ~set_state:(fun x -> pcache_state:=x; return ())
65 |
66 | (** NOTE the following enqueues a find event on the msg queue, and
67 | constructs a promise that waits for the result *)
68 | let bt_find = fun k ->
69 | event_ops.ev_create () >>= fun ev ->
70 | let callback = fun v -> event_ops.ev_signal ev v in
71 | mark d2b_aa;
72 | q_pcache_bt.ops.memq_enqueue
73 | ~q:q_pcache_bt_state
74 | ~msg:Msg_pcache_bt.(Find(k,callback)) >>= fun () ->
75 | mark d2b_ab;
76 | event_ops.ev_wait ev
77 |
78 | let bt_handle_detach (detach_info:('k,'v,'ptr)detach_info) =
79 | (* Printf.printf "bt_handle_detach start\n%!"; *)
80 | let kv_op_map = Tjr_pcache.Op_aux.default_kvop_map_ops () in
81 | let kv_ops = detach_info.past_map |> kv_op_map.bindings |> List.map snd in
82 | mark d2b_ca;
83 | q_pcache_bt.ops.memq_enqueue
84 | ~q:q_pcache_bt_state
85 | ~msg:Msg_pcache_bt.(Detach {
86 | ops=kv_ops;
87 | new_pcache_root=detach_info.current_ptr}) >>= fun _ ->
88 | (* Printf.printf "bt_handle_detach end\n%!"; *)
89 | mark d2b_cb;
90 | return ()
91 |
92 | let pcache_ops =
93 | (* FIXME we really want an implementation that uses polymap, so we can convert to a map *)
94 | let raw_pcache_ops (* pcache_ops *) : ('op,'map,'ptr,'t)pcache_ops =
95 | Pcache_dummy_implementation.make_pcache_ops
96 | ~monad_ops
97 | ~ops_per_block:pcache_ops_per_block
98 | ~alloc_ptr:(fun () -> return (fv()))
99 | ~with_state:{with_state}
100 | in
101 | let _ : (k,v,'ptr,'t) pcache_ops = raw_pcache_ops in
102 | Pcache_with_blocks_limit.make_ops
103 | ~monad_ops
104 | ~pcache_ops:raw_pcache_ops
105 | ~pcache_blocks_limit
106 | ~bt_find
107 | ~bt_handle_detach
108 |
109 | let pcache_thread ~yield ~sleep () =
110 | let loop_evictees =
111 | let rec loop es =
112 | from_lwt(yield ()) >>= fun () ->
113 | (* Printf.printf "pcache_thread, loop_evictees\n%!"; *)
114 | match es with
115 | | [] -> return ()
116 | | (k,e)::es ->
117 | let open Im_intf in
118 | (* let open Mt_intf in *)
119 | match e with
120 | | Insert { value=v; _ } ->
121 | pcache_ops.insert k v >>= fun () ->
122 | loop es
123 | | Delete _ ->
124 | pcache_ops.delete k >>= fun () ->
125 | loop es
126 | | Lower _ ->
127 | Printf.printf "WARNING!!! unexpected evictee: Lower\n%!";
128 | assert(false) (* should never happen FIXME? *)
129 | (* loop es *)
130 | (* FIXME perhaps define a restricted type *)
131 | in
132 | loop
133 | in
134 | let rec read_and_dispatch () =
135 | (* FIXME do we need to yield if we are simply dequeueing? *)
136 | (* FIXME why is yield coerced to from_lwt? should be monad-agnostic *)
137 | from_lwt(yield ()) >>= fun () ->
138 | (* Printf.printf "pcache_thread read_and_dispatch starts\n%!"; *)
139 | mark pcache_l2d_deq1;
140 | q_lru_pc.ops.memq_dequeue q_lru_pc_state >>= fun msg ->
141 | mark pcache_l2d_deq2;
142 | (* Printf.printf "pcache_thread dequeued: %s\n%!" (Lru'.msg2string msg); *)
143 | (* FIXME the following pause seems to require that the btree
144 | thread makes progress, but of course it cannot since there
145 | are no msgs on the queue *)
146 | from_lwt(sleep pcache_thread_delay) >>= fun () -> (* FIXME *)
147 | match msg with
148 | | Insert (k,v,callback) ->
149 | pcache_ops.insert k v >>= fun () ->
150 | async (fun () -> callback ()) >>= fun () ->
151 | read_and_dispatch ()
152 | | Delete (k,callback) ->
153 | pcache_ops.delete k >>= fun () ->
154 | async (fun () -> callback ()) >>= fun () ->
155 | read_and_dispatch ()
156 | | Find (k,callback) ->
157 | pcache_ops.find k >>= fun v ->
158 | async (fun () -> callback v) >>= fun () ->
159 | read_and_dispatch ()
160 | | Evictees es ->
161 | mark pcache_es;
162 | loop_evictees es >>= fun () ->
163 | read_and_dispatch ()
164 | in
165 | read_and_dispatch ()
166 |
167 | end
168 | *)
169 |
--------------------------------------------------------------------------------
/src/_old/dummy_btree_implementation.ml:
--------------------------------------------------------------------------------
1 | (** An in-mem B-tree with sync, for testing. *)
2 |
3 | open Kv_intf
4 | open Btree_ops
5 |
6 | module Ptr = Int_.Make_type_isomorphic_to_int()
7 |
8 | module Types = struct
9 |
10 | type bt_ptr = Ptr.t
11 |
12 | type ('k,'v) bt_map = ('k,'v,unit) Tjr_map.map
13 |
14 | type ('k,'v) dummy_bt_state = {
15 | ptr: bt_ptr; (* "current" pointer; revealed on next sync *)
16 | map: ('k,'v) bt_map;
17 | synced_states: (bt_ptr * ('k,'v) bt_map) list
18 | }
19 |
20 | end
21 | include Types
22 |
23 |
24 | let empty_btree () : ('k,'v) dummy_bt_state =
25 | (* FIXME pervasives.compare *)
26 | let map = (Tjr_map.make_map_ops Pervasives.compare).empty in
27 | let ptr = Ptr.int2t 0 in
28 | let synced_states = [] in
29 | { ptr; map; synced_states }
30 |
31 | (* NOTE this assumes that ptr is greatest, which it should be given
32 | the implementation *)
33 | let new_ptr state = state.ptr |> Ptr.t2int |> fun x -> x+1 |> Ptr.int2t
34 |
35 |
36 | (** Simple implementation of the B-tree ops, for testing *)
37 | let make_dummy_btree_ops
38 | ~monad_ops ~with_state
39 | : ('k,'v,'blk_id,'t) btree_ops
40 | =
41 | let ( >>= ) = monad_ops.bind in
42 | let return = monad_ops.return in
43 | let with_btree = with_state.with_state in
44 | let count = ref 0 in
45 | (* FIXME pervasives.compare *)
46 | let map_ops = Tjr_map.make_map_ops Pervasives.compare in
47 | let find k = with_btree (fun ~state ~set_state ->
48 | map_ops.find_opt k state.map |> return)
49 | in
50 | let insert k v = with_btree (fun ~state ~set_state ->
51 | count:=!count+1;
52 | (if !count mod (int_of_float 1e5) = 0 then Printf.printf "B-tree, %d inserts\n%!" !count else ());
53 | map_ops.add k v state.map |> fun map ->
54 | set_state {state with map})
55 | in
56 | let delete k = with_btree (fun ~state ~set_state ->
57 | map_ops.remove k state.map |> fun map ->
58 | set_state {state with map})
59 | in
60 | let sync () = with_btree (fun ~state ~set_state ->
61 | let synced_states = (state.ptr,state.map)::state.synced_states in
62 | let ptr = new_ptr state in
63 | set_state {state with synced_states;ptr } >>= fun () ->
64 | return ptr)
65 | in
66 | {find;insert;delete;sync}
67 |
68 | let _ = make_dummy_btree_ops
69 |
--------------------------------------------------------------------------------
/src/_old/internal_staging.ml:
--------------------------------------------------------------------------------
1 | (*
2 | (** INTERNAL PLEASE IGNORE This is another attempt to isolate the
3 | various stages of type construction. *)
4 |
5 | open Kv_intf
6 |
7 | module type M = sig
8 | type t
9 | val monad_ops: t monad_ops
10 | end
11 |
12 |
13 | module type B1 = sig
14 | type blk_id
15 | type blk
16 | val blk_ops: blk blk_ops
17 | end
18 |
19 | module type B2 = sig
20 | include M
21 | include B1
22 | (** NOTE typically blk_dev_ops requires eg a file_descr *)
23 | val blk_dev_ops: (blk_id,blk,t)blk_dev_ops
24 | val blk_layer: (blk,(blk_id,blk,t)blk_dev_ops)blk_layer
25 | end
26 |
27 |
28 | module type K1 = sig
29 | type k
30 | val compare_k: k -> k -> int
31 | type v
32 | end
33 |
34 | module type KB1 = sig
35 | include B1
36 | include K1
37 | end
38 |
39 | module type KB2 = sig
40 | include KB1
41 | (* B-tree marshal *)
42 | end
43 |
44 | module type KB3 = sig
45 | (* pcache marshal *)
46 | end
47 |
48 |
49 | (** argument to B-tree make *)
50 | module type BT1 = sig
51 | include M
52 | include K1
53 | include B1 (* only need blk_id *)
54 | type r = blk_id
55 | end
56 |
57 | module I = Isa_btree.Isa_btree_intf
58 | module B = Tjr_btree.Btree_intf
59 |
60 | (** result of B-tree make; NOTE that B.disk_ops contains the dnode
61 | marshalling code, and that this is an argument to most of the
62 | constructor functions in Tjr_btree.Make *)
63 | module type BT2 = sig
64 | include BT1
65 | type leaf
66 | type node
67 | type leaf_stream
68 | type dnode = (node,leaf)I.dnode
69 | val leaf_ops: (k,v,leaf)I.leaf_ops
70 | val node_ops: (k,r,node)I.node_ops
71 | type disk_ops = (r,t,dnode,blk) B.disk_ops
72 | type store_ops = (r,dnode,t) I.store_ops
73 | type pre_btree_ops = (k,v,r,t,leaf,node,leaf_stream) I.pre_btree_ops
74 | val make_something: disk_ops -> unit
75 | end
76 |
77 |
78 |
79 | (** {2 Older version} *)
80 |
81 |
82 | (** These types are common to almost all the components (well, perhaps
83 | the root manager deals with blks rather than kvrt) *)
84 | module type KVRT = sig
85 | type k
86 | type v
87 | type r
88 | type blk_id = r
89 |
90 | type t
91 |
92 | (** Once the [t] monad type is fixed, the mutex and cvar types are usually also fixed *)
93 | type mutex
94 | type cvar
95 |
96 | (** The type of the monadic yield *)
97 | type yield_t
98 |
99 | (** The type of the monadic sleep *)
100 | type sleep_t
101 | end
102 |
103 | (** The following module is for system architecture documentation purposes *)
104 | module Ctxt(Pre:KVRT) = struct
105 | open Memq_intf
106 | include Pre
107 |
108 | module type LRU_DMAP = sig
109 | type msg1 = (k,v,t) Msg_lru_pc.lru_pc_msg
110 | type q1 = (mutex,cvar,msg1) queue
111 | val q_lru_pc_ops : (msg1,q1,t) memq_ops
112 | end
113 |
114 | (* NOTE leaves in the ctxt tree can be mod types rather than mods *)
115 | (** The main types and values in scope at the Lru layer *)
116 | module type LRU = sig
117 | open Syncable_map
118 | type lru_ops = (k,v,r,t) syncable_map_with_pmode
119 | val lru_ops: lru_ops
120 | (* NOTE no lru thread; lru_callback_ops are used instead *)
121 | end
122 |
123 |
124 | module type DMAP_BTREE = sig
125 | type msg2 = (k,v,blk_id,t) Msg_pc_bt.pc_bt_msg
126 | type q2 = (mutex,cvar,msg2) queue
127 | val q_dmag_bt_ops : (msg2,q2,t) memq_ops
128 | end
129 |
130 | (** The main types and values in scope at the detachable map *)
131 | module type DMAP = sig
132 | (** NOTE this thread "never" terminates; it takes msgs from the
133 | lru->pcache queue, and applies them to the log; occasionally the
134 | log is detached and the result is put on the pcache->btree queue
135 | *)
136 | val pcache_thread: yield:yield_t -> sleep:sleep_t -> unit -> ('a,t)m
137 | end
138 |
139 | module type BTREE_ROOTMAN = sig
140 | open Msg_btree_rootman
141 | type msg3 = blk_id msg_btree_rootman
142 | end
143 |
144 | module type BTREE = sig
145 | (** This thread takes items of pcache->btree, and executes against the btree *)
146 | val btree_thread: yield:yield_t -> sleep:sleep_t -> unit -> ('a,t)m
147 | end
148 |
149 | module type ROOTMAN = sig
150 | val rootman_thread: yield:yield_t -> sleep:sleep_t -> unit -> ('a,t)m
151 | end
152 | end
153 |
154 |
155 | (** Documentation of the various state types of the components *)
156 | module States(Pre:KVRT) = struct
157 | include Pre
158 |
159 | module type LRU = sig
160 | type k_map
161 | type t_map
162 | type nonrec lru_state = (k,v,k_map,t_map,t) Mt_state_type.mt_state
163 | end
164 |
165 | module type DMAP = sig
166 | open Pcache_types
167 | open Dcl_types
168 |
169 | (** NOTE typically the internal state is the same for pl and pcl,
170 | and is a buffer and an int *)
171 | type pl_and_pcl_internal_state
172 |
173 | type kvop_map
174 |
175 | (** dcl_state is start_block, current_block etc *)
176 | type nonrec dcl_state = (r,kvop_map) dcl_state
177 | type nonrec detach_info = (k,v,r) detach_info
178 | type nonrec pcache_ops = (k,v,r,t) pcache_ops
179 |
180 | type pcache_state = pl_and_pcl_internal_state * dcl_state
181 | end
182 |
183 |
184 | module type BTREE = sig
185 | (** These fixed types are placeholders *)
186 | type t1
187 | type t2
188 |
189 | (** NOTE: our examples use a file descriptor as a reference to the "block device" *)
190 | type fd
191 |
192 | (** This is the state held in memory while the B-tree executes *)
193 | type btree_state = {
194 | blk_allocator_state:t1;
195 | fstore_state:t2;
196 | btree_root_blk:blk_id;
197 | blk_dev:fd
198 | }
199 | end
200 |
201 |
202 | module type ROOTMAN = sig
203 | type fd
204 | (** This is the state held in memory and presumably mirrored
205 | somewhere on disk (at least, for the roots) eg in block 0 *)
206 | type rootman_state = {
207 | blk_dev:fd;
208 | pcache_root:blk_id;
209 | btree_root:blk_id;
210 | }
211 | end
212 |
213 | (** NOTE The system state is composed of the above, plus the
214 | contents of the queues, plus the contents of the caches (eg the
215 | store cache) *)
216 | end
217 |
218 |
219 |
220 |
221 | *)
222 |
--------------------------------------------------------------------------------
/src/_old/internal_staging.ml.html:
--------------------------------------------------------------------------------
1 |
2 |
4 |
5 |
6 | internal_staging.ml
7 |
8 |
35 |
36 |
131 |
132 |
133 |
134 | (** INTERNAL PLEASE IGNORE This is another attempt to isolate the
135 | various stages of type construction. *)
136 |
137 | open Kv_intf
138 |
139 | module type M = sig
140 | type t
141 | val monad_ops: t monad_ops
142 | end
143 |
144 |
145 | module type B1 = sig
146 | type blk_id
147 | type blk
148 | val blk_ops: blk blk_ops
149 | end
150 |
151 | module type B2 = sig
152 | include M
153 | include B1
154 | (** NOTE typically blk_dev_ops requires eg a file_descr *)
155 | val blk_dev_ops: (blk_id,blk,t)blk_dev_ops
156 | val blk_layer: (blk,(blk_id,blk,t)blk_dev_ops)blk_layer
157 | end
158 |
159 |
160 | module type K1 = sig
161 | type k
162 | val compare_k: k -> k -> int
163 | type v
164 | end
165 |
166 | module type KB1 = sig
167 | include B1
168 | include K1
169 | end
170 |
171 | module type KB2 = sig
172 | include KB1
173 |
174 | end
175 |
176 | module type KB3 = sig
177 |
178 | end
179 |
180 |
181 | (** argument to B-tree make *)
182 | module type BT1 = sig
183 | include M
184 | include K1
185 | include B1
186 | type r = blk_id
187 | end
188 |
189 | module I = Isa_btree.Isa_btree_intf
190 | module B = Tjr_btree.Btree_intf
191 |
192 | (** result of B-tree make; NOTE that B.disk_ops contains the dnode
193 | marshalling code, and that this is an argument to most of the
194 | constructor functions in Tjr_btree.Make *)
195 | module type BT2 = sig
196 | include BT1
197 | type leaf
198 | type node
199 | type leaf_stream
200 | type dnode = (node,leaf)I.dnode
201 | val leaf_ops: (k,v,leaf)I.leaf_ops
202 | val node_ops: (k,r,node)I.node_ops
203 | type disk_ops = (r,t,dnode,blk) B.disk_ops
204 | type store_ops = (r,dnode,t) I.store_ops
205 | type pre_btree_ops = (k,v,r,t,leaf,node,leaf_stream) I.pre_btree_ops
206 | val make_something: disk_ops -> unit
207 | end
208 |
209 |
210 |
211 | (** {2 Older version} *)
212 |
213 |
214 | (** These types are common to almost all the components (well, perhaps
215 | the root manager deals with blks rather than kvrt) *)
216 | module type KVRT = sig
217 | type k
218 | type v
219 | type r
220 | type blk_id = r
221 |
222 | type t
223 |
224 | (** Once the [t] monad type is fixed, the mutex and cvar types are usually also fixed *)
225 | type mutex
226 | type cvar
227 |
228 | (** The type of the monadic yield *)
229 | type yield_t
230 |
231 | (** The type of the monadic sleep *)
232 | type sleep_t
233 | end
234 |
235 | (** The following module is for system architecture documentation purposes *)
236 | module Ctxt(Pre:KVRT) = struct
237 | open Memq_intf
238 | include Pre
239 |
240 | module type LRU_DMAP = sig
241 | type msg1 = (k,v,t) Msg_lru_dmap.lru_dmap_msg
242 | type q1 = (mutex,cvar,msg1) queue
243 | val q_lru_dmap_ops : (msg1,q1,t) memq_ops
244 | end
245 |
246 |
247 | (** The main types and values in scope at the Lru layer *)
248 | module type LRU = sig
249 | open Syncable_map
250 | type lru_ops = (k,v,r,t) syncable_map_with_pmode
251 | val lru_ops: lru_ops
252 |
253 | end
254 |
255 |
256 | module type DMAP_BTREE = sig
257 | type msg2 = (k,v,blk_id,t) Msg_dmap_bt.dmap_bt_msg
258 | type q2 = (mutex,cvar,msg2) queue
259 | val q_dmag_bt_ops : (msg2,q2,t) memq_ops
260 | end
261 |
262 | (** The main types and values in scope at the detachable map *)
263 | module type DMAP = sig
264 | (** NOTE this thread "never" terminates; it takes msgs from the
265 | lru->dmap queue, and applies them to the log; occasionally the
266 | log is detached and the result is put on the dmap->btree queue
267 | *)
268 | val dmap_thread: yield:yield_t -> sleep:sleep_t -> unit -> ('a,t)m
269 | end
270 |
271 | module type BTREE_ROOTMAN = sig
272 | open Msg_btree_rootman
273 | type msg3 = blk_id msg_btree_rootman
274 | end
275 |
276 | module type BTREE = sig
277 | (** This thread takes items of dmap->btree, and executes against the btree *)
278 | val btree_thread: yield:yield_t -> sleep:sleep_t -> unit -> ('a,t)m
279 | end
280 |
281 | module type ROOTMAN = sig
282 | val rootman_thread: yield:yield_t -> sleep:sleep_t -> unit -> ('a,t)m
283 | end
284 | end
285 |
286 |
287 | (** Documentation of the various state types of the components *)
288 | module States(Pre:KVRT) = struct
289 | include Pre
290 |
291 | module type LRU = sig
292 | type k_map
293 | type t_map
294 | type nonrec lru_state = (k,v,k_map,t_map,t) Mt_state_type.mt_state
295 | end
296 |
297 | module With_blk_id(Blk_id:sig type blk_id = r end) = struct
298 | open Blk_id
299 |
300 | module type DMAP = sig
301 | open Dmap_types
302 | open Dcl_types
303 |
304 | (** NOTE typically the internal state is the same for pl and pcl,
305 | and is a buffer and an int *)
306 | type pl_and_pcl_internal_state
307 |
308 | type kvop_map
309 |
310 | (** dcl_state is start_block, current_block etc *)
311 | type nonrec dcl_state = (r,kvop_map) dcl_state
312 | type nonrec detach_info = (k,v,r) detach_info
313 | type nonrec dmap_ops = (k,v,r,t) dmap_ops
314 |
315 | type dmap_state = pl_and_pcl_internal_state * dcl_state
316 | end
317 |
318 |
319 | module type BTREE = sig
320 | (** These fixed types are placeholders *)
321 | type t1
322 | type t2
323 |
324 | (** NOTE: our examples use a file descriptor as a reference to the "block device" *)
325 | type fd
326 |
327 | (** This is the state held in memory while the B-tree executes *)
328 | type btree_state = {
329 | blk_allocator_state:t1;
330 | fstore_state:t2;
331 | btree_root_blk:blk_id;
332 | blk_dev:fd
333 | }
334 | end
335 |
336 |
337 | module type ROOTMAN = sig
338 | type fd
339 | (** This is the state held in memory and presumably mirrored
340 | somewhere on disk (at least, for the roots) eg in block 0 *)
341 | type rootman_state = {
342 | blk_dev:fd;
343 | dmap_root:blk_id;
344 | btree_root:blk_id;
345 | }
346 | end
347 |
348 | (** NOTE The system state is composed of the above, plus the
349 | contents of the queues, plus the contents of the caches (eg the
350 | store cache) *)
351 | end
352 | end
353 |
354 |
355 |
356 |
357 |
358 |
359 |
--------------------------------------------------------------------------------
/src/_old/kv_intf_v2.ml_:
--------------------------------------------------------------------------------
1 | (** Interfaces based on classes *)
2 |
3 | open Kv_intf
4 | open Std_types
5 |
6 |
7 |
8 | (** {2 Pcache} *)
9 |
10 |
--------------------------------------------------------------------------------
/src/_old/kv_intf_v3.ml_:
--------------------------------------------------------------------------------
1 | (** Interfaces based on a single "store" object with mutable refs.
2 |
3 |
4 | NOTE the class types are not rendered well with odoc.
5 |
6 | {[
7 | ]}
8 |
9 | *)
10 |
11 | [@@@ warning "-33"]
12 | open Tjr_monad.With_lwt
13 | open Std_types
14 |
15 | module Util = struct
16 | class virtual ['a] mrshlr = object
17 | method virtual to_blk: 'a -> blk
18 | method virtual of_blk: blk -> 'a
19 | end
20 |
21 | class virtual ['a] set_once = object
22 | method virtual set: 'a -> unit
23 | method virtual get: unit -> 'a
24 | method virtual is_set: bool
25 | end
26 |
27 | class virtual ['a] mutable_ = object
28 | method virtual set: 'a -> unit
29 | method virtual get: unit -> 'a
30 | method virtual is_set: bool
31 | end
32 |
33 |
34 | (*
35 | (** This is a container for a type 'a that can be stored in a single
36 | block. The initialized method checks that all the state parts of
37 | a component are initialized; use with assert *)
38 | class virtual ['a] on_disk_block = object
39 | (* val blk_dev_ops : (blk_id,blk,t)blk_dev_ops *)
40 | val virtual blk_id : blk_id
41 | val virtual contents : 'a mutable_
42 | val virtual marshaller : 'a mrshlr
43 | method virtual sync_to_disk : unit -> (unit,t)m
44 | method virtual sync_from_disk : unit -> (unit,t)m
45 | (* method virtual is_initialized : bool *)
46 | end
47 | *)
48 |
49 | end
50 | open Util
51 |
52 | module Pvt_class_types = struct
53 |
54 | class virtual ['fl] freelist = object
55 | (* inherit ['fl] on_disk_block *)
56 | method virtual blk_allocator: (r,t)blk_allocator_ops
57 | method virtual sync_to_disk: unit -> (unit,t)m
58 | end
59 |
60 | class virtual ['fl] freelist_factory = object
61 | method virtual make_from_disk:
62 | blk_dev_ops:(blk_id,blk,t)blk_dev_ops ->
63 | blk_id:blk_id ->
64 | 'fl freelist
65 | end
66 |
67 | type t1 = {
68 | mutable bt_rt:blk_id;
69 | mutable pc_hd:blk_id;
70 | mutable pc_tl:blk_id
71 | }[@@deriving bin_io]
72 |
73 | class virtual root_man = object
74 | val virtual roots: t1
75 | method virtual sync_to_disk: unit -> (unit,t)m
76 | end
77 |
78 | class virtual btree_cache = object
79 | (* method virtual blk_dev_ops : (blk_id,blk,t)blk_dev_ops set_once *)
80 |
81 | (** Flush the write back cache, after merging a prefix of the pcache *)
82 | method virtual flush_cache : unit -> (unit,t)m
83 | end
84 |
85 | (* we expect that, once setup, the threads run forever; other
86 | applications may need to shutdown threads instead. *)
87 | class virtual ['k,'v] btree = object
88 | val mutable virtual blk_id : blk_id (* root of the btree *)
89 | method virtual thread : < start_thread: unit -> (unit,t)m >
90 | method virtual btree_ops : unit -> ('k,'v,blk_id,t) Kv_intf.Btree_ops.btree_ops
91 | (* method virtual blk_dev_ops : (blk_id,blk,t)blk_dev_ops set_once *)
92 | (* method virtual get_cache : btree_cache *)
93 | (* method virtual is_initialized : bool *)
94 | end
95 | (** The B-tree needs to track the root blk_id only; to create a
96 | B-tree we need to write an empty leaf to disk *)
97 |
98 | class virtual ['k,'v] btree_factory = object
99 | method virtual read_from_disk: blk_id -> ('k,'v)btree
100 | method virtual make_empty: blk_id -> ('k,'v)btree
101 | end
102 |
103 | class virtual ['kvop_map] pcache = object
104 | val mutable virtual pcache_state : (r,'kvop_map) Tjr_pcache.Pcache_state.pcache_state
105 | method virtual thread : < start_thread: unit -> (unit,t)m >
106 | method virtual sync_to_disk : unit -> (unit,t)m
107 | method virtual sync_from_disk : hd:blk_id -> tl:blk_id -> (unit,t)m
108 | (* method is_initialized : bool *)
109 | (* method blk_dev_ops : (blk_id,blk,t)blk_dev_ops set_once *)
110 | end
111 |
112 | class virtual ['kvop_map] pcache_factory = object
113 |
114 | end
115 |
116 |
117 | class virtual ['k,'v,'mt_state] lru = object
118 | val mutable virtual lru_state: 'mt_state
119 | method virtual lru_ops: unit -> ('k,'v,t)mt_ops
120 | end
121 |
122 | (** A collection of all the components *)
123 | class virtual ['k,'v,'fl,'kvop_map,'mt_state] kv_store = object
124 | method virtual blk_dev_ops : (blk_id,blk,t)blk_dev_ops set_once
125 | method virtual root_man : root_man
126 | method virtual freelist : 'fl freelist
127 | method virtual btree_cache : btree_cache
128 | method virtual btree : ('k,'v) btree
129 | method virtual q_pc_bt : ('k,'v) Kv_intf_v2.q_pc_bt
130 | method virtual pcache : 'kvop_map pcache
131 | method virtual q_lru_pc : ('k,'v) Kv_intf_v2.q_lru_pc
132 | method virtual lru : ('k,'v,'mt_state) lru
133 |
134 | (** Checks all components are initialized *)
135 | method virtual is_initialized : bool
136 | end
137 |
138 | end
139 |
140 | module Classes = struct
141 |
142 | module P = Pvt_class_types
143 |
144 | (** {2 Generic syncable object} *)
145 |
146 | (* Convert a type with binprot to a marshaller *)
147 | module Make_mrshlr(S:sig type tt[@@deriving bin_io] end) = struct
148 | open S
149 |
150 | let to_blk (x:tt) =
151 | let buf = buf_create () in
152 | let _ : int = bin_write_tt buf ~pos:0 x in
153 | buf
154 |
155 | let of_blk blk =
156 | bin_read_tt blk ~pos_ref:(ref 0)
157 |
158 | let mrshlr : tt P.mrshlr = object
159 | method to_blk = to_blk
160 | method of_blk = of_blk
161 | end
162 |
163 | end
164 |
165 | class ['a] mutable_ = object
166 | val mutable the_ref = (Obj.magic () : 'a)
167 | val mutable is_set : bool = false
168 | method set x = the_ref <- x
169 | method get =
170 | assert(is_set);
171 | the_ref
172 | method is_set = is_set
173 | end
174 |
175 | class ['a] set_once = object (self:'self)
176 | inherit ['a] mutable_
177 | method! set x =
178 | assert(not(is_set));
179 | the_ref <- x
180 | end
181 |
182 | class ['a] on_disk_block = object (self:'self)
183 | val blk_dev_ops = (new set_once:(blk_id,blk,t)blk_dev_ops set_once)
184 | val blk_id = (new set_once:blk_id set_once)
185 | val contents = (new mutable_ : 'a mutable_)
186 | val marshaller = (new set_once:'a P.mrshlr set_once)
187 | method sync_to_disk () =
188 | blk_dev_ops#get.write ~blk_id:(blk_id#get) ~blk:(marshaller#get#to_blk contents#get)
189 | method sync_from_disk () =
190 | blk_dev_ops#get.read ~blk_id:(blk_id#get) >>= fun blk ->
191 | contents#set (marshaller#get#of_blk blk); return ()
192 | method is_initialized = blk_dev_ops#is_set && blk_id#is_set && contents#is_set
193 | end
194 |
195 | (* FIXME how to check that this class definition satisfies the class type definition? *)
196 | let f (x:'a on_disk_block) : 'a P.on_disk_block = x
197 |
198 |
199 | (*
200 | (** {2 Freelist} *)
201 |
202 | module Freelist = struct
203 |
204 | type x = { mutable min_free_blk_id:blk_id }[@@deriving bin_io]
205 |
206 | class freelist = object
207 | inherit [x] syncable
208 |
209 | val pvt_blk_allocator : (r,t)blk_allocator_ops set_once = new set_once
210 |
211 | method get_blk_allocator () =
212 | match pvt_blk_allocator#is_set () with
213 | | true -> pvt_blk_allocator#get
214 | | false ->
215 | rt#get |> fun rb ->
216 | let blk_alloc () =
217 | let min = rb.min_free_blk_id in
218 | rb.min_free_blk_id <- B.inc rb.min_free_blk_id;
219 | return min
220 | in
221 | let blk_free blk_id = return () in
222 | { blk_alloc; blk_free }
223 |
224 | initializer
225 | let module M = Make_mrshlr(struct type tt = x[@@deriving bin_io] end) in
226 | marshaller#set M.mrshlr
227 | end
228 | end
229 | class freelist = Freelist.freelist
230 |
231 |
232 |
233 | (** {2 Root manager, for B-tree and pcache roots} *)
234 |
235 | module Root_man = struct
236 |
237 | type x = {
238 | mutable bt_rt:blk_id;
239 | mutable pc_hd:blk_id;
240 | mutable pc_tl:blk_id
241 | }[@@deriving bin_io]
242 |
243 | class root_man = object
244 | val sync_ops : x syncable = new syncable
245 | method get_sync_ops = sync_ops
246 |
247 | initializer
248 | let module M = Make_mrshlr(struct type tt = x[@@deriving bin_io] end) in
249 | sync_ops#set_marshaller M.mrshlr
250 | end
251 |
252 | end
253 | class root_man = Root_man.root_man
254 |
255 |
256 | (** {2 B-tree} *)
257 |
258 | module Btree = struct
259 |
260 | class btree = object (self)
261 | method f = self#get_blk_dev_ops |> fun (x:int) -> x
262 |
263 | end
264 |
265 |
266 | (** {2 The kv store, as a collection of components} *)
267 |
268 | module Kv_store = struct
269 | open Kv_intf_v2
270 | class ['k,'v] kv_store = object
271 | val root_man = new root_man
272 | val btree = ()
273 | val q_pc_bt : ('k,'v) q_pc_bt = failwith ""
274 | val pc = ()
275 | val q_lru_pc : ('k,'v)q_lru_pc = failwith ""
276 | method set_blk_dev_ops x =
277 | root_man#get_sync_ops#set_blk_dev_ops x;
278 | (* btree#set_blk_dev_ops x; *)
279 | ()
280 |
281 | end
282 | end
283 |
284 | *)
285 |
286 | end
287 |
288 | include Classes
289 |
290 |
291 | (*
292 |
293 |
294 | class type ['k, 'v, 'kvop_map, 'fl] store = object
295 |
296 | method set_blk_dev_ops: std_blk_dev_ops -> unit
297 |
298 | method set_rt_blk_id : blk_id -> unit
299 |
300 | (* This doesn't sync to disk *)
301 | method set_rt_blk: rt_blk -> unit
302 |
303 | method sync_rt_blk_from_disk: unit -> (unit,t)m
304 |
305 | method sync_rt_blk_to_disk: unit -> (unit,t)m
306 | (* method write_rt_blk: rt_blk -> (unit,t)m *)
307 |
308 |
309 | (* this also contains the blk allocator *)
310 | method set_freelist: 'fl freelist -> unit
311 |
312 |
313 |
314 | (* this starts the btree thread *)
315 | method boot_btree: unit -> (unit,t)m
316 |
317 | method get_btree: unit -> ('k,'v,r,t) Kv_intf.Btree_ops.btree_ops
318 |
319 | method get_btree_cache: unit (* FIXME *)
320 |
321 |
322 | method boot_pcache: unit -> (unit,t)m
323 |
324 | method get_pcache: unit -> (r,'kvop_map)Pcache_state.pcache_state
325 |
326 |
327 | (* method boot_lru: unit -> (unit,t)m *)
328 |
329 | method get_lru: unit -> ('k,'v,t)mt_ops
330 | (* and various kinds of marshallers? empty_leaf as blk? *)
331 | end
332 |
333 |
334 | *)
335 |
--------------------------------------------------------------------------------
/src/_old/kv_store_v3.ml_:
--------------------------------------------------------------------------------
1 | (** Version using {!Kv_intf_v3} interfaces *)
2 |
3 | (* NOTE this code is mostly copied from kv_store_with_lru *)
4 | [@@@warning "-33"]
5 |
6 | open Tjr_monad.With_lwt
7 | open Lwt_aux (* provides various msg queues *)
8 | open Std_types
9 | open Kv_intf
10 | open Kv_intf_v3
11 |
12 |
13 | module type S = Kv_store_with_lru.S
14 |
15 | (*
16 | module Make(S:S) = struct
17 | open S
18 |
19 |
20 | (** {2 Message queues} *)
21 |
22 | let q_lru_pc : (k,v) Kv_intf_v2.q_lru_pc = Tjr_mem_queue.With_lwt.make_as_object ()
23 | let q_pc_bt : (k,v) Kv_intf_v2.q_pc_bt = Tjr_mem_queue.With_lwt.make_as_object ()
24 |
25 |
26 | (** {2 Blk_dev_ops ref} *)
27 |
28 | let blk_dev_ops_ref: (blk_id,blk,t) blk_dev_ops option ref = ref None
29 |
30 | let set_blk_dev_ops blk_dev_ops = blk_dev_ops_ref := Some blk_dev_ops
31 |
32 | let get_blk_dev_ops () =
33 | assert(Option.is_some !blk_dev_ops_ref);
34 | Option.get !blk_dev_ops_ref
35 |
36 |
37 | module Make_root_blk_ops(S:sig type rb[@@deriving bin_io] end) = struct
38 | include S
39 |
40 | let write_rb ~blk_id rb =
41 | let blk_dev_ops = get_blk_dev_ops () in
42 | (* FIXME have a single buf_create, specialized to std_type and buf_sz *)
43 | let buf = buf_create () in
44 | bin_write_rb buf ~pos:0 rb |> fun _ ->
45 | blk_dev_ops.write ~blk_id ~blk:buf
46 |
47 | let read_rb: blk_id:blk_id -> (rb,t)m = fun ~blk_id ->
48 | let blk_dev_ops = get_blk_dev_ops () in
49 | blk_dev_ops.read ~blk_id >>= fun blk ->
50 | bin_read_rb blk ~pos_ref:(ref 0) |> fun rb ->
51 | return rb
52 | end
53 |
54 | module X = Make_root_blk_ops(struct type rb = rt_blk[@@deriving bin_io] end)
55 |
56 |
57 |
58 | (** {2 The root block, where roots (apart from freelist) are stored} *)
59 |
60 | let r0 = ref None
61 |
62 | let set_rt blk_id = r0:=Some blk_id
63 |
64 | let get_rt () =
65 | assert(Option.is_some !r0);
66 | Option.get !r0
67 |
68 |
69 | let rb_ref = ref None
70 |
71 | let set_rt_blk rb = rb_ref:=Some rb
72 |
73 | let get_rb () =
74 | assert(Option.is_some !rb_ref);
75 | Option.get !rb_ref
76 |
77 | let sync_rt_blk_from_disk () =
78 | get_rt () |> fun blk_id ->
79 | X.read_rb ~blk_id >>= fun rb ->
80 | rb_ref:=Some rb; return ()
81 |
82 | let sync_rt_blk_to_disk () =
83 | get_rt () |> fun blk_id ->
84 | X.write_rb ~blk_id (get_rb())
85 |
86 |
87 |
88 | (** {2 The freelist} *)
89 |
90 |
91 | type freelist_rt_blk = {
92 | min_free:blk_id;
93 | } [@@deriving bin_io]
94 |
95 |
96 |
97 |
98 |
99 |
100 |
101 |
102 |
103 | (** {2 Root manager} *)
104 |
105 | let roots : rt_blk option ref = ref None
106 | let root_man : (rt_blk,t) Root_man_ops.root_man Lazy.t = lazy (
107 | assert(Option.is_some !roots);
108 | Root_manager.make_root_man ~monad_ops ~blk_ops ~blk_dev_ops:(Lazy.force blk_dev_ops))
109 |
110 |
111 | (** {2 Blk allocator} *)
112 |
113 | let blk_alloc : (r,t) blk_allocator_ops Lazy.t = lazy (
114 | let blk_alloc () =
115 | assert(Option.is_some !roots);
116 | !roots |> Option.get |> fun x ->
117 | roots:=Some({x with min_free=B.inc x.min_free});
118 | return x.min_free
119 | in
120 | let blk_free blk_id = return () in
121 | {blk_alloc;blk_free})
122 |
123 |
124 |
125 | (** {2 B-tree/btree ops/bt thread} *)
126 |
127 | module Btree_ = Tjr_btree_examples.Make_1.Make(struct
128 | include Std_types
129 | include S
130 | let cs = Tjr_btree_examples.Make_1.make_constants ~k_size ~v_size
131 | end)
132 |
133 | let with_bt_rt =
134 | let with_state f =
135 | assert(Option.is_some !roots);
136 | f ~state:( (!roots |> Option.get).bt_rt )
137 | ~set_state:(fun bt_rt ->
138 | !roots |> Option.get |> fun x ->
139 | {x with bt_rt} |> fun x ->
140 | roots:=Some x; return ())
141 | in
142 | { with_state }
143 |
144 | let btree_thread = lazy Btree_thread.(
145 | let blk_dev_ops = Lazy.force blk_dev_ops in
146 | let blk_alloc = Lazy.force blk_alloc in
147 | let x = Btree_.make ~blk_dev_ops ~blk_alloc ~root_ops:with_bt_rt in
148 | let module S = (val x) in (* FIXME this is supposed to be uncached *)
149 | make_btree_thread ~q_pc_bt ~map_ops:S.map_ops_with_ls)
150 |
151 |
152 | (** {2 Pcache and pcache_thread } *)
153 |
154 | let marshalling_config : (k,v,r) Pcache_intf.marshalling_config =
155 | (module S)
156 |
157 | module Pcache_ = Tjr_pcache.Make.Make(struct
158 | include Std_types
159 | include S
160 | let marshalling_config = marshalling_config
161 | end)
162 |
163 | (** NOTE don't set this directly; use set_pcache_state *)
164 | let pcache_state : Pcache_.pcache_state option ref = ref None
165 |
166 | let set_pcache_state = fun s ->
167 | pcache_state := Some s;
168 | assert(Option.is_some !roots);
169 | (* also update roots *)
170 | !roots|>Option.get|>fun x ->
171 | { x with pc_hd=s.root_ptr; pc_tl=s.current_ptr } |> fun x ->
172 | roots:=Some x;
173 | ()
174 |
175 | let with_pcache =
176 | let with_state f =
177 | assert(Option.is_some !pcache_state);
178 | f ~state:( !pcache_state |> Option.get )
179 | ~set_state:(fun s ->
180 | set_pcache_state s;
181 | return ())
182 | in
183 | { with_state }
184 |
185 | let pcache_thread = lazy Pcache_.(
186 | let pcache_ops =
187 | make_pcache_ops_with_blk_dev
188 | ~blk_dev_ops:(Lazy.force blk_dev_ops)
189 | ~blk_alloc:(Lazy.force blk_alloc).blk_alloc
190 | ~with_pcache
191 | in
192 | let config = Lazy.force runtime_config in
193 | Pcache_thread.make_pcache_thread
194 | ~kvop_map_ops
195 | ~pcache_blocks_limit:config.pcache_blocks_limit
196 | ~pcache_ops
197 | ~q_lru_pc
198 | ~q_pc_bt)
199 |
200 |
201 | (** {2 LRU cache} *)
202 |
203 | module Lru_ = Tjr_lru_cache.Make.Make(struct
204 | type k = S.k
205 | let compare = S.k_cmp
206 | type v = S.v
207 | type t = lwt
208 | let monad_ops = monad_ops
209 | let async = async
210 | let event_ops = event_ops
211 | end)
212 | type mt_state = Lru_.mt_state
213 |
214 | let lru : (k,v,_) Lru.lru =
215 | let open Lru in
216 | let args : (_,_,_) args =
217 | object
218 | method make_multithreaded_lru=Lru_.make_multithreaded_lru
219 | method q_lru_pc ()=q_lru_pc
220 | end
221 | in
222 | make_lru args
223 |
224 | let config = Lazy.force runtime_config
225 |
226 | let _ : unit = lru#set_initial_state
227 | (Lru_.init_state ~max_size:config.lru_max_size ~evict_count:config.lru_evict_count)
228 |
229 | let lru_ops = lru#get_lru_ops ()
230 |
231 |
232 | let store : (k,v,_) store =
233 | let module X = Kv_store_with_lru.Make(S) in
234 | let set_blk_dev_ops blk_dev_ops = X.blk_dev_ops:=
235 |
236 | failwith ""
237 |
238 | end
239 | *)
240 |
--------------------------------------------------------------------------------
/src/_old/tjr_kv.t.ml:
--------------------------------------------------------------------------------
1 | (** A key-value store (example instance)
2 |
3 | {2 Architecture}
4 |
5 | {%html:
6 |
7 | 
8 |
9 | 
10 |
11 | %}
12 |
13 | Simplified interface:
14 |
15 | {%html:
16 |
17 | module type KV = sig
18 | type ('a, 't) m
19 |
20 | type k
21 |
22 | type v
23 |
24 | type blk_id
25 |
26 | type ('k, 'v) kvop = Insert of 'k * 'v | Delete of 'k
27 |
28 | (* NOTE this is the LRU entry type *)
29 | type dirty = bool
30 |
31 | type 'v entry =
32 | | Insert of { value : 'v; dirty : dirty }
33 | | Delete of { dirty : dirty }
34 | | Lower of 'v option
35 |
36 | type ('k, 'v, 'blk_id, 't) btree_ops = {
37 | find : 'k -> ('v option, 't) m;
38 | insert : 'k -> 'v -> (unit, 't) m;
39 | delete : 'k -> (unit, 't) m;
40 | sync : unit -> ('blk_id, 't) m;
41 | }
42 |
43 | type ('k, 'v, 'blk_id, 't) pc_bt_msg =
44 | | Find of 'k * ('v option -> (unit, 't) m)
45 | | Detach of { ops : ('k, 'v) kvop list; new_pcache_root : 'blk_id }
46 |
47 | type ('k, 'v, 't) lru_pc_msg =
48 | | Insert of 'k * 'v * (unit -> (unit, 't) m)
49 | | Delete of 'k * (unit -> (unit, 't) m)
50 | | Find of 'k * ('v option -> (unit, 't) m)
51 | | Evictees of ('k * 'v entry) list
52 | (** NOTE this is the same as LRU msg type *)
53 |
54 | (* NOTE the interface provided by the key-value store is the same as
55 | that of the LRU component, which we reproduce here *)
56 | type persist_mode = Persist_later | Persist_now
57 |
58 | type ('k, 'v, 't) mt_ops = {
59 | mt_find : 'k -> ('v option, 't) m;
60 | mt_insert : persist_mode -> 'k -> 'v -> (unit, 't) m;
61 | mt_delete : persist_mode -> 'k -> (unit, 't) m;
62 | mt_sync_key : 'k -> (unit, 't) m;
63 | mt_sync_all_keys : unit -> (unit, 't) m;
64 | }
65 | end
66 | 