Pure OCaml B-tree implementation for persistent storage
btree: add cell, page, pager, record, table, varint modules
borealis: add example yaml configs
sqlite: update interop test
+1856
-1786
+19
-1755
lib/btree.ml
+19
-1755
lib/btree.ml
···
3
3
SPDX-License-Identifier: MIT
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(* Varint encoding - SQLite style *)
7
-
module Varint = struct
8
-
let decode buf off =
9
-
let rec loop acc shift i =
10
-
if i >= String.length buf then (acc, i - off)
11
-
else
12
-
let byte = Char.code buf.[i] in
13
-
let value = Int64.of_int (byte land 0x7f) in
14
-
let acc = Int64.logor acc (Int64.shift_left value shift) in
15
-
if byte land 0x80 = 0 then (acc, i - off + 1)
16
-
else if shift >= 56 then
17
-
(* 9th byte - use all 8 bits *)
18
-
let byte9 = Char.code buf.[i + 1] in
19
-
let acc =
20
-
Int64.logor acc (Int64.shift_left (Int64.of_int byte9) 56)
21
-
in
22
-
(acc, i - off + 2)
23
-
else loop acc (shift + 7) (i + 1)
24
-
in
25
-
loop 0L 0 off
26
-
27
-
let size n =
28
-
if n < 0L then 9
29
-
else if n < 128L then 1
30
-
else if n < 16384L then 2
31
-
else if n < 2097152L then 3
32
-
else if n < 268435456L then 4
33
-
else if n < 34359738368L then 5
34
-
else if n < 4398046511104L then 6
35
-
else if n < 562949953421312L then 7
36
-
else if n < 72057594037927936L then 8
37
-
else 9
38
-
39
-
let encode n =
40
-
let sz = size n in
41
-
let buf = Bytes.create sz in
42
-
let rec loop n i =
43
-
if i = sz - 1 then Bytes.set_uint8 buf i (Int64.to_int n land 0x7f)
44
-
else begin
45
-
Bytes.set_uint8 buf i (Int64.to_int n land 0x7f lor 0x80);
46
-
loop (Int64.shift_right_logical n 7) (i + 1)
47
-
end
48
-
in
49
-
loop n 0;
50
-
Bytes.unsafe_to_string buf
51
-
end
52
-
53
-
(* Page types *)
54
-
type page_type = Interior_index | Interior_table | Leaf_index | Leaf_table
55
-
56
-
let pp_page_type ppf = function
57
-
| Interior_index -> Format.pp_print_string ppf "interior_index"
58
-
| Interior_table -> Format.pp_print_string ppf "interior_table"
59
-
| Leaf_index -> Format.pp_print_string ppf "leaf_index"
60
-
| Leaf_table -> Format.pp_print_string ppf "leaf_table"
61
-
62
-
let page_type_of_byte = function
63
-
| 0x02 -> Interior_index
64
-
| 0x05 -> Interior_table
65
-
| 0x0a -> Leaf_index
66
-
| 0x0d -> Leaf_table
67
-
| b -> failwith (Printf.sprintf "Invalid page type: 0x%02x" b)
68
-
69
-
let byte_of_page_type = function
70
-
| Interior_index -> 0x02
71
-
| Interior_table -> 0x05
72
-
| Leaf_index -> 0x0a
73
-
| Leaf_table -> 0x0d
74
-
75
-
let page_header_size = function
76
-
| Interior_index | Interior_table -> 12
77
-
| Leaf_index | Leaf_table -> 8
78
-
79
-
let is_interior = function
80
-
| Interior_index | Interior_table -> true
81
-
| Leaf_index | Leaf_table -> false
82
-
83
-
(* Page header *)
84
-
type page_header = {
85
-
page_type : page_type;
86
-
first_freeblock : int;
87
-
cell_count : int;
88
-
cell_content_start : int;
89
-
fragmented_bytes : int;
90
-
right_child : int option;
91
-
}
92
-
93
-
let get_u16_be buf off = (Char.code buf.[off] lsl 8) lor Char.code buf.[off + 1]
94
-
95
-
let get_u32_be buf off =
96
-
(Char.code buf.[off] lsl 24)
97
-
lor (Char.code buf.[off + 1] lsl 16)
98
-
lor (Char.code buf.[off + 2] lsl 8)
99
-
lor Char.code buf.[off + 3]
100
-
101
-
let set_u16_be buf off v =
102
-
Bytes.set_uint8 buf off (v lsr 8);
103
-
Bytes.set_uint8 buf (off + 1) (v land 0xff)
104
-
105
-
let set_u32_be buf off v =
106
-
Bytes.set_uint8 buf off (v lsr 24);
107
-
Bytes.set_uint8 buf (off + 1) ((v lsr 16) land 0xff);
108
-
Bytes.set_uint8 buf (off + 2) ((v lsr 8) land 0xff);
109
-
Bytes.set_uint8 buf (off + 3) (v land 0xff)
110
-
111
-
let parse_page_header buf off =
112
-
let page_type = page_type_of_byte (Char.code buf.[off]) in
113
-
let first_freeblock = get_u16_be buf (off + 1) in
114
-
let cell_count = get_u16_be buf (off + 3) in
115
-
let cell_content_start =
116
-
let v = get_u16_be buf (off + 5) in
117
-
if v = 0 then 65536 else v
118
-
in
119
-
let fragmented_bytes = Char.code buf.[off + 7] in
120
-
let right_child =
121
-
if is_interior page_type then Some (get_u32_be buf (off + 8)) else None
122
-
in
123
-
{
124
-
page_type;
125
-
first_freeblock;
126
-
cell_count;
127
-
cell_content_start;
128
-
fragmented_bytes;
129
-
right_child;
130
-
}
131
-
132
-
(* Cells *)
133
-
module Cell = struct
134
-
type table_leaf = {
135
-
rowid : int64;
136
-
payload : string;
137
-
overflow_page : int option;
138
-
}
139
-
140
-
type table_interior = { left_child : int; rowid : int64 }
141
-
type index_leaf = { payload : string; overflow_page : int option }
142
-
143
-
type index_interior = {
144
-
left_child : int;
145
-
payload : string;
146
-
overflow_page : int option;
147
-
}
148
-
149
-
(* Calculate max payload on page - simplified *)
150
-
let max_local ~usable_size ~is_table =
151
-
if is_table then usable_size - 35 else ((usable_size - 12) * 64 / 255) - 23
152
-
153
-
let min_local ~usable_size = ((usable_size - 12) * 32 / 255) - 23
154
-
155
-
let parse_table_leaf buf off ~usable_size =
156
-
let payload_size, consumed1 = Varint.decode buf off in
157
-
let rowid, consumed2 = Varint.decode buf (off + consumed1) in
158
-
let header_len = consumed1 + consumed2 in
159
-
let payload_size = Int64.to_int payload_size in
160
-
let max_local = max_local ~usable_size ~is_table:true in
161
-
let min_local = min_local ~usable_size in
162
-
let local_size, overflow_page =
163
-
if payload_size <= max_local then (payload_size, None)
164
-
else
165
-
let k =
166
-
min_local + ((payload_size - min_local) mod (usable_size - 4))
167
-
in
168
-
let local = if k <= max_local then k else min_local in
169
-
let overflow = get_u32_be buf (off + header_len + local) in
170
-
(local, Some overflow)
171
-
in
172
-
let payload = String.sub buf (off + header_len) local_size in
173
-
let total_consumed =
174
-
header_len + local_size + if overflow_page = None then 0 else 4
175
-
in
176
-
({ rowid; payload; overflow_page }, total_consumed)
177
-
178
-
let parse_table_interior buf off =
179
-
let left_child = get_u32_be buf off in
180
-
let rowid, consumed = Varint.decode buf (off + 4) in
181
-
({ left_child; rowid }, 4 + consumed)
182
-
183
-
(* Parse index leaf cell - returns local payload and overflow pointer *)
184
-
let parse_index_leaf_raw buf off ~usable_size =
185
-
let payload_size, consumed = Varint.decode buf off in
186
-
let payload_size = Int64.to_int payload_size in
187
-
let max_local = max_local ~usable_size ~is_table:false in
188
-
let min_local = min_local ~usable_size in
189
-
let local_size, overflow_page =
190
-
if payload_size <= max_local then (payload_size, None)
191
-
else
192
-
let k =
193
-
min_local + ((payload_size - min_local) mod (usable_size - 4))
194
-
in
195
-
let local = if k <= max_local then k else min_local in
196
-
let overflow = get_u32_be buf (off + consumed + local) in
197
-
(local, Some overflow)
198
-
in
199
-
let local_payload = String.sub buf (off + consumed) local_size in
200
-
let total = consumed + local_size + if overflow_page = None then 0 else 4 in
201
-
(payload_size, local_payload, overflow_page, total)
202
-
203
-
let parse_index_leaf buf off ~usable_size =
204
-
let payload_size, local_payload, overflow_page, total =
205
-
parse_index_leaf_raw buf off ~usable_size
206
-
in
207
-
(* For now, return just the local payload - caller must handle overflow *)
208
-
ignore payload_size;
209
-
({ payload = local_payload; overflow_page }, total)
210
-
211
-
(* Parse index interior cell - returns local payload and overflow pointer *)
212
-
let parse_index_interior_raw buf off ~usable_size =
213
-
let left_child = get_u32_be buf off in
214
-
let payload_size, consumed = Varint.decode buf (off + 4) in
215
-
let payload_size = Int64.to_int payload_size in
216
-
let max_local = max_local ~usable_size ~is_table:false in
217
-
let min_local = min_local ~usable_size in
218
-
let local_size, overflow_page =
219
-
if payload_size <= max_local then (payload_size, None)
220
-
else
221
-
let k =
222
-
min_local + ((payload_size - min_local) mod (usable_size - 4))
223
-
in
224
-
let local = if k <= max_local then k else min_local in
225
-
let overflow = get_u32_be buf (off + 4 + consumed + local) in
226
-
(local, Some overflow)
227
-
in
228
-
let local_payload = String.sub buf (off + 4 + consumed) local_size in
229
-
let total =
230
-
4 + consumed + local_size + if overflow_page = None then 0 else 4
231
-
in
232
-
(left_child, payload_size, local_payload, overflow_page, total)
233
-
234
-
let parse_index_interior buf off ~usable_size =
235
-
let left_child, _payload_size, local_payload, overflow_page, total =
236
-
parse_index_interior_raw buf off ~usable_size
237
-
in
238
-
({ left_child; payload = local_payload; overflow_page }, total)
239
-
end
240
-
241
-
(* Record format *)
242
-
module Record = struct
243
-
type serial_type =
244
-
| Null
245
-
| Int8
246
-
| Int16
247
-
| Int24
248
-
| Int32
249
-
| Int48
250
-
| Int64
251
-
| Float64
252
-
| Zero
253
-
| One
254
-
| Blob of int
255
-
| Text of int
256
-
257
-
type value =
258
-
| Vnull
259
-
| Vint of int64
260
-
| Vfloat of float
261
-
| Vblob of string
262
-
| Vtext of string
263
-
264
-
let serial_type_of_int = function
265
-
| 0 -> Null
266
-
| 1 -> Int8
267
-
| 2 -> Int16
268
-
| 3 -> Int24
269
-
| 4 -> Int32
270
-
| 5 -> Int48
271
-
| 6 -> Int64
272
-
| 7 -> Float64
273
-
| 8 -> Zero
274
-
| 9 -> One
275
-
| n when n >= 12 && n mod 2 = 0 -> Blob ((n - 12) / 2)
276
-
| n when n >= 13 -> Text ((n - 13) / 2)
277
-
| n -> failwith (Printf.sprintf "Invalid serial type: %d" n)
278
-
279
-
let decode_int buf off len =
280
-
let rec loop acc i =
281
-
if i >= len then acc
282
-
else
283
-
let b = Char.code buf.[off + i] in
284
-
let acc = Int64.logor (Int64.shift_left acc 8) (Int64.of_int b) in
285
-
loop acc (i + 1)
286
-
in
287
-
(* Sign extend for negative values *)
288
-
let v = loop 0L 0 in
289
-
if len > 0 && Char.code buf.[off] land 0x80 <> 0 then
290
-
let mask = Int64.shift_left (-1L) (len * 8) in
291
-
Int64.logor v mask
292
-
else v
293
-
294
-
let decode payload =
295
-
let header_size, consumed = Varint.decode payload 0 in
296
-
let header_size = Int64.to_int header_size in
297
-
(* Parse serial types *)
298
-
let rec parse_types off acc =
299
-
if off >= header_size then List.rev acc
300
-
else
301
-
let st, consumed = Varint.decode payload off in
302
-
let st = serial_type_of_int (Int64.to_int st) in
303
-
parse_types (off + consumed) (st :: acc)
304
-
in
305
-
let types = parse_types consumed [] in
306
-
(* Parse values *)
307
-
let rec parse_values types off acc =
308
-
match types with
309
-
| [] -> List.rev acc
310
-
| st :: rest ->
311
-
let value, sz =
312
-
match st with
313
-
| Null -> (Vnull, 0)
314
-
| Zero -> (Vint 0L, 0)
315
-
| One -> (Vint 1L, 0)
316
-
| Int8 -> (Vint (decode_int payload off 1), 1)
317
-
| Int16 -> (Vint (decode_int payload off 2), 2)
318
-
| Int24 -> (Vint (decode_int payload off 3), 3)
319
-
| Int32 -> (Vint (decode_int payload off 4), 4)
320
-
| Int48 -> (Vint (decode_int payload off 6), 6)
321
-
| Int64 -> (Vint (decode_int payload off 8), 8)
322
-
| Float64 ->
323
-
let bits = decode_int payload off 8 in
324
-
(Vfloat (Int64.float_of_bits bits), 8)
325
-
| Blob n -> (Vblob (String.sub payload off n), n)
326
-
| Text n -> (Vtext (String.sub payload off n), n)
327
-
in
328
-
parse_values rest (off + sz) (value :: acc)
329
-
in
330
-
parse_values types header_size []
331
-
332
-
let serial_type_of_value = function
333
-
| Vnull -> (0, 0)
334
-
| Vint 0L -> (8, 0)
335
-
| Vint 1L -> (9, 0)
336
-
| Vint n ->
337
-
if n >= -128L && n <= 127L then (1, 1)
338
-
else if n >= -32768L && n <= 32767L then (2, 2)
339
-
else if n >= -8388608L && n <= 8388607L then (3, 3)
340
-
else if n >= -2147483648L && n <= 2147483647L then (4, 4)
341
-
else if n >= -140737488355328L && n <= 140737488355327L then (5, 6)
342
-
else (6, 8)
343
-
| Vfloat _ -> (7, 8)
344
-
| Vblob s -> (12 + (String.length s * 2), String.length s)
345
-
| Vtext s -> (13 + (String.length s * 2), String.length s)
346
-
347
-
let encode_int buf off n len =
348
-
for i = 0 to len - 1 do
349
-
let shift = (len - 1 - i) * 8 in
350
-
Bytes.set_uint8 buf (off + i)
351
-
(Int64.to_int (Int64.shift_right n shift) land 0xff)
352
-
done
353
-
354
-
let encode values =
355
-
(* Calculate header *)
356
-
let types_and_sizes = List.map serial_type_of_value values in
357
-
let header_types =
358
-
List.map (fun (st, _) -> Varint.encode (Int64.of_int st)) types_and_sizes
359
-
in
360
-
let header_body = String.concat "" header_types in
361
-
let header_size = 1 + String.length header_body in
362
-
(* header size varint + types *)
363
-
let body_size =
364
-
List.fold_left (fun acc (_, sz) -> acc + sz) 0 types_and_sizes
365
-
in
366
-
let total = header_size + body_size in
367
-
let buf = Bytes.create total in
368
-
(* Write header size *)
369
-
Bytes.set_uint8 buf 0 header_size;
370
-
(* Write serial types *)
371
-
let _ =
372
-
List.fold_left
373
-
(fun off s ->
374
-
Bytes.blit_string s 0 buf off (String.length s);
375
-
off + String.length s)
376
-
1 header_types
377
-
in
378
-
(* Write values *)
379
-
let _ =
380
-
List.fold_left2
381
-
(fun off value (_, sz) ->
382
-
(match value with
383
-
| Vnull | Vint 0L | Vint 1L -> ()
384
-
| Vint n -> encode_int buf off n sz
385
-
| Vfloat f -> encode_int buf off (Int64.bits_of_float f) 8
386
-
| Vblob s | Vtext s -> Bytes.blit_string s 0 buf off sz);
387
-
off + sz)
388
-
header_size values types_and_sizes
389
-
in
390
-
Bytes.unsafe_to_string buf
391
-
392
-
let pp_value ppf = function
393
-
| Vnull -> Format.pp_print_string ppf "NULL"
394
-
| Vint n -> Format.fprintf ppf "%Ld" n
395
-
| Vfloat f -> Format.fprintf ppf "%f" f
396
-
| Vblob s -> Format.fprintf ppf "BLOB(%d)" (String.length s)
397
-
| Vtext s -> Format.fprintf ppf "%S" s
398
-
end
399
-
400
-
(* Pager *)
401
-
module Pager = struct
402
-
type t = {
403
-
file : Eio.File.rw_ty Eio.Resource.t;
404
-
page_size : int;
405
-
mutable page_count : int;
406
-
cache : (int, string) Hashtbl.t;
407
-
dirty : (int, string) Hashtbl.t;
408
-
}
409
-
410
-
let create ~page_size file =
411
-
let stat = Eio.File.stat file in
412
-
let file_size = Optint.Int63.to_int stat.size in
413
-
let page_count = if file_size = 0 then 0 else file_size / page_size in
414
-
{
415
-
file;
416
-
page_size;
417
-
page_count;
418
-
cache = Hashtbl.create 64;
419
-
dirty = Hashtbl.create 16;
420
-
}
421
-
422
-
let page_size t = t.page_size
423
-
let page_count t = t.page_count
424
-
425
-
let read t page_num =
426
-
if page_num < 1 || page_num > t.page_count then
427
-
failwith (Printf.sprintf "Invalid page number: %d" page_num);
428
-
match Hashtbl.find_opt t.dirty page_num with
429
-
| Some data -> data
430
-
| None -> (
431
-
match Hashtbl.find_opt t.cache page_num with
432
-
| Some data -> data
433
-
| None ->
434
-
let offset = Optint.Int63.of_int ((page_num - 1) * t.page_size) in
435
-
let buf = Cstruct.create t.page_size in
436
-
Eio.File.pread_exact t.file ~file_offset:offset [ buf ];
437
-
let data = Cstruct.to_string buf in
438
-
Hashtbl.replace t.cache page_num data;
439
-
data)
440
-
441
-
let write t page_num data =
442
-
if String.length data <> t.page_size then failwith "Invalid page size";
443
-
Hashtbl.replace t.dirty page_num data;
444
-
Hashtbl.replace t.cache page_num data
445
-
446
-
let allocate t =
447
-
t.page_count <- t.page_count + 1;
448
-
let data = String.make t.page_size '\x00' in
449
-
Hashtbl.replace t.dirty t.page_count data;
450
-
Hashtbl.replace t.cache t.page_count data;
451
-
t.page_count
452
-
453
-
let sync t =
454
-
Hashtbl.iter
455
-
(fun page_num data ->
456
-
let offset = Optint.Int63.of_int ((page_num - 1) * t.page_size) in
457
-
let buf = Cstruct.of_string data in
458
-
Eio.File.pwrite_all t.file ~file_offset:offset [ buf ])
459
-
t.dirty;
460
-
Hashtbl.clear t.dirty
461
-
end
462
-
463
-
(* Table B-tree *)
464
-
module Table = struct
465
-
type t = { pager : Pager.t; mutable root_page : int }
466
-
467
-
(* Initialize a page as empty leaf or interior *)
468
-
let init_page ~page_size ~page_type =
469
-
let buf = Bytes.create page_size in
470
-
Bytes.set_uint8 buf 0 (byte_of_page_type page_type);
471
-
set_u16_be buf 1 0;
472
-
(* first freeblock *)
473
-
set_u16_be buf 3 0;
474
-
(* cell count *)
475
-
set_u16_be buf 5 page_size;
476
-
(* cell content start *)
477
-
Bytes.set_uint8 buf 7 0;
478
-
(* fragmented bytes *)
479
-
if is_interior page_type then set_u32_be buf 8 0;
480
-
(* right child *)
481
-
buf
482
-
483
-
let create pager =
484
-
let root = Pager.allocate pager in
485
-
let page_size = Pager.page_size pager in
486
-
let buf = init_page ~page_size ~page_type:Leaf_table in
487
-
Pager.write pager root (Bytes.unsafe_to_string buf);
488
-
{ pager; root_page = root }
489
-
490
-
let open_ pager ~root_page = { pager; root_page }
491
-
let root_page t = t.root_page
492
-
let usable_size t = Pager.page_size t.pager
493
-
494
-
(* Find cell pointers in a page *)
495
-
let cell_pointers page header_offset header =
496
-
let ptrs = Array.make header.cell_count 0 in
497
-
let ptr_start = header_offset + page_header_size header.page_type in
498
-
for i = 0 to header.cell_count - 1 do
499
-
ptrs.(i) <- get_u16_be page (ptr_start + (i * 2))
500
-
done;
501
-
ptrs
502
-
503
-
(* Calculate free space in a page *)
504
-
let free_space header ~page_type =
505
-
let header_size = page_header_size page_type in
506
-
let ptr_area_end = header_size + (header.cell_count * 2) in
507
-
header.cell_content_start - ptr_area_end - header.fragmented_bytes
508
-
509
-
(* Encode a table leaf cell *)
510
-
let encode_table_leaf_cell ~rowid ~data =
511
-
let rowid_varint = Varint.encode rowid in
512
-
let payload_size_varint =
513
-
Varint.encode (Int64.of_int (String.length data))
514
-
in
515
-
let cell =
516
-
Bytes.create
517
-
(String.length payload_size_varint
518
-
+ String.length rowid_varint + String.length data)
519
-
in
520
-
Bytes.blit_string payload_size_varint 0 cell 0
521
-
(String.length payload_size_varint);
522
-
Bytes.blit_string rowid_varint 0 cell
523
-
(String.length payload_size_varint)
524
-
(String.length rowid_varint);
525
-
Bytes.blit_string data 0 cell
526
-
(String.length payload_size_varint + String.length rowid_varint)
527
-
(String.length data);
528
-
Bytes.unsafe_to_string cell
529
-
530
-
(* Encode a table interior cell *)
531
-
let encode_table_interior_cell ~left_child ~rowid =
532
-
let rowid_varint = Varint.encode rowid in
533
-
let cell = Bytes.create (4 + String.length rowid_varint) in
534
-
set_u32_be cell 0 left_child;
535
-
Bytes.blit_string rowid_varint 0 cell 4 (String.length rowid_varint);
536
-
Bytes.unsafe_to_string cell
537
-
538
-
(* Write a cell into a page buffer, returns new cell_content_start *)
539
-
let write_cell buf ~cell_content_start ~cell =
540
-
let cell_len = String.length cell in
541
-
let new_start = cell_content_start - cell_len in
542
-
Bytes.blit_string cell 0 buf new_start cell_len;
543
-
new_start
544
-
545
-
(* Insert a cell pointer at index, shifting others *)
546
-
let insert_cell_pointer buf ~header_offset ~page_type ~cell_count ~index ~ptr
547
-
=
548
-
let ptr_start = header_offset + page_header_size page_type in
549
-
(* Shift existing pointers right *)
550
-
for i = cell_count - 1 downto index do
551
-
let old_ptr =
552
-
get_u16_be (Bytes.unsafe_to_string buf) (ptr_start + (i * 2))
553
-
in
554
-
set_u16_be buf (ptr_start + ((i + 1) * 2)) old_ptr
555
-
done;
556
-
set_u16_be buf (ptr_start + (index * 2)) ptr
557
-
558
-
(* Binary search for rowid in leaf page *)
559
-
let search_leaf t page header rowid =
560
-
let ptrs = cell_pointers page 0 header in
561
-
let usable = usable_size t in
562
-
let rec loop lo hi =
563
-
if lo > hi then None
564
-
else
565
-
let mid = (lo + hi) / 2 in
566
-
let cell, _ =
567
-
Cell.parse_table_leaf page ptrs.(mid) ~usable_size:usable
568
-
in
569
-
if cell.rowid = rowid then Some cell.payload
570
-
else if cell.rowid < rowid then loop (mid + 1) hi
571
-
else loop lo (mid - 1)
572
-
in
573
-
loop 0 (header.cell_count - 1)
574
-
575
-
(* Find insertion index for rowid in leaf page *)
576
-
let find_insert_idx t page header rowid =
577
-
let ptrs = cell_pointers page 0 header in
578
-
let usable = usable_size t in
579
-
let rec find i =
580
-
if i >= header.cell_count then i
581
-
else
582
-
let cell, _ = Cell.parse_table_leaf page ptrs.(i) ~usable_size:usable in
583
-
if rowid < cell.rowid then i else find (i + 1)
584
-
in
585
-
find 0
586
-
587
-
(* Find child page for rowid in interior page.
588
-
SQLite B-tree: keys < separator go left, keys >= separator go right. *)
589
-
let find_child _t page header rowid =
590
-
let ptrs = cell_pointers page 0 header in
591
-
let rec loop i =
592
-
if i >= header.cell_count then Option.get header.right_child
593
-
else
594
-
let cell, _ = Cell.parse_table_interior page ptrs.(i) in
595
-
if rowid < cell.rowid then cell.left_child else loop (i + 1)
596
-
in
597
-
loop 0
598
-
599
-
(* Find child index for rowid in interior page *)
600
-
let find_child_idx page header rowid =
601
-
let ptrs = cell_pointers page 0 header in
602
-
let rec loop i =
603
-
if i >= header.cell_count then i (* right child *)
604
-
else
605
-
let cell, _ = Cell.parse_table_interior page ptrs.(i) in
606
-
if rowid < cell.rowid then i else loop (i + 1)
607
-
in
608
-
loop 0
609
-
610
-
let rec find_in_page t page_num rowid =
611
-
let page = Pager.read t.pager page_num in
612
-
let header = parse_page_header page 0 in
613
-
match header.page_type with
614
-
| Leaf_table -> search_leaf t page header rowid
615
-
| Interior_table ->
616
-
let child = find_child t page header rowid in
617
-
find_in_page t child rowid
618
-
| _ -> failwith "Invalid page type in table B-tree"
619
-
620
-
let find t rowid = find_in_page t t.root_page rowid
621
-
622
-
(* Split result: new page number and separator rowid *)
623
-
type split_result = { new_page : int; separator_rowid : int64 }
624
-
625
-
(* Split a leaf page, returns info about the new page *)
626
-
let split_leaf t page_num =
627
-
let page = Pager.read t.pager page_num in
628
-
let header = parse_page_header page 0 in
629
-
let ptrs = cell_pointers page 0 header in
630
-
let usable = usable_size t in
631
-
let page_size = Pager.page_size t.pager in
632
-
633
-
(* Find split point (middle) *)
634
-
let split_idx = header.cell_count / 2 in
635
-
636
-
(* Get separator rowid (first key that goes to right page) *)
637
-
let sep_cell, _ =
638
-
Cell.parse_table_leaf page ptrs.(split_idx) ~usable_size:usable
639
-
in
640
-
let separator_rowid = sep_cell.rowid in
641
-
642
-
(* Create new right page *)
643
-
let new_page_num = Pager.allocate t.pager in
644
-
let new_buf = init_page ~page_size ~page_type:Leaf_table in
645
-
646
-
(* Copy cells [split_idx..cell_count-1] to new page *)
647
-
let new_cell_content_start = ref page_size in
648
-
for i = split_idx to header.cell_count - 1 do
649
-
let cell_off = ptrs.(i) in
650
-
let cell, cell_len =
651
-
Cell.parse_table_leaf page cell_off ~usable_size:usable
652
-
in
653
-
let cell_data =
654
-
encode_table_leaf_cell ~rowid:cell.rowid ~data:cell.payload
655
-
in
656
-
new_cell_content_start :=
657
-
write_cell new_buf ~cell_content_start:!new_cell_content_start
658
-
~cell:cell_data;
659
-
let new_idx = i - split_idx in
660
-
let ptr_off = page_header_size Leaf_table + (new_idx * 2) in
661
-
set_u16_be new_buf ptr_off !new_cell_content_start;
662
-
ignore cell_len
663
-
done;
664
-
let new_cell_count = header.cell_count - split_idx in
665
-
set_u16_be new_buf 3 new_cell_count;
666
-
set_u16_be new_buf 5 !new_cell_content_start;
667
-
Pager.write t.pager new_page_num (Bytes.unsafe_to_string new_buf);
668
-
669
-
(* Update original page to only have cells [0..split_idx-1] *)
670
-
let old_buf = Bytes.of_string page in
671
-
set_u16_be old_buf 3 split_idx;
672
-
(* Recalculate cell content start for remaining cells *)
673
-
if split_idx > 0 then begin
674
-
let min_ptr = ref page_size in
675
-
for i = 0 to split_idx - 1 do
676
-
if ptrs.(i) < !min_ptr then min_ptr := ptrs.(i)
677
-
done;
678
-
set_u16_be old_buf 5 !min_ptr
679
-
end
680
-
else set_u16_be old_buf 5 page_size;
681
-
Pager.write t.pager page_num (Bytes.unsafe_to_string old_buf);
682
-
683
-
{ new_page = new_page_num; separator_rowid }
684
-
685
-
(* Split an interior page *)
686
-
let split_interior t page_num =
687
-
let page = Pager.read t.pager page_num in
688
-
let header = parse_page_header page 0 in
689
-
let ptrs = cell_pointers page 0 header in
690
-
let page_size = Pager.page_size t.pager in
691
-
692
-
(* Split point - middle cell becomes separator, doesn't go to either page *)
693
-
let split_idx = header.cell_count / 2 in
694
-
let sep_cell, _ = Cell.parse_table_interior page ptrs.(split_idx) in
695
-
let separator_rowid = sep_cell.rowid in
696
-
697
-
(* Create new right page *)
698
-
let new_page_num = Pager.allocate t.pager in
699
-
let new_buf = init_page ~page_size ~page_type:Interior_table in
700
-
701
-
(* The right child of split cell becomes the left-most child of new page *)
702
-
(* Cells [split_idx+1..cell_count-1] go to new page *)
703
-
let new_cell_content_start = ref page_size in
704
-
for i = split_idx + 1 to header.cell_count - 1 do
705
-
let cell_off = ptrs.(i) in
706
-
let cell, _ = Cell.parse_table_interior page cell_off in
707
-
let cell_data =
708
-
encode_table_interior_cell ~left_child:cell.left_child ~rowid:cell.rowid
709
-
in
710
-
new_cell_content_start :=
711
-
write_cell new_buf ~cell_content_start:!new_cell_content_start
712
-
~cell:cell_data;
713
-
let new_idx = i - split_idx - 1 in
714
-
let ptr_off = page_header_size Interior_table + (new_idx * 2) in
715
-
set_u16_be new_buf ptr_off !new_cell_content_start
716
-
done;
717
-
let new_cell_count = header.cell_count - split_idx - 1 in
718
-
set_u16_be new_buf 3 new_cell_count;
719
-
set_u16_be new_buf 5 !new_cell_content_start;
720
-
(* Right child of new page is same as original *)
721
-
set_u32_be new_buf 8 (Option.get header.right_child);
722
-
Pager.write t.pager new_page_num (Bytes.unsafe_to_string new_buf);
723
-
724
-
(* Update original page: keep cells [0..split_idx-1], right child = sep_cell.left_child *)
725
-
let old_buf = Bytes.of_string page in
726
-
set_u16_be old_buf 3 split_idx;
727
-
set_u32_be old_buf 8 sep_cell.left_child;
728
-
if split_idx > 0 then begin
729
-
let min_ptr = ref page_size in
730
-
for i = 0 to split_idx - 1 do
731
-
if ptrs.(i) < !min_ptr then min_ptr := ptrs.(i)
732
-
done;
733
-
set_u16_be old_buf 5 !min_ptr
734
-
end
735
-
else set_u16_be old_buf 5 page_size;
736
-
Pager.write t.pager page_num (Bytes.unsafe_to_string old_buf);
737
-
738
-
{ new_page = new_page_num; separator_rowid }
739
-
740
-
(* Insert a separator into an interior page, potentially splitting *)
741
-
let rec insert_into_interior t page_num ~left_child ~separator_rowid
742
-
~right_child =
743
-
let page = Pager.read t.pager page_num in
744
-
let header = parse_page_header page 0 in
745
-
let cell = encode_table_interior_cell ~left_child ~rowid:separator_rowid in
746
-
let cell_len = String.length cell in
747
-
let space_needed = cell_len + 2 in
748
-
(* cell + pointer *)
749
-
750
-
if free_space header ~page_type:Interior_table >= space_needed then begin
751
-
(* Fits - insert directly *)
752
-
let buf = Bytes.of_string page in
753
-
let ptrs = cell_pointers page 0 header in
754
-
755
-
(* Find insert position *)
756
-
let insert_idx =
757
-
let rec find i =
758
-
if i >= header.cell_count then i
759
-
else
760
-
let c, _ = Cell.parse_table_interior page ptrs.(i) in
761
-
if separator_rowid < c.rowid then i else find (i + 1)
762
-
in
763
-
find 0
764
-
in
765
-
766
-
(* Write cell *)
767
-
let cell_start =
768
-
write_cell buf ~cell_content_start:header.cell_content_start ~cell
769
-
in
770
-
set_u16_be buf 5 cell_start;
771
-
772
-
(* Insert pointer *)
773
-
insert_cell_pointer buf ~header_offset:0 ~page_type:Interior_table
774
-
~cell_count:header.cell_count ~index:insert_idx ~ptr:cell_start;
775
-
776
-
(* Update cell count *)
777
-
set_u16_be buf 3 (header.cell_count + 1);
778
-
779
-
(* Update child pointers: the cell we displaced (now at insert_idx+1)
780
-
needs its left_child updated to right_child, OR if we inserted at end,
781
-
update the page's right_child. *)
782
-
if insert_idx < header.cell_count then begin
783
-
(* Update the displaced cell's left_child to right_child *)
784
-
let ptr_start = page_header_size Interior_table in
785
-
let displaced_ptr =
786
-
get_u16_be
787
-
(Bytes.unsafe_to_string buf)
788
-
(ptr_start + ((insert_idx + 1) * 2))
789
-
in
790
-
set_u32_be buf displaced_ptr right_child
791
-
end
792
-
else set_u32_be buf 8 right_child;
793
-
794
-
Pager.write t.pager page_num (Bytes.unsafe_to_string buf);
795
-
None
796
-
end
797
-
else begin
798
-
(* Need to split interior page *)
799
-
let split = split_interior t page_num in
800
-
801
-
(* Determine which page gets the new separator *)
802
-
if separator_rowid < split.separator_rowid then begin
803
-
(* Insert into left (original) page *)
804
-
ignore
805
-
(insert_into_interior t page_num ~left_child ~separator_rowid
806
-
~right_child)
807
-
end
808
-
else begin
809
-
(* Insert into right (new) page *)
810
-
ignore
811
-
(insert_into_interior t split.new_page ~left_child ~separator_rowid
812
-
~right_child)
813
-
end;
814
-
815
-
(* Return split info to propagate up *)
816
-
Some { split with separator_rowid = split.separator_rowid }
817
-
end
818
-
819
-
(* Insert into a leaf page, potentially splitting *)
820
-
let rec insert_into_leaf t page_num ~rowid ~data ~parent_stack =
821
-
let page = Pager.read t.pager page_num in
822
-
let header = parse_page_header page 0 in
823
-
let cell = encode_table_leaf_cell ~rowid ~data in
824
-
let cell_len = String.length cell in
825
-
let space_needed = cell_len + 2 in
826
-
(* cell + pointer *)
827
-
828
-
if free_space header ~page_type:Leaf_table >= space_needed then begin
829
-
(* Fits - insert directly *)
830
-
let buf = Bytes.of_string page in
831
-
let insert_idx = find_insert_idx t page header rowid in
832
-
833
-
(* Write cell *)
834
-
let cell_start =
835
-
write_cell buf ~cell_content_start:header.cell_content_start ~cell
836
-
in
837
-
set_u16_be buf 5 cell_start;
838
-
839
-
(* Insert pointer *)
840
-
insert_cell_pointer buf ~header_offset:0 ~page_type:Leaf_table
841
-
~cell_count:header.cell_count ~index:insert_idx ~ptr:cell_start;
842
-
843
-
(* Update cell count *)
844
-
set_u16_be buf 3 (header.cell_count + 1);
845
-
846
-
Pager.write t.pager page_num (Bytes.unsafe_to_string buf)
847
-
end
848
-
else begin
849
-
(* Need to split *)
850
-
let split = split_leaf t page_num in
851
-
852
-
(* Determine target page and insert directly (no recursion needed -
853
-
after split, both pages have ~half capacity, plenty of room) *)
854
-
let target_page =
855
-
if rowid < split.separator_rowid then page_num else split.new_page
856
-
in
857
-
let target = Pager.read t.pager target_page in
858
-
let target_header = parse_page_header target 0 in
859
-
let target_buf = Bytes.of_string target in
860
-
let insert_idx = find_insert_idx t target target_header rowid in
861
-
let cell_start =
862
-
write_cell target_buf
863
-
~cell_content_start:target_header.cell_content_start ~cell
864
-
in
865
-
set_u16_be target_buf 5 cell_start;
866
-
insert_cell_pointer target_buf ~header_offset:0 ~page_type:Leaf_table
867
-
~cell_count:target_header.cell_count ~index:insert_idx ~ptr:cell_start;
868
-
set_u16_be target_buf 3 (target_header.cell_count + 1);
869
-
Pager.write t.pager target_page (Bytes.unsafe_to_string target_buf);
870
-
871
-
(* Propagate split up *)
872
-
propagate_split t ~parent_stack ~left_page:page_num
873
-
~separator_rowid:split.separator_rowid ~right_page:split.new_page
874
-
end
875
-
876
-
and propagate_split t ~parent_stack ~left_page ~separator_rowid ~right_page =
877
-
match parent_stack with
878
-
| [] ->
879
-
(* Splitting root - create new root *)
880
-
let page_size = Pager.page_size t.pager in
881
-
let new_root = Pager.allocate t.pager in
882
-
let buf = init_page ~page_size ~page_type:Interior_table in
883
-
884
-
(* Single cell pointing to left page *)
885
-
let cell =
886
-
encode_table_interior_cell ~left_child:left_page
887
-
~rowid:separator_rowid
888
-
in
889
-
let cell_start = write_cell buf ~cell_content_start:page_size ~cell in
890
-
set_u16_be buf 5 cell_start;
891
-
set_u16_be buf (page_header_size Interior_table) cell_start;
892
-
set_u16_be buf 3 1;
893
-
set_u32_be buf 8 right_page;
894
-
895
-
Pager.write t.pager new_root (Bytes.unsafe_to_string buf);
896
-
t.root_page <- new_root
897
-
| parent_page :: rest -> (
898
-
match
899
-
insert_into_interior t parent_page ~left_child:left_page
900
-
~separator_rowid ~right_child:right_page
901
-
with
902
-
| None -> () (* Fit in parent *)
903
-
| Some split ->
904
-
(* Parent also split, propagate up *)
905
-
propagate_split t ~parent_stack:rest ~left_page:parent_page
906
-
~separator_rowid:split.separator_rowid ~right_page:split.new_page)
907
-
908
-
(* Main insert - traverses tree and handles splits *)
909
-
let insert t ~rowid data =
910
-
let rec traverse page_num parent_stack =
911
-
let page = Pager.read t.pager page_num in
912
-
let header = parse_page_header page 0 in
913
-
match header.page_type with
914
-
| Leaf_table -> insert_into_leaf t page_num ~rowid ~data ~parent_stack
915
-
| Interior_table ->
916
-
let child_idx = find_child_idx page header rowid in
917
-
let child_page =
918
-
if child_idx >= header.cell_count then Option.get header.right_child
919
-
else
920
-
let ptrs = cell_pointers page 0 header in
921
-
let cell, _ = Cell.parse_table_interior page ptrs.(child_idx) in
922
-
cell.left_child
923
-
in
924
-
traverse child_page (page_num :: parent_stack)
925
-
| _ -> failwith "Invalid page type in table B-tree"
926
-
in
927
-
traverse t.root_page []
928
-
929
-
let delete _t _rowid = failwith "Delete not yet implemented"
930
-
931
-
let iter t f =
932
-
let rec iter_page page_num =
933
-
let page = Pager.read t.pager page_num in
934
-
let header = parse_page_header page 0 in
935
-
let ptrs = cell_pointers page 0 header in
936
-
let usable = usable_size t in
937
-
match header.page_type with
938
-
| Leaf_table ->
939
-
for i = 0 to header.cell_count - 1 do
940
-
let cell, _ =
941
-
Cell.parse_table_leaf page ptrs.(i) ~usable_size:usable
942
-
in
943
-
f cell.rowid cell.payload
944
-
done
945
-
| Interior_table ->
946
-
for i = 0 to header.cell_count - 1 do
947
-
let cell, _ = Cell.parse_table_interior page ptrs.(i) in
948
-
iter_page cell.left_child
949
-
done;
950
-
Option.iter iter_page header.right_child
951
-
| _ -> failwith "Invalid page type"
952
-
in
953
-
iter_page t.root_page
954
-
955
-
let fold t ~init ~f =
956
-
let acc = ref init in
957
-
iter t (fun rowid data -> acc := f rowid data !acc);
958
-
!acc
959
-
end
960
-
961
-
(* Index B-tree *)
962
-
module Index = struct
963
-
type t = { pager : Pager.t; mutable root_page : int }
964
-
965
-
(* Initialize a page as empty leaf or interior *)
966
-
let init_page ~page_size ~page_type =
967
-
let buf = Bytes.create page_size in
968
-
Bytes.set_uint8 buf 0 (byte_of_page_type page_type);
969
-
set_u16_be buf 1 0;
970
-
(* first freeblock *)
971
-
set_u16_be buf 3 0;
972
-
(* cell count *)
973
-
set_u16_be buf 5 page_size;
974
-
(* cell content start *)
975
-
Bytes.set_uint8 buf 7 0;
976
-
(* fragmented bytes *)
977
-
if is_interior page_type then set_u32_be buf 8 0;
978
-
(* right child *)
979
-
buf
980
-
981
-
let create pager =
982
-
let root = Pager.allocate pager in
983
-
let page_size = Pager.page_size pager in
984
-
let buf = init_page ~page_size ~page_type:Leaf_index in
985
-
Pager.write pager root (Bytes.unsafe_to_string buf);
986
-
{ pager; root_page = root }
987
-
988
-
let open_ pager ~root_page = { pager; root_page }
989
-
let root_page t = t.root_page
990
-
let usable_size t = Pager.page_size t.pager
991
-
992
-
(* Overflow page handling *)
993
-
let read_overflow_chain pager first_page ~remaining_size =
994
-
let usable = Pager.page_size pager in
995
-
let overflow_content_size = usable - 4 in
996
-
let buf = Buffer.create remaining_size in
997
-
let rec read page_num remaining =
998
-
if remaining <= 0 || page_num = 0 then ()
999
-
else begin
1000
-
let page = Pager.read pager page_num in
1001
-
let next_page = get_u32_be page 0 in
1002
-
let to_read = min remaining overflow_content_size in
1003
-
Buffer.add_substring buf page 4 to_read;
1004
-
read next_page (remaining - to_read)
1005
-
end
1006
-
in
1007
-
read first_page remaining_size;
1008
-
Buffer.contents buf
1009
-
1010
-
let write_overflow_chain pager payload ~offset =
1011
-
let usable = Pager.page_size pager in
1012
-
let overflow_content_size = usable - 4 in
1013
-
let remaining = String.length payload - offset in
1014
-
if remaining <= 0 then 0
1015
-
else begin
1016
-
let first_page = ref 0 in
1017
-
let prev_page_buf = ref None in
1018
-
let prev_page_num = ref 0 in
1019
-
let pos = ref offset in
1020
-
while !pos < String.length payload do
1021
-
let page_num = Pager.allocate pager in
1022
-
if !first_page = 0 then first_page := page_num;
1023
-
(* Link previous page to this one *)
1024
-
(match !prev_page_buf with
1025
-
| Some buf ->
1026
-
set_u32_be buf 0 page_num;
1027
-
Pager.write pager !prev_page_num (Bytes.unsafe_to_string buf)
1028
-
| None -> ());
1029
-
(* Write this page *)
1030
-
let page_buf = Bytes.create usable in
1031
-
set_u32_be page_buf 0 0;
1032
-
(* Next page = 0 for now *)
1033
-
let to_write =
1034
-
min (String.length payload - !pos) overflow_content_size
1035
-
in
1036
-
Bytes.blit_string payload !pos page_buf 4 to_write;
1037
-
prev_page_buf := Some page_buf;
1038
-
prev_page_num := page_num;
1039
-
pos := !pos + to_write
1040
-
done;
1041
-
(* Write final page *)
1042
-
(match !prev_page_buf with
1043
-
| Some buf ->
1044
-
Pager.write pager !prev_page_num (Bytes.unsafe_to_string buf)
1045
-
| None -> ());
1046
-
!first_page
1047
-
end
1048
-
1049
-
(* Read full payload including overflow pages for leaf cells *)
1050
-
let read_full_payload t page off ~usable_size =
1051
-
let payload_size, local_payload, overflow_page, _consumed =
1052
-
Cell.parse_index_leaf_raw page off ~usable_size
1053
-
in
1054
-
match overflow_page with
1055
-
| None -> local_payload
1056
-
| Some first_overflow ->
1057
-
let remaining = payload_size - String.length local_payload in
1058
-
let overflow_data =
1059
-
read_overflow_chain t.pager first_overflow ~remaining_size:remaining
1060
-
in
1061
-
local_payload ^ overflow_data
1062
-
1063
-
(* Read full payload including overflow pages for interior cells *)
1064
-
let read_full_interior_payload t page off ~usable_size =
1065
-
let _left_child, payload_size, local_payload, overflow_page, _consumed =
1066
-
Cell.parse_index_interior_raw page off ~usable_size
1067
-
in
1068
-
match overflow_page with
1069
-
| None -> local_payload
1070
-
| Some first_overflow ->
1071
-
let remaining = payload_size - String.length local_payload in
1072
-
let overflow_data =
1073
-
read_overflow_chain t.pager first_overflow ~remaining_size:remaining
1074
-
in
1075
-
local_payload ^ overflow_data
1076
-
1077
-
let cell_pointers page header =
1078
-
let ptrs = Array.make header.cell_count 0 in
1079
-
let ptr_start = page_header_size header.page_type in
1080
-
for i = 0 to header.cell_count - 1 do
1081
-
ptrs.(i) <- get_u16_be page (ptr_start + (i * 2))
1082
-
done;
1083
-
ptrs
1084
-
1085
-
(* Calculate free space in a page *)
1086
-
let free_space header ~page_type =
1087
-
let header_size = page_header_size page_type in
1088
-
let ptr_area_end = header_size + (header.cell_count * 2) in
1089
-
header.cell_content_start - ptr_area_end - header.fragmented_bytes
1090
-
1091
-
(* Encode an index leaf cell - handles overflow for large payloads *)
1092
-
let encode_index_leaf_cell_with_overflow t ~payload =
1093
-
let payload_size = String.length payload in
1094
-
let usable_size = usable_size t in
1095
-
let max_local = Cell.max_local ~usable_size ~is_table:false in
1096
-
let min_local = Cell.min_local ~usable_size in
1097
-
let payload_size_varint = Varint.encode (Int64.of_int payload_size) in
1098
-
let varint_len = String.length payload_size_varint in
1099
-
if payload_size <= max_local then begin
1100
-
(* Fits entirely - no overflow needed *)
1101
-
let cell = Bytes.create (varint_len + payload_size) in
1102
-
Bytes.blit_string payload_size_varint 0 cell 0 varint_len;
1103
-
Bytes.blit_string payload 0 cell varint_len payload_size;
1104
-
Bytes.unsafe_to_string cell
1105
-
end
1106
-
else begin
1107
-
(* Need overflow pages *)
1108
-
let k = min_local + ((payload_size - min_local) mod (usable_size - 4)) in
1109
-
let local_size = if k <= max_local then k else min_local in
1110
-
(* Write overflow pages for data beyond local_size *)
1111
-
let overflow_page =
1112
-
write_overflow_chain t.pager payload ~offset:local_size
1113
-
in
1114
-
(* Create cell: varint(size) + local_payload + overflow_ptr *)
1115
-
let cell = Bytes.create (varint_len + local_size + 4) in
1116
-
Bytes.blit_string payload_size_varint 0 cell 0 varint_len;
1117
-
Bytes.blit_string payload 0 cell varint_len local_size;
1118
-
set_u32_be cell (varint_len + local_size) overflow_page;
1119
-
Bytes.unsafe_to_string cell
1120
-
end
1121
-
1122
-
(* Encode an index interior cell *)
1123
-
let encode_index_interior_cell ~left_child ~payload =
1124
-
let payload_size_varint =
1125
-
Varint.encode (Int64.of_int (String.length payload))
1126
-
in
1127
-
let cell =
1128
-
Bytes.create
1129
-
(4 + String.length payload_size_varint + String.length payload)
1130
-
in
1131
-
set_u32_be cell 0 left_child;
1132
-
Bytes.blit_string payload_size_varint 0 cell 4
1133
-
(String.length payload_size_varint);
1134
-
Bytes.blit_string payload 0 cell
1135
-
(4 + String.length payload_size_varint)
1136
-
(String.length payload);
1137
-
Bytes.unsafe_to_string cell
1138
-
1139
-
(* Write a cell into a page buffer, returns new cell_content_start *)
1140
-
let write_cell buf ~cell_content_start ~cell =
1141
-
let cell_len = String.length cell in
1142
-
let new_start = cell_content_start - cell_len in
1143
-
Bytes.blit_string cell 0 buf new_start cell_len;
1144
-
new_start
1145
-
1146
-
(* Insert a cell pointer at index, shifting others *)
1147
-
let insert_cell_pointer buf ~header_offset ~page_type ~cell_count ~index ~ptr
1148
-
=
1149
-
let ptr_start = header_offset + page_header_size page_type in
1150
-
(* Shift existing pointers right *)
1151
-
for i = cell_count - 1 downto index do
1152
-
let old_ptr =
1153
-
get_u16_be (Bytes.unsafe_to_string buf) (ptr_start + (i * 2))
1154
-
in
1155
-
set_u16_be buf (ptr_start + ((i + 1) * 2)) old_ptr
1156
-
done;
1157
-
set_u16_be buf (ptr_start + (index * 2)) ptr
1158
-
1159
-
(* Compare for btree navigation: key is strictly less than payload.
1160
-
Special case: if key is a prefix of payload, they are equal for navigation purposes
1161
-
(i.e., entries starting with key might be at or after payload's position). *)
1162
-
let key_less_than key payload =
1163
-
let key_len = String.length key in
1164
-
let payload_len = String.length payload in
1165
-
let cmp_len = min key_len payload_len in
1166
-
let cmp =
1167
-
String.compare (String.sub key 0 cmp_len) (String.sub payload 0 cmp_len)
1168
-
in
1169
-
if cmp <> 0 then cmp < 0
1170
-
else
1171
-
(* Prefixes match - if key is shorter or equal length, it's NOT strictly less *)
1172
-
false
1173
-
1174
-
let rec mem_in_page t page_num key =
1175
-
let page = Pager.read t.pager page_num in
1176
-
let header = parse_page_header page 0 in
1177
-
let ptrs = cell_pointers page header in
1178
-
let usable = usable_size t in
1179
-
match header.page_type with
1180
-
| Leaf_index ->
1181
-
let rec search lo hi =
1182
-
if lo > hi then false
1183
-
else
1184
-
let mid = (lo + hi) / 2 in
1185
-
let cell, _ =
1186
-
Cell.parse_index_leaf page ptrs.(mid) ~usable_size:usable
1187
-
in
1188
-
let cmp = String.compare key cell.payload in
1189
-
if cmp = 0 then true
1190
-
else if cmp < 0 then search lo (mid - 1)
1191
-
else search (mid + 1) hi
1192
-
in
1193
-
search 0 (header.cell_count - 1)
1194
-
| Interior_index ->
1195
-
let rec find_child i =
1196
-
if i >= header.cell_count then Option.get header.right_child
1197
-
else
1198
-
let cell, _ =
1199
-
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
1200
-
in
1201
-
if key_less_than key cell.payload then cell.left_child
1202
-
else find_child (i + 1)
1203
-
in
1204
-
mem_in_page t (find_child 0) key
1205
-
| _ -> failwith "Invalid page type in index B-tree"
1206
-
1207
-
let mem t key = mem_in_page t t.root_page key
1208
-
1209
-
(* Find exact key, returns payload *)
1210
-
let rec find_in_page t page_num key =
1211
-
let page = Pager.read t.pager page_num in
1212
-
let header = parse_page_header page 0 in
1213
-
let ptrs = cell_pointers page header in
1214
-
let usable = usable_size t in
1215
-
match header.page_type with
1216
-
| Leaf_index ->
1217
-
let rec search lo hi =
1218
-
if lo > hi then None
1219
-
else
1220
-
let mid = (lo + hi) / 2 in
1221
-
(* Read full payload including overflow *)
1222
-
let full_payload =
1223
-
read_full_payload t page ptrs.(mid) ~usable_size:usable
1224
-
in
1225
-
let cmp = String.compare key full_payload in
1226
-
if cmp = 0 then Some full_payload
1227
-
else if cmp < 0 then search lo (mid - 1)
1228
-
else search (mid + 1) hi
1229
-
in
1230
-
search 0 (header.cell_count - 1)
1231
-
| Interior_index ->
1232
-
let rec find_child_rec i =
1233
-
if i >= header.cell_count then Option.get header.right_child
1234
-
else
1235
-
(* Read full payload for interior comparison *)
1236
-
let full_payload =
1237
-
read_full_interior_payload t page ptrs.(i) ~usable_size:usable
1238
-
in
1239
-
if key_less_than key full_payload then
1240
-
let cell, _ =
1241
-
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
1242
-
in
1243
-
cell.left_child
1244
-
else find_child_rec (i + 1)
1245
-
in
1246
-
find_in_page t (find_child_rec 0) key
1247
-
| _ -> failwith "Invalid page type in index B-tree"
6
+
(** SQLite-compatible B-tree implementation.
1248
7
1249
-
let find t key = find_in_page t t.root_page key
8
+
This library provides read/write access to SQLite B-tree structures,
9
+
supporting both table B-trees (for row storage) and index B-trees (for key
10
+
storage).
1250
11
1251
-
(* Find a key in leaf page, returns (payload, index) if found *)
1252
-
let find_in_leaf t page header key =
1253
-
let ptrs = cell_pointers page header in
1254
-
let usable = usable_size t in
1255
-
let rec search lo hi =
1256
-
if lo > hi then None
1257
-
else
1258
-
let mid = (lo + hi) / 2 in
1259
-
let full_payload =
1260
-
read_full_payload t page ptrs.(mid) ~usable_size:usable
1261
-
in
1262
-
let cmp = String.compare key full_payload in
1263
-
if cmp = 0 then Some (full_payload, mid)
1264
-
else if cmp < 0 then search lo (mid - 1)
1265
-
else search (mid + 1) hi
1266
-
in
1267
-
search 0 (header.cell_count - 1)
12
+
The implementation is split into several modules:
13
+
- {!Varint}: SQLite-style variable-length integer encoding
14
+
- {!Page}: Page types, headers, and binary helpers
15
+
- {!Cell}: Cell types and parsing for all B-tree node types
16
+
- {!Record}: SQLite record format encoding/decoding
17
+
- {!Pager}: Page cache and file I/O
18
+
- {!Table}: Table B-tree for row storage (rowid -> data)
19
+
- {!Index}: Index B-tree for key storage (key sets) *)
1268
20
1269
-
(* Find insertion index for key in leaf page *)
1270
-
let find_insert_idx t page header key =
1271
-
let ptrs = cell_pointers page header in
1272
-
let usable = usable_size t in
1273
-
let rec find i =
1274
-
if i >= header.cell_count then i
1275
-
else
1276
-
let full_payload =
1277
-
read_full_payload t page ptrs.(i) ~usable_size:usable
1278
-
in
1279
-
if key < full_payload then i else find (i + 1)
1280
-
in
1281
-
find 0
1282
-
1283
-
(* Find child page for key in interior page *)
1284
-
let find_child t page header key =
1285
-
let ptrs = cell_pointers page header in
1286
-
let usable = usable_size t in
1287
-
let rec loop i =
1288
-
if i >= header.cell_count then Option.get header.right_child
1289
-
else
1290
-
let full_payload =
1291
-
read_full_interior_payload t page ptrs.(i) ~usable_size:usable
1292
-
in
1293
-
if key_less_than key full_payload then
1294
-
let cell, _ =
1295
-
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
1296
-
in
1297
-
cell.left_child
1298
-
else loop (i + 1)
1299
-
in
1300
-
loop 0
1301
-
1302
-
(* Find child index for key in interior page *)
1303
-
let find_child_idx t page header key =
1304
-
let ptrs = cell_pointers page header in
1305
-
let usable = usable_size t in
1306
-
let rec loop i =
1307
-
if i >= header.cell_count then i (* right child *)
1308
-
else
1309
-
let full_payload =
1310
-
read_full_interior_payload t page ptrs.(i) ~usable_size:usable
1311
-
in
1312
-
if key_less_than key full_payload then i else loop (i + 1)
1313
-
in
1314
-
loop 0
1315
-
1316
-
(* Split result: new page number and separator key *)
1317
-
type split_result = { new_page : int; separator_key : string }
1318
-
1319
-
(* Split a leaf page, returns info about the new page *)
1320
-
let split_leaf t page_num =
1321
-
let page = Pager.read t.pager page_num in
1322
-
let header = parse_page_header page 0 in
1323
-
let ptrs = cell_pointers page header in
1324
-
let usable = usable_size t in
1325
-
let page_size = Pager.page_size t.pager in
1326
-
1327
-
(* Find split point (middle) *)
1328
-
let split_idx = header.cell_count / 2 in
1329
-
1330
-
(* Get separator key (first key that goes to right page) - read full payload *)
1331
-
let separator_key =
1332
-
read_full_payload t page ptrs.(split_idx) ~usable_size:usable
1333
-
in
1334
-
1335
-
(* Create new right page *)
1336
-
let new_page_num = Pager.allocate t.pager in
1337
-
let new_buf = init_page ~page_size ~page_type:Leaf_index in
1338
-
1339
-
(* Copy cells [split_idx..cell_count-1] to new page *)
1340
-
let new_cell_content_start = ref page_size in
1341
-
for i = split_idx to header.cell_count - 1 do
1342
-
let cell_off = ptrs.(i) in
1343
-
(* Read full payload including from overflow pages *)
1344
-
let full_payload =
1345
-
read_full_payload t page cell_off ~usable_size:usable
1346
-
in
1347
-
(* Re-encode with overflow support *)
1348
-
let cell_data =
1349
-
encode_index_leaf_cell_with_overflow t ~payload:full_payload
1350
-
in
1351
-
new_cell_content_start :=
1352
-
write_cell new_buf ~cell_content_start:!new_cell_content_start
1353
-
~cell:cell_data;
1354
-
let new_idx = i - split_idx in
1355
-
let ptr_off = page_header_size Leaf_index + (new_idx * 2) in
1356
-
set_u16_be new_buf ptr_off !new_cell_content_start
1357
-
done;
1358
-
let new_cell_count = header.cell_count - split_idx in
1359
-
set_u16_be new_buf 3 new_cell_count;
1360
-
set_u16_be new_buf 5 !new_cell_content_start;
1361
-
Pager.write t.pager new_page_num (Bytes.unsafe_to_string new_buf);
1362
-
1363
-
(* Update original page to only have cells [0..split_idx-1] *)
1364
-
let old_buf = Bytes.of_string page in
1365
-
set_u16_be old_buf 3 split_idx;
1366
-
(* Recalculate cell content start for remaining cells *)
1367
-
if split_idx > 0 then begin
1368
-
let min_ptr = ref page_size in
1369
-
for i = 0 to split_idx - 1 do
1370
-
if ptrs.(i) < !min_ptr then min_ptr := ptrs.(i)
1371
-
done;
1372
-
set_u16_be old_buf 5 !min_ptr
1373
-
end
1374
-
else set_u16_be old_buf 5 page_size;
1375
-
Pager.write t.pager page_num (Bytes.unsafe_to_string old_buf);
1376
-
1377
-
{ new_page = new_page_num; separator_key }
1378
-
1379
-
(* Split an interior page *)
1380
-
let split_interior t page_num =
1381
-
let page = Pager.read t.pager page_num in
1382
-
let header = parse_page_header page 0 in
1383
-
let ptrs = cell_pointers page header in
1384
-
let usable = usable_size t in
1385
-
let page_size = Pager.page_size t.pager in
1386
-
1387
-
(* Split point - middle cell becomes separator, doesn't go to either page *)
1388
-
let split_idx = header.cell_count / 2 in
1389
-
let sep_cell, _ =
1390
-
Cell.parse_index_interior page ptrs.(split_idx) ~usable_size:usable
1391
-
in
1392
-
let separator_key = sep_cell.payload in
1393
-
1394
-
(* Create new right page *)
1395
-
let new_page_num = Pager.allocate t.pager in
1396
-
let new_buf = init_page ~page_size ~page_type:Interior_index in
1397
-
1398
-
(* Cells [split_idx+1..cell_count-1] go to new page *)
1399
-
let new_cell_content_start = ref page_size in
1400
-
for i = split_idx + 1 to header.cell_count - 1 do
1401
-
let cell_off = ptrs.(i) in
1402
-
let cell, _ =
1403
-
Cell.parse_index_interior page cell_off ~usable_size:usable
1404
-
in
1405
-
let cell_data =
1406
-
encode_index_interior_cell ~left_child:cell.left_child
1407
-
~payload:cell.payload
1408
-
in
1409
-
new_cell_content_start :=
1410
-
write_cell new_buf ~cell_content_start:!new_cell_content_start
1411
-
~cell:cell_data;
1412
-
let new_idx = i - split_idx - 1 in
1413
-
let ptr_off = page_header_size Interior_index + (new_idx * 2) in
1414
-
set_u16_be new_buf ptr_off !new_cell_content_start
1415
-
done;
1416
-
let new_cell_count = header.cell_count - split_idx - 1 in
1417
-
set_u16_be new_buf 3 new_cell_count;
1418
-
set_u16_be new_buf 5 !new_cell_content_start;
1419
-
(* Right child of new page is same as original *)
1420
-
set_u32_be new_buf 8 (Option.get header.right_child);
1421
-
Pager.write t.pager new_page_num (Bytes.unsafe_to_string new_buf);
1422
-
1423
-
(* Update original page: keep cells [0..split_idx-1], right child = sep_cell.left_child *)
1424
-
let old_buf = Bytes.of_string page in
1425
-
set_u16_be old_buf 3 split_idx;
1426
-
set_u32_be old_buf 8 sep_cell.left_child;
1427
-
if split_idx > 0 then begin
1428
-
let min_ptr = ref page_size in
1429
-
for i = 0 to split_idx - 1 do
1430
-
if ptrs.(i) < !min_ptr then min_ptr := ptrs.(i)
1431
-
done;
1432
-
set_u16_be old_buf 5 !min_ptr
1433
-
end
1434
-
else set_u16_be old_buf 5 page_size;
1435
-
Pager.write t.pager page_num (Bytes.unsafe_to_string old_buf);
1436
-
1437
-
{ new_page = new_page_num; separator_key }
1438
-
1439
-
(* Insert a separator into an interior page, potentially splitting *)
1440
-
let rec insert_into_interior t page_num ~left_child ~separator_key
1441
-
~right_child =
1442
-
let page = Pager.read t.pager page_num in
1443
-
let header = parse_page_header page 0 in
1444
-
let cell = encode_index_interior_cell ~left_child ~payload:separator_key in
1445
-
let cell_len = String.length cell in
1446
-
let space_needed = cell_len + 2 in
1447
-
(* cell + pointer *)
1448
-
1449
-
if free_space header ~page_type:Interior_index >= space_needed then begin
1450
-
(* Fits - insert directly *)
1451
-
let buf = Bytes.of_string page in
1452
-
let ptrs = cell_pointers page header in
1453
-
let usable = usable_size t in
1454
-
1455
-
(* Find insert position *)
1456
-
let insert_idx =
1457
-
let rec find i =
1458
-
if i >= header.cell_count then i
1459
-
else
1460
-
let c, _ =
1461
-
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
1462
-
in
1463
-
if separator_key < c.payload then i else find (i + 1)
1464
-
in
1465
-
find 0
1466
-
in
1467
-
1468
-
(* Write cell *)
1469
-
let cell_start =
1470
-
write_cell buf ~cell_content_start:header.cell_content_start ~cell
1471
-
in
1472
-
set_u16_be buf 5 cell_start;
1473
-
1474
-
(* Insert pointer *)
1475
-
insert_cell_pointer buf ~header_offset:0 ~page_type:Interior_index
1476
-
~cell_count:header.cell_count ~index:insert_idx ~ptr:cell_start;
1477
-
1478
-
(* Update cell count *)
1479
-
set_u16_be buf 3 (header.cell_count + 1);
1480
-
1481
-
(* Update child pointers *)
1482
-
if insert_idx < header.cell_count then begin
1483
-
let ptr_start = page_header_size Interior_index in
1484
-
let displaced_ptr =
1485
-
get_u16_be
1486
-
(Bytes.unsafe_to_string buf)
1487
-
(ptr_start + ((insert_idx + 1) * 2))
1488
-
in
1489
-
set_u32_be buf displaced_ptr right_child
1490
-
end
1491
-
else set_u32_be buf 8 right_child;
1492
-
1493
-
Pager.write t.pager page_num (Bytes.unsafe_to_string buf);
1494
-
None
1495
-
end
1496
-
else begin
1497
-
(* Need to split interior page *)
1498
-
let split = split_interior t page_num in
1499
-
1500
-
(* Determine which page gets the new separator *)
1501
-
if separator_key < split.separator_key then begin
1502
-
ignore
1503
-
(insert_into_interior t page_num ~left_child ~separator_key
1504
-
~right_child)
1505
-
end
1506
-
else begin
1507
-
ignore
1508
-
(insert_into_interior t split.new_page ~left_child ~separator_key
1509
-
~right_child)
1510
-
end;
1511
-
1512
-
Some { split with separator_key = split.separator_key }
1513
-
end
1514
-
1515
-
(* Insert into a leaf page, potentially splitting *)
1516
-
let rec insert_into_leaf t page_num ~key ~parent_stack =
1517
-
let page = Pager.read t.pager page_num in
1518
-
let header = parse_page_header page 0 in
1519
-
let cell = encode_index_leaf_cell_with_overflow t ~payload:key in
1520
-
let cell_len = String.length cell in
1521
-
let space_needed = cell_len + 2 in
1522
-
(* cell + pointer *)
1523
-
1524
-
if free_space header ~page_type:Leaf_index >= space_needed then begin
1525
-
(* Fits - insert directly *)
1526
-
let buf = Bytes.of_string page in
1527
-
let insert_idx = find_insert_idx t page header key in
1528
-
1529
-
(* Write cell *)
1530
-
let cell_start =
1531
-
write_cell buf ~cell_content_start:header.cell_content_start ~cell
1532
-
in
1533
-
set_u16_be buf 5 cell_start;
1534
-
1535
-
(* Insert pointer *)
1536
-
insert_cell_pointer buf ~header_offset:0 ~page_type:Leaf_index
1537
-
~cell_count:header.cell_count ~index:insert_idx ~ptr:cell_start;
1538
-
1539
-
(* Update cell count *)
1540
-
set_u16_be buf 3 (header.cell_count + 1);
1541
-
1542
-
Pager.write t.pager page_num (Bytes.unsafe_to_string buf)
1543
-
end
1544
-
else begin
1545
-
(* Need to split *)
1546
-
let split = split_leaf t page_num in
1547
-
1548
-
(* Determine target page and insert *)
1549
-
let target_page =
1550
-
if key < split.separator_key then page_num else split.new_page
1551
-
in
1552
-
let target = Pager.read t.pager target_page in
1553
-
let target_header = parse_page_header target 0 in
1554
-
let target_buf = Bytes.of_string target in
1555
-
let insert_idx = find_insert_idx t target target_header key in
1556
-
let cell_start =
1557
-
write_cell target_buf
1558
-
~cell_content_start:target_header.cell_content_start ~cell
1559
-
in
1560
-
set_u16_be target_buf 5 cell_start;
1561
-
insert_cell_pointer target_buf ~header_offset:0 ~page_type:Leaf_index
1562
-
~cell_count:target_header.cell_count ~index:insert_idx ~ptr:cell_start;
1563
-
set_u16_be target_buf 3 (target_header.cell_count + 1);
1564
-
Pager.write t.pager target_page (Bytes.unsafe_to_string target_buf);
1565
-
1566
-
(* Propagate split up *)
1567
-
propagate_split t ~parent_stack ~left_page:page_num
1568
-
~separator_key:split.separator_key ~right_page:split.new_page
1569
-
end
1570
-
1571
-
and propagate_split t ~parent_stack ~left_page ~separator_key ~right_page =
1572
-
match parent_stack with
1573
-
| [] ->
1574
-
(* Splitting root - create new root *)
1575
-
let page_size = Pager.page_size t.pager in
1576
-
let new_root = Pager.allocate t.pager in
1577
-
let buf = init_page ~page_size ~page_type:Interior_index in
1578
-
1579
-
(* Single cell pointing to left page *)
1580
-
let cell =
1581
-
encode_index_interior_cell ~left_child:left_page
1582
-
~payload:separator_key
1583
-
in
1584
-
let cell_start = write_cell buf ~cell_content_start:page_size ~cell in
1585
-
set_u16_be buf 5 cell_start;
1586
-
set_u16_be buf (page_header_size Interior_index) cell_start;
1587
-
set_u16_be buf 3 1;
1588
-
set_u32_be buf 8 right_page;
1589
-
1590
-
Pager.write t.pager new_root (Bytes.unsafe_to_string buf);
1591
-
t.root_page <- new_root
1592
-
| parent_page :: rest -> (
1593
-
match
1594
-
insert_into_interior t parent_page ~left_child:left_page
1595
-
~separator_key ~right_child:right_page
1596
-
with
1597
-
| None -> () (* Fit in parent *)
1598
-
| Some split ->
1599
-
(* Parent also split, propagate up *)
1600
-
propagate_split t ~parent_stack:rest ~left_page:parent_page
1601
-
~separator_key:split.separator_key ~right_page:split.new_page)
1602
-
1603
-
(* Main insert - traverses tree and handles splits *)
1604
-
let insert t key =
1605
-
let rec traverse page_num parent_stack =
1606
-
let page = Pager.read t.pager page_num in
1607
-
let header = parse_page_header page 0 in
1608
-
match header.page_type with
1609
-
| Leaf_index -> (
1610
-
(* Check if key already exists *)
1611
-
match find_in_leaf t page header key with
1612
-
| Some _ -> () (* Key exists, do nothing (set semantics) *)
1613
-
| None -> insert_into_leaf t page_num ~key ~parent_stack)
1614
-
| Interior_index ->
1615
-
let child_idx = find_child_idx t page header key in
1616
-
let child_page =
1617
-
if child_idx >= header.cell_count then Option.get header.right_child
1618
-
else
1619
-
let ptrs = cell_pointers page header in
1620
-
let usable = usable_size t in
1621
-
let cell, _ =
1622
-
Cell.parse_index_interior page ptrs.(child_idx)
1623
-
~usable_size:usable
1624
-
in
1625
-
cell.left_child
1626
-
in
1627
-
traverse child_page (page_num :: parent_stack)
1628
-
| _ -> failwith "Invalid page type in index B-tree"
1629
-
in
1630
-
traverse t.root_page []
1631
-
1632
-
(* Delete a cell from a leaf page at given index *)
1633
-
let delete_from_leaf t page_num ~index =
1634
-
let page = Pager.read t.pager page_num in
1635
-
let header = parse_page_header page 0 in
1636
-
if header.cell_count = 0 then ()
1637
-
else begin
1638
-
let buf = Bytes.of_string page in
1639
-
let ptr_start = page_header_size Leaf_index in
1640
-
1641
-
(* Shift pointers left to remove the entry at index *)
1642
-
for i = index to header.cell_count - 2 do
1643
-
let next_ptr = get_u16_be page (ptr_start + ((i + 1) * 2)) in
1644
-
set_u16_be buf (ptr_start + (i * 2)) next_ptr
1645
-
done;
1646
-
1647
-
(* Decrease cell count *)
1648
-
set_u16_be buf 3 (header.cell_count - 1);
1649
-
1650
-
(* Note: We don't reclaim space - it becomes fragmented.
1651
-
A proper implementation would compact or track free space. *)
1652
-
Pager.write t.pager page_num (Bytes.unsafe_to_string buf)
1653
-
end
1654
-
1655
-
(* Delete implementation - simplified, doesn't rebalance *)
1656
-
let delete t key =
1657
-
let rec traverse page_num =
1658
-
let page = Pager.read t.pager page_num in
1659
-
let header = parse_page_header page 0 in
1660
-
match header.page_type with
1661
-
| Leaf_index -> (
1662
-
match find_in_leaf t page header key with
1663
-
| Some (_, idx) -> delete_from_leaf t page_num ~index:idx
1664
-
| None -> () (* Key not found, nothing to do *))
1665
-
| Interior_index ->
1666
-
let child = find_child t page header key in
1667
-
traverse child
1668
-
| _ -> failwith "Invalid page type in index B-tree"
1669
-
in
1670
-
traverse t.root_page
1671
-
1672
-
(* Find by prefix - returns first entry starting with prefix *)
1673
-
let rec find_by_prefix_in_page t page_num prefix =
1674
-
let page = Pager.read t.pager page_num in
1675
-
let header = parse_page_header page 0 in
1676
-
let ptrs = cell_pointers page header in
1677
-
let usable = usable_size t in
1678
-
let prefix_len = String.length prefix in
1679
-
let starts_with payload =
1680
-
String.length payload >= prefix_len
1681
-
&& String.sub payload 0 prefix_len = prefix
1682
-
in
1683
-
match header.page_type with
1684
-
| Leaf_index ->
1685
-
(* Linear search for first entry with prefix *)
1686
-
let rec find_first i =
1687
-
if i >= header.cell_count then None
1688
-
else
1689
-
let full_payload =
1690
-
read_full_payload t page ptrs.(i) ~usable_size:usable
1691
-
in
1692
-
if starts_with full_payload then Some full_payload
1693
-
else if full_payload > prefix then None
1694
-
else find_first (i + 1)
1695
-
in
1696
-
find_first 0
1697
-
| Interior_index ->
1698
-
let child = find_child t page header prefix in
1699
-
find_by_prefix_in_page t child prefix
1700
-
| _ -> failwith "Invalid page type in index B-tree"
1701
-
1702
-
let find_by_prefix t prefix = find_by_prefix_in_page t t.root_page prefix
1703
-
1704
-
(* Delete by prefix - deletes first entry starting with prefix *)
1705
-
let rec delete_by_prefix_in_page t page_num prefix =
1706
-
let page = Pager.read t.pager page_num in
1707
-
let header = parse_page_header page 0 in
1708
-
let ptrs = cell_pointers page header in
1709
-
let usable = usable_size t in
1710
-
let prefix_len = String.length prefix in
1711
-
let starts_with payload =
1712
-
String.length payload >= prefix_len
1713
-
&& String.sub payload 0 prefix_len = prefix
1714
-
in
1715
-
match header.page_type with
1716
-
| Leaf_index -> (
1717
-
(* Find first entry with prefix *)
1718
-
let rec find_idx i =
1719
-
if i >= header.cell_count then None
1720
-
else
1721
-
let full_payload =
1722
-
read_full_payload t page ptrs.(i) ~usable_size:usable
1723
-
in
1724
-
if starts_with full_payload then Some i
1725
-
else if full_payload > prefix then None
1726
-
else find_idx (i + 1)
1727
-
in
1728
-
match find_idx 0 with
1729
-
| Some idx -> delete_from_leaf t page_num ~index:idx
1730
-
| None -> ())
1731
-
| Interior_index ->
1732
-
let child = find_child t page header prefix in
1733
-
delete_by_prefix_in_page t child prefix
1734
-
| _ -> failwith "Invalid page type in index B-tree"
1735
-
1736
-
let delete_by_prefix t prefix = delete_by_prefix_in_page t t.root_page prefix
1737
-
1738
-
let iter t f =
1739
-
let rec iter_page page_num =
1740
-
let page = Pager.read t.pager page_num in
1741
-
let header = parse_page_header page 0 in
1742
-
let ptrs = cell_pointers page header in
1743
-
let usable = usable_size t in
1744
-
match header.page_type with
1745
-
| Leaf_index ->
1746
-
for i = 0 to header.cell_count - 1 do
1747
-
let full_payload =
1748
-
read_full_payload t page ptrs.(i) ~usable_size:usable
1749
-
in
1750
-
f full_payload
1751
-
done
1752
-
| Interior_index ->
1753
-
for i = 0 to header.cell_count - 1 do
1754
-
let cell, _ =
1755
-
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
1756
-
in
1757
-
iter_page cell.left_child
1758
-
done;
1759
-
Option.iter iter_page header.right_child
1760
-
| _ -> failwith "Invalid page type"
1761
-
in
1762
-
iter_page t.root_page
1763
-
end
21
+
module Varint = Varint
22
+
module Page = Page
23
+
module Cell = Cell
24
+
module Record = Record
25
+
module Pager = Pager
26
+
module Table = Table
27
+
module Index = Index
+60
-23
lib/btree.mli
+60
-23
lib/btree.mli
···
3
3
SPDX-License-Identifier: MIT
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Pure OCaml B-tree for persistent storage.
6
+
(** SQLite-compatible B-tree implementation.
7
7
8
-
Implements SQLite-compatible B-tree pages for table and index storage. *)
8
+
This library provides read/write access to SQLite B-tree structures,
9
+
supporting both table B-trees (for row storage) and index B-trees (for key
10
+
storage).
11
+
12
+
The implementation is split into several modules:
13
+
- {!Varint}: SQLite-style variable-length integer encoding
14
+
- {!Page}: Page types, headers, and binary helpers
15
+
- {!Cell}: Cell types and parsing for all B-tree node types
16
+
- {!Record}: SQLite record format encoding/decoding
17
+
- {!Pager}: Page cache and file I/O
18
+
- {!Table}: Table B-tree for row storage (rowid -> data)
19
+
- {!Index}: Index B-tree for key storage (key sets) *)
9
20
10
21
(** {1 Varint Encoding}
11
22
···
23
34
(** [size n] returns the number of bytes needed to encode [n]. *)
24
35
end
25
36
26
-
(** {1 Page Types} *)
37
+
(** {1 Page Types and Headers} *)
27
38
28
-
type page_type =
29
-
| Interior_index (** 0x02 *)
30
-
| Interior_table (** 0x05 *)
31
-
| Leaf_index (** 0x0a *)
32
-
| Leaf_table (** 0x0d *)
39
+
module Page : sig
40
+
type page_type =
41
+
| Interior_index (** 0x02 *)
42
+
| Interior_table (** 0x05 *)
43
+
| Leaf_index (** 0x0a *)
44
+
| Leaf_table (** 0x0d *)
45
+
46
+
val pp_page_type : Format.formatter -> page_type -> unit
47
+
48
+
type header = {
49
+
page_type : page_type;
50
+
first_freeblock : int;
51
+
cell_count : int;
52
+
cell_content_start : int;
53
+
fragmented_bytes : int;
54
+
right_child : int option; (** Interior pages only *)
55
+
}
33
56
34
-
val pp_page_type : Format.formatter -> page_type -> unit
57
+
val parse_header : string -> int -> header
58
+
(** [parse_header buf off] parses a page header starting at [off]. For page 1,
59
+
[off] should be 100 (after database header). *)
35
60
36
-
(** {1 Page Header} *)
61
+
val header_size : page_type -> int
62
+
(** [header_size typ] is 8 for leaf pages, 12 for interior pages. *)
37
63
38
-
type page_header = {
39
-
page_type : page_type;
40
-
first_freeblock : int;
41
-
cell_count : int;
42
-
cell_content_start : int;
43
-
fragmented_bytes : int;
44
-
right_child : int option; (** Interior pages only *)
45
-
}
64
+
val init : page_size:int -> page_type:page_type -> bytes
65
+
(** [init ~page_size ~page_type] creates a new empty page buffer. *)
46
66
47
-
val parse_page_header : string -> int -> page_header
48
-
(** [parse_page_header buf off] parses a page header starting at [off]. For page
49
-
1, [off] should be 100 (after database header). *)
67
+
val cell_pointers : string -> int -> header -> int array
68
+
(** [cell_pointers page header_offset header] returns cell pointer array. *)
50
69
51
-
val page_header_size : page_type -> int
52
-
(** [page_header_size typ] is 8 for leaf pages, 12 for interior pages. *)
70
+
val get_u16_be : string -> int -> int
71
+
val get_u32_be : string -> int -> int
72
+
val set_u16_be : bytes -> int -> int -> unit
73
+
val set_u32_be : bytes -> int -> int -> unit
74
+
end
53
75
54
76
(** {1 Cells}
55
77
···
76
98
}
77
99
(** Index interior cell: child page + payload *)
78
100
101
+
val max_local : usable_size:int -> is_table:bool -> int
102
+
val min_local : usable_size:int -> int
103
+
79
104
val parse_table_leaf : string -> int -> usable_size:int -> table_leaf * int
80
105
(** [parse_table_leaf buf off ~usable_size] parses a table leaf cell. Returns
81
106
[(cell, bytes_consumed)]. *)
···
86
111
val parse_index_leaf : string -> int -> usable_size:int -> index_leaf * int
87
112
(** [parse_index_leaf buf off ~usable_size] parses an index leaf cell. *)
88
113
114
+
val parse_index_leaf_raw :
115
+
string -> int -> usable_size:int -> int * string * int option * int
116
+
(** [parse_index_leaf_raw buf off ~usable_size] parses an index leaf cell.
117
+
Returns [(payload_size, local_payload, overflow_page, bytes_consumed)]. *)
118
+
89
119
val parse_index_interior :
90
120
string -> int -> usable_size:int -> index_interior * int
91
121
(** [parse_index_interior buf off ~usable_size] parses an index interior cell.
122
+
*)
123
+
124
+
val parse_index_interior_raw :
125
+
string -> int -> usable_size:int -> int * int * string * int option * int
126
+
(** [parse_index_interior_raw buf off ~usable_size] parses an index interior
127
+
cell. Returns
128
+
[(left_child, payload_size, local_payload, overflow_page, bytes_consumed)].
92
129
*)
93
130
end
94
131
+105
lib/cell.ml
+105
lib/cell.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** B-tree cell parsing and encoding. *)
7
+
8
+
type table_leaf = {
9
+
rowid : int64;
10
+
payload : string;
11
+
overflow_page : int option;
12
+
}
13
+
14
+
type table_interior = { left_child : int; rowid : int64 }
15
+
type index_leaf = { payload : string; overflow_page : int option }
16
+
17
+
type index_interior = {
18
+
left_child : int;
19
+
payload : string;
20
+
overflow_page : int option;
21
+
}
22
+
23
+
(* Calculate max payload on page - simplified *)
24
+
let max_local ~usable_size ~is_table =
25
+
if is_table then usable_size - 35 else ((usable_size - 12) * 64 / 255) - 23
26
+
27
+
let min_local ~usable_size = ((usable_size - 12) * 32 / 255) - 23
28
+
29
+
let parse_table_leaf buf off ~usable_size =
30
+
let payload_size, consumed1 = Varint.decode buf off in
31
+
let rowid, consumed2 = Varint.decode buf (off + consumed1) in
32
+
let header_len = consumed1 + consumed2 in
33
+
let payload_size = Int64.to_int payload_size in
34
+
let max_local = max_local ~usable_size ~is_table:true in
35
+
let min_local = min_local ~usable_size in
36
+
let local_size, overflow_page =
37
+
if payload_size <= max_local then (payload_size, None)
38
+
else
39
+
let k = min_local + ((payload_size - min_local) mod (usable_size - 4)) in
40
+
let local = if k <= max_local then k else min_local in
41
+
let overflow = Page.get_u32_be buf (off + header_len + local) in
42
+
(local, Some overflow)
43
+
in
44
+
let payload = String.sub buf (off + header_len) local_size in
45
+
let total_consumed =
46
+
header_len + local_size + if overflow_page = None then 0 else 4
47
+
in
48
+
({ rowid; payload; overflow_page }, total_consumed)
49
+
50
+
let parse_table_interior buf off =
51
+
let left_child = Page.get_u32_be buf off in
52
+
let rowid, consumed = Varint.decode buf (off + 4) in
53
+
({ left_child; rowid }, 4 + consumed)
54
+
55
+
(* Parse index leaf cell - returns local payload and overflow pointer *)
56
+
let parse_index_leaf_raw buf off ~usable_size =
57
+
let payload_size, consumed = Varint.decode buf off in
58
+
let payload_size = Int64.to_int payload_size in
59
+
let max_local = max_local ~usable_size ~is_table:false in
60
+
let min_local = min_local ~usable_size in
61
+
let local_size, overflow_page =
62
+
if payload_size <= max_local then (payload_size, None)
63
+
else
64
+
let k = min_local + ((payload_size - min_local) mod (usable_size - 4)) in
65
+
let local = if k <= max_local then k else min_local in
66
+
let overflow = Page.get_u32_be buf (off + consumed + local) in
67
+
(local, Some overflow)
68
+
in
69
+
let local_payload = String.sub buf (off + consumed) local_size in
70
+
let total = consumed + local_size + if overflow_page = None then 0 else 4 in
71
+
(payload_size, local_payload, overflow_page, total)
72
+
73
+
let parse_index_leaf buf off ~usable_size =
74
+
let payload_size, local_payload, overflow_page, total =
75
+
parse_index_leaf_raw buf off ~usable_size
76
+
in
77
+
ignore payload_size;
78
+
({ payload = local_payload; overflow_page }, total)
79
+
80
+
(* Parse index interior cell - returns local payload and overflow pointer *)
81
+
let parse_index_interior_raw buf off ~usable_size =
82
+
let left_child = Page.get_u32_be buf off in
83
+
let payload_size, consumed = Varint.decode buf (off + 4) in
84
+
let payload_size = Int64.to_int payload_size in
85
+
let max_local = max_local ~usable_size ~is_table:false in
86
+
let min_local = min_local ~usable_size in
87
+
let local_size, overflow_page =
88
+
if payload_size <= max_local then (payload_size, None)
89
+
else
90
+
let k = min_local + ((payload_size - min_local) mod (usable_size - 4)) in
91
+
let local = if k <= max_local then k else min_local in
92
+
let overflow = Page.get_u32_be buf (off + 4 + consumed + local) in
93
+
(local, Some overflow)
94
+
in
95
+
let local_payload = String.sub buf (off + 4 + consumed) local_size in
96
+
let total =
97
+
4 + consumed + local_size + if overflow_page = None then 0 else 4
98
+
in
99
+
(left_child, payload_size, local_payload, overflow_page, total)
100
+
101
+
let parse_index_interior buf off ~usable_size =
102
+
let left_child, _payload_size, local_payload, overflow_page, total =
103
+
parse_index_interior_raw buf off ~usable_size
104
+
in
105
+
({ left_child; payload = local_payload; overflow_page }, total)
+2
-1
lib/dune
+2
-1
lib/dune
+782
lib/index.ml
+782
lib/index.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Index B-tree for SQLite key storage. *)
7
+
8
+
type t = { pager : Pager.t; mutable root_page : int }
9
+
10
+
let create pager =
11
+
let root = Pager.allocate pager in
12
+
let page_size = Pager.page_size pager in
13
+
let buf = Page.init ~page_size ~page_type:Page.Leaf_index in
14
+
Pager.write pager root (Bytes.unsafe_to_string buf);
15
+
{ pager; root_page = root }
16
+
17
+
let open_ pager ~root_page = { pager; root_page }
18
+
let root_page t = t.root_page
19
+
let usable_size t = Pager.page_size t.pager
20
+
21
+
(* Overflow page handling *)
22
+
let read_overflow_chain pager first_page ~remaining_size =
23
+
let usable = Pager.page_size pager in
24
+
let overflow_content_size = usable - 4 in
25
+
let buf = Buffer.create remaining_size in
26
+
let rec read page_num remaining =
27
+
if remaining <= 0 || page_num = 0 then ()
28
+
else begin
29
+
let page = Pager.read pager page_num in
30
+
let next_page = Page.get_u32_be page 0 in
31
+
let to_read = min remaining overflow_content_size in
32
+
Buffer.add_substring buf page 4 to_read;
33
+
read next_page (remaining - to_read)
34
+
end
35
+
in
36
+
read first_page remaining_size;
37
+
Buffer.contents buf
38
+
39
+
let write_overflow_chain pager payload ~offset =
40
+
let usable = Pager.page_size pager in
41
+
let overflow_content_size = usable - 4 in
42
+
let remaining = String.length payload - offset in
43
+
if remaining <= 0 then 0
44
+
else begin
45
+
let first_page = ref 0 in
46
+
let prev_page_buf = ref None in
47
+
let prev_page_num = ref 0 in
48
+
let pos = ref offset in
49
+
while !pos < String.length payload do
50
+
let page_num = Pager.allocate pager in
51
+
if !first_page = 0 then first_page := page_num;
52
+
(* Link previous page to this one *)
53
+
(match !prev_page_buf with
54
+
| Some buf ->
55
+
Page.set_u32_be buf 0 page_num;
56
+
Pager.write pager !prev_page_num (Bytes.unsafe_to_string buf)
57
+
| None -> ());
58
+
(* Write this page *)
59
+
let page_buf = Bytes.create usable in
60
+
Page.set_u32_be page_buf 0 0;
61
+
(* Next page = 0 for now *)
62
+
let to_write = min (String.length payload - !pos) overflow_content_size in
63
+
Bytes.blit_string payload !pos page_buf 4 to_write;
64
+
prev_page_buf := Some page_buf;
65
+
prev_page_num := page_num;
66
+
pos := !pos + to_write
67
+
done;
68
+
(* Write final page *)
69
+
(match !prev_page_buf with
70
+
| Some buf -> Pager.write pager !prev_page_num (Bytes.unsafe_to_string buf)
71
+
| None -> ());
72
+
!first_page
73
+
end
74
+
75
+
(* Read full payload including overflow pages for leaf cells *)
76
+
let read_full_payload t page off ~usable_size =
77
+
let payload_size, local_payload, overflow_page, _consumed =
78
+
Cell.parse_index_leaf_raw page off ~usable_size
79
+
in
80
+
match overflow_page with
81
+
| None -> local_payload
82
+
| Some first_overflow ->
83
+
let remaining = payload_size - String.length local_payload in
84
+
let overflow_data =
85
+
read_overflow_chain t.pager first_overflow ~remaining_size:remaining
86
+
in
87
+
local_payload ^ overflow_data
88
+
89
+
(* Read full payload including overflow pages for interior cells *)
90
+
let read_full_interior_payload t page off ~usable_size =
91
+
let _left_child, payload_size, local_payload, overflow_page, _consumed =
92
+
Cell.parse_index_interior_raw page off ~usable_size
93
+
in
94
+
match overflow_page with
95
+
| None -> local_payload
96
+
| Some first_overflow ->
97
+
let remaining = payload_size - String.length local_payload in
98
+
let overflow_data =
99
+
read_overflow_chain t.pager first_overflow ~remaining_size:remaining
100
+
in
101
+
local_payload ^ overflow_data
102
+
103
+
let cell_pointers page header =
104
+
let ptrs = Array.make header.Page.cell_count 0 in
105
+
let ptr_start = Page.header_size header.Page.page_type in
106
+
for i = 0 to header.Page.cell_count - 1 do
107
+
ptrs.(i) <- Page.get_u16_be page (ptr_start + (i * 2))
108
+
done;
109
+
ptrs
110
+
111
+
(* Calculate free space in a page *)
112
+
let free_space header ~page_type =
113
+
let header_size = Page.header_size page_type in
114
+
let ptr_area_end = header_size + (header.Page.cell_count * 2) in
115
+
header.Page.cell_content_start - ptr_area_end - header.Page.fragmented_bytes
116
+
117
+
(* Encode an index leaf cell - handles overflow for large payloads *)
118
+
let encode_index_leaf_cell_with_overflow t ~payload =
119
+
let payload_size = String.length payload in
120
+
let usable_size = usable_size t in
121
+
let max_local = Cell.max_local ~usable_size ~is_table:false in
122
+
let min_local = Cell.min_local ~usable_size in
123
+
let payload_size_varint = Varint.encode (Int64.of_int payload_size) in
124
+
let varint_len = String.length payload_size_varint in
125
+
if payload_size <= max_local then begin
126
+
(* Fits entirely - no overflow needed *)
127
+
let cell = Bytes.create (varint_len + payload_size) in
128
+
Bytes.blit_string payload_size_varint 0 cell 0 varint_len;
129
+
Bytes.blit_string payload 0 cell varint_len payload_size;
130
+
Bytes.unsafe_to_string cell
131
+
end
132
+
else begin
133
+
(* Need overflow pages *)
134
+
let k = min_local + ((payload_size - min_local) mod (usable_size - 4)) in
135
+
let local_size = if k <= max_local then k else min_local in
136
+
(* Write overflow pages for data beyond local_size *)
137
+
let overflow_page =
138
+
write_overflow_chain t.pager payload ~offset:local_size
139
+
in
140
+
(* Create cell: varint(size) + local_payload + overflow_ptr *)
141
+
let cell = Bytes.create (varint_len + local_size + 4) in
142
+
Bytes.blit_string payload_size_varint 0 cell 0 varint_len;
143
+
Bytes.blit_string payload 0 cell varint_len local_size;
144
+
Page.set_u32_be cell (varint_len + local_size) overflow_page;
145
+
Bytes.unsafe_to_string cell
146
+
end
147
+
148
+
(* Encode an index interior cell *)
149
+
let encode_index_interior_cell ~left_child ~payload =
150
+
let payload_size_varint =
151
+
Varint.encode (Int64.of_int (String.length payload))
152
+
in
153
+
let cell =
154
+
Bytes.create (4 + String.length payload_size_varint + String.length payload)
155
+
in
156
+
Page.set_u32_be cell 0 left_child;
157
+
Bytes.blit_string payload_size_varint 0 cell 4
158
+
(String.length payload_size_varint);
159
+
Bytes.blit_string payload 0 cell
160
+
(4 + String.length payload_size_varint)
161
+
(String.length payload);
162
+
Bytes.unsafe_to_string cell
163
+
164
+
(* Write a cell into a page buffer, returns new cell_content_start *)
165
+
let write_cell buf ~cell_content_start ~cell =
166
+
let cell_len = String.length cell in
167
+
let new_start = cell_content_start - cell_len in
168
+
Bytes.blit_string cell 0 buf new_start cell_len;
169
+
new_start
170
+
171
+
(* Insert a cell pointer at index, shifting others *)
172
+
let insert_cell_pointer buf ~header_offset ~page_type ~cell_count ~index ~ptr =
173
+
let ptr_start = header_offset + Page.header_size page_type in
174
+
(* Shift existing pointers right *)
175
+
for i = cell_count - 1 downto index do
176
+
let old_ptr =
177
+
Page.get_u16_be (Bytes.unsafe_to_string buf) (ptr_start + (i * 2))
178
+
in
179
+
Page.set_u16_be buf (ptr_start + ((i + 1) * 2)) old_ptr
180
+
done;
181
+
Page.set_u16_be buf (ptr_start + (index * 2)) ptr
182
+
183
+
(* Compare for btree navigation: key is strictly less than payload.
184
+
Special case: if key is a prefix of payload, they are equal for navigation purposes
185
+
(i.e., entries starting with key might be at or after payload's position). *)
186
+
let key_less_than key payload =
187
+
let key_len = String.length key in
188
+
let payload_len = String.length payload in
189
+
let cmp_len = min key_len payload_len in
190
+
let cmp =
191
+
String.compare (String.sub key 0 cmp_len) (String.sub payload 0 cmp_len)
192
+
in
193
+
if cmp <> 0 then cmp < 0
194
+
else
195
+
(* Prefixes match - if key is shorter or equal length, it's NOT strictly less *)
196
+
false
197
+
198
+
let rec mem_in_page t page_num key =
199
+
let page = Pager.read t.pager page_num in
200
+
let header = Page.parse_header page 0 in
201
+
let ptrs = cell_pointers page header in
202
+
let usable = usable_size t in
203
+
match header.Page.page_type with
204
+
| Page.Leaf_index ->
205
+
let rec search lo hi =
206
+
if lo > hi then false
207
+
else
208
+
let mid = (lo + hi) / 2 in
209
+
let cell, _ =
210
+
Cell.parse_index_leaf page ptrs.(mid) ~usable_size:usable
211
+
in
212
+
let cmp = String.compare key cell.Cell.payload in
213
+
if cmp = 0 then true
214
+
else if cmp < 0 then search lo (mid - 1)
215
+
else search (mid + 1) hi
216
+
in
217
+
search 0 (header.Page.cell_count - 1)
218
+
| Page.Interior_index ->
219
+
let rec find_child i =
220
+
if i >= header.Page.cell_count then Option.get header.Page.right_child
221
+
else
222
+
let cell, _ =
223
+
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
224
+
in
225
+
if key_less_than key cell.Cell.payload then cell.Cell.left_child
226
+
else find_child (i + 1)
227
+
in
228
+
mem_in_page t (find_child 0) key
229
+
| _ -> failwith "Invalid page type in index B-tree"
230
+
231
+
let mem t key = mem_in_page t t.root_page key
232
+
233
+
(* Find exact key, returns payload *)
234
+
let rec find_in_page t page_num key =
235
+
let page = Pager.read t.pager page_num in
236
+
let header = Page.parse_header page 0 in
237
+
let ptrs = cell_pointers page header in
238
+
let usable = usable_size t in
239
+
match header.Page.page_type with
240
+
| Page.Leaf_index ->
241
+
let rec search lo hi =
242
+
if lo > hi then None
243
+
else
244
+
let mid = (lo + hi) / 2 in
245
+
(* Read full payload including overflow *)
246
+
let full_payload =
247
+
read_full_payload t page ptrs.(mid) ~usable_size:usable
248
+
in
249
+
let cmp = String.compare key full_payload in
250
+
if cmp = 0 then Some full_payload
251
+
else if cmp < 0 then search lo (mid - 1)
252
+
else search (mid + 1) hi
253
+
in
254
+
search 0 (header.Page.cell_count - 1)
255
+
| Page.Interior_index ->
256
+
let rec find_child_rec i =
257
+
if i >= header.Page.cell_count then Option.get header.Page.right_child
258
+
else
259
+
(* Read full payload for interior comparison *)
260
+
let full_payload =
261
+
read_full_interior_payload t page ptrs.(i) ~usable_size:usable
262
+
in
263
+
if key_less_than key full_payload then
264
+
let cell, _ =
265
+
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
266
+
in
267
+
cell.Cell.left_child
268
+
else find_child_rec (i + 1)
269
+
in
270
+
find_in_page t (find_child_rec 0) key
271
+
| _ -> failwith "Invalid page type in index B-tree"
272
+
273
+
let find t key = find_in_page t t.root_page key
274
+
275
+
(* Find a key in leaf page, returns (payload, index) if found *)
276
+
let find_in_leaf t page header key =
277
+
let ptrs = cell_pointers page header in
278
+
let usable = usable_size t in
279
+
let rec search lo hi =
280
+
if lo > hi then None
281
+
else
282
+
let mid = (lo + hi) / 2 in
283
+
let full_payload =
284
+
read_full_payload t page ptrs.(mid) ~usable_size:usable
285
+
in
286
+
let cmp = String.compare key full_payload in
287
+
if cmp = 0 then Some (full_payload, mid)
288
+
else if cmp < 0 then search lo (mid - 1)
289
+
else search (mid + 1) hi
290
+
in
291
+
search 0 (header.Page.cell_count - 1)
292
+
293
+
(* Find insertion index for key in leaf page *)
294
+
let find_insert_idx t page header key =
295
+
let ptrs = cell_pointers page header in
296
+
let usable = usable_size t in
297
+
let rec find i =
298
+
if i >= header.Page.cell_count then i
299
+
else
300
+
let full_payload =
301
+
read_full_payload t page ptrs.(i) ~usable_size:usable
302
+
in
303
+
if key < full_payload then i else find (i + 1)
304
+
in
305
+
find 0
306
+
307
+
(* Find child page for key in interior page *)
308
+
let find_child t page header key =
309
+
let ptrs = cell_pointers page header in
310
+
let usable = usable_size t in
311
+
let rec loop i =
312
+
if i >= header.Page.cell_count then Option.get header.Page.right_child
313
+
else
314
+
let full_payload =
315
+
read_full_interior_payload t page ptrs.(i) ~usable_size:usable
316
+
in
317
+
if key_less_than key full_payload then
318
+
let cell, _ =
319
+
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
320
+
in
321
+
cell.Cell.left_child
322
+
else loop (i + 1)
323
+
in
324
+
loop 0
325
+
326
+
(* Find child index for key in interior page *)
327
+
let find_child_idx t page header key =
328
+
let ptrs = cell_pointers page header in
329
+
let usable = usable_size t in
330
+
let rec loop i =
331
+
if i >= header.Page.cell_count then i (* right child *)
332
+
else
333
+
let full_payload =
334
+
read_full_interior_payload t page ptrs.(i) ~usable_size:usable
335
+
in
336
+
if key_less_than key full_payload then i else loop (i + 1)
337
+
in
338
+
loop 0
339
+
340
+
(* Split result: new page number and separator key *)
341
+
type split_result = { new_page : int; separator_key : string }
342
+
343
+
(* Split a leaf page, returns info about the new page *)
344
+
let split_leaf t page_num =
345
+
let page = Pager.read t.pager page_num in
346
+
let header = Page.parse_header page 0 in
347
+
let ptrs = cell_pointers page header in
348
+
let usable = usable_size t in
349
+
let page_size = Pager.page_size t.pager in
350
+
351
+
(* Find split point (middle) *)
352
+
let split_idx = header.Page.cell_count / 2 in
353
+
354
+
(* Get separator key (first key that goes to right page) - read full payload *)
355
+
let separator_key =
356
+
read_full_payload t page ptrs.(split_idx) ~usable_size:usable
357
+
in
358
+
359
+
(* Create new right page *)
360
+
let new_page_num = Pager.allocate t.pager in
361
+
let new_buf = Page.init ~page_size ~page_type:Page.Leaf_index in
362
+
363
+
(* Copy cells [split_idx..cell_count-1] to new page *)
364
+
let new_cell_content_start = ref page_size in
365
+
for i = split_idx to header.Page.cell_count - 1 do
366
+
let cell_off = ptrs.(i) in
367
+
(* Read full payload including from overflow pages *)
368
+
let full_payload = read_full_payload t page cell_off ~usable_size:usable in
369
+
(* Re-encode with overflow support *)
370
+
let cell_data =
371
+
encode_index_leaf_cell_with_overflow t ~payload:full_payload
372
+
in
373
+
new_cell_content_start :=
374
+
write_cell new_buf ~cell_content_start:!new_cell_content_start
375
+
~cell:cell_data;
376
+
let new_idx = i - split_idx in
377
+
let ptr_off = Page.header_size Page.Leaf_index + (new_idx * 2) in
378
+
Page.set_u16_be new_buf ptr_off !new_cell_content_start
379
+
done;
380
+
let new_cell_count = header.Page.cell_count - split_idx in
381
+
Page.set_u16_be new_buf 3 new_cell_count;
382
+
Page.set_u16_be new_buf 5 !new_cell_content_start;
383
+
Pager.write t.pager new_page_num (Bytes.unsafe_to_string new_buf);
384
+
385
+
(* Update original page to only have cells [0..split_idx-1] *)
386
+
let old_buf = Bytes.of_string page in
387
+
Page.set_u16_be old_buf 3 split_idx;
388
+
(* Recalculate cell content start for remaining cells *)
389
+
if split_idx > 0 then begin
390
+
let min_ptr = ref page_size in
391
+
for i = 0 to split_idx - 1 do
392
+
if ptrs.(i) < !min_ptr then min_ptr := ptrs.(i)
393
+
done;
394
+
Page.set_u16_be old_buf 5 !min_ptr
395
+
end
396
+
else Page.set_u16_be old_buf 5 page_size;
397
+
Pager.write t.pager page_num (Bytes.unsafe_to_string old_buf);
398
+
399
+
{ new_page = new_page_num; separator_key }
400
+
401
+
(* Split an interior page *)
402
+
let split_interior t page_num =
403
+
let page = Pager.read t.pager page_num in
404
+
let header = Page.parse_header page 0 in
405
+
let ptrs = cell_pointers page header in
406
+
let usable = usable_size t in
407
+
let page_size = Pager.page_size t.pager in
408
+
409
+
(* Split point - middle cell becomes separator, doesn't go to either page *)
410
+
let split_idx = header.Page.cell_count / 2 in
411
+
let sep_cell, _ =
412
+
Cell.parse_index_interior page ptrs.(split_idx) ~usable_size:usable
413
+
in
414
+
let separator_key = sep_cell.Cell.payload in
415
+
416
+
(* Create new right page *)
417
+
let new_page_num = Pager.allocate t.pager in
418
+
let new_buf = Page.init ~page_size ~page_type:Page.Interior_index in
419
+
420
+
(* Cells [split_idx+1..cell_count-1] go to new page *)
421
+
let new_cell_content_start = ref page_size in
422
+
for i = split_idx + 1 to header.Page.cell_count - 1 do
423
+
let cell_off = ptrs.(i) in
424
+
let cell, _ = Cell.parse_index_interior page cell_off ~usable_size:usable in
425
+
let cell_data =
426
+
encode_index_interior_cell ~left_child:cell.Cell.left_child
427
+
~payload:cell.Cell.payload
428
+
in
429
+
new_cell_content_start :=
430
+
write_cell new_buf ~cell_content_start:!new_cell_content_start
431
+
~cell:cell_data;
432
+
let new_idx = i - split_idx - 1 in
433
+
let ptr_off = Page.header_size Page.Interior_index + (new_idx * 2) in
434
+
Page.set_u16_be new_buf ptr_off !new_cell_content_start
435
+
done;
436
+
let new_cell_count = header.Page.cell_count - split_idx - 1 in
437
+
Page.set_u16_be new_buf 3 new_cell_count;
438
+
Page.set_u16_be new_buf 5 !new_cell_content_start;
439
+
(* Right child of new page is same as original *)
440
+
Page.set_u32_be new_buf 8 (Option.get header.Page.right_child);
441
+
Pager.write t.pager new_page_num (Bytes.unsafe_to_string new_buf);
442
+
443
+
(* Update original page: keep cells [0..split_idx-1], right child = sep_cell.left_child *)
444
+
let old_buf = Bytes.of_string page in
445
+
Page.set_u16_be old_buf 3 split_idx;
446
+
Page.set_u32_be old_buf 8 sep_cell.Cell.left_child;
447
+
if split_idx > 0 then begin
448
+
let min_ptr = ref page_size in
449
+
for i = 0 to split_idx - 1 do
450
+
if ptrs.(i) < !min_ptr then min_ptr := ptrs.(i)
451
+
done;
452
+
Page.set_u16_be old_buf 5 !min_ptr
453
+
end
454
+
else Page.set_u16_be old_buf 5 page_size;
455
+
Pager.write t.pager page_num (Bytes.unsafe_to_string old_buf);
456
+
457
+
{ new_page = new_page_num; separator_key }
458
+
459
+
(* Insert a separator into an interior page, potentially splitting *)
460
+
let rec insert_into_interior t page_num ~left_child ~separator_key ~right_child
461
+
=
462
+
let page = Pager.read t.pager page_num in
463
+
let header = Page.parse_header page 0 in
464
+
let cell = encode_index_interior_cell ~left_child ~payload:separator_key in
465
+
let cell_len = String.length cell in
466
+
let space_needed = cell_len + 2 in
467
+
(* cell + pointer *)
468
+
469
+
if free_space header ~page_type:Page.Interior_index >= space_needed then begin
470
+
(* Fits - insert directly *)
471
+
let buf = Bytes.of_string page in
472
+
let ptrs = cell_pointers page header in
473
+
let usable = usable_size t in
474
+
475
+
(* Find insert position *)
476
+
let insert_idx =
477
+
let rec find i =
478
+
if i >= header.Page.cell_count then i
479
+
else
480
+
let c, _ =
481
+
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
482
+
in
483
+
if separator_key < c.Cell.payload then i else find (i + 1)
484
+
in
485
+
find 0
486
+
in
487
+
488
+
(* Write cell *)
489
+
let cell_start =
490
+
write_cell buf ~cell_content_start:header.Page.cell_content_start ~cell
491
+
in
492
+
Page.set_u16_be buf 5 cell_start;
493
+
494
+
(* Insert pointer *)
495
+
insert_cell_pointer buf ~header_offset:0 ~page_type:Page.Interior_index
496
+
~cell_count:header.Page.cell_count ~index:insert_idx ~ptr:cell_start;
497
+
498
+
(* Update cell count *)
499
+
Page.set_u16_be buf 3 (header.Page.cell_count + 1);
500
+
501
+
(* Update child pointers *)
502
+
if insert_idx < header.Page.cell_count then begin
503
+
let ptr_start = Page.header_size Page.Interior_index in
504
+
let displaced_ptr =
505
+
Page.get_u16_be
506
+
(Bytes.unsafe_to_string buf)
507
+
(ptr_start + ((insert_idx + 1) * 2))
508
+
in
509
+
Page.set_u32_be buf displaced_ptr right_child
510
+
end
511
+
else Page.set_u32_be buf 8 right_child;
512
+
513
+
Pager.write t.pager page_num (Bytes.unsafe_to_string buf);
514
+
None
515
+
end
516
+
else begin
517
+
(* Need to split interior page *)
518
+
let split = split_interior t page_num in
519
+
520
+
(* Determine which page gets the new separator *)
521
+
if separator_key < split.separator_key then begin
522
+
ignore
523
+
(insert_into_interior t page_num ~left_child ~separator_key ~right_child)
524
+
end
525
+
else begin
526
+
ignore
527
+
(insert_into_interior t split.new_page ~left_child ~separator_key
528
+
~right_child)
529
+
end;
530
+
531
+
Some { split with separator_key = split.separator_key }
532
+
end
533
+
534
+
(* Insert into a leaf page, potentially splitting *)
535
+
let rec insert_into_leaf t page_num ~key ~parent_stack =
536
+
let page = Pager.read t.pager page_num in
537
+
let header = Page.parse_header page 0 in
538
+
let cell = encode_index_leaf_cell_with_overflow t ~payload:key in
539
+
let cell_len = String.length cell in
540
+
let space_needed = cell_len + 2 in
541
+
(* cell + pointer *)
542
+
543
+
if free_space header ~page_type:Page.Leaf_index >= space_needed then begin
544
+
(* Fits - insert directly *)
545
+
let buf = Bytes.of_string page in
546
+
let insert_idx = find_insert_idx t page header key in
547
+
548
+
(* Write cell *)
549
+
let cell_start =
550
+
write_cell buf ~cell_content_start:header.Page.cell_content_start ~cell
551
+
in
552
+
Page.set_u16_be buf 5 cell_start;
553
+
554
+
(* Insert pointer *)
555
+
insert_cell_pointer buf ~header_offset:0 ~page_type:Page.Leaf_index
556
+
~cell_count:header.Page.cell_count ~index:insert_idx ~ptr:cell_start;
557
+
558
+
(* Update cell count *)
559
+
Page.set_u16_be buf 3 (header.Page.cell_count + 1);
560
+
561
+
Pager.write t.pager page_num (Bytes.unsafe_to_string buf)
562
+
end
563
+
else begin
564
+
(* Need to split *)
565
+
let split = split_leaf t page_num in
566
+
567
+
(* Determine target page and insert *)
568
+
let target_page =
569
+
if key < split.separator_key then page_num else split.new_page
570
+
in
571
+
let target = Pager.read t.pager target_page in
572
+
let target_header = Page.parse_header target 0 in
573
+
let target_buf = Bytes.of_string target in
574
+
let insert_idx = find_insert_idx t target target_header key in
575
+
let cell_start =
576
+
write_cell target_buf
577
+
~cell_content_start:target_header.Page.cell_content_start ~cell
578
+
in
579
+
Page.set_u16_be target_buf 5 cell_start;
580
+
insert_cell_pointer target_buf ~header_offset:0 ~page_type:Page.Leaf_index
581
+
~cell_count:target_header.Page.cell_count ~index:insert_idx
582
+
~ptr:cell_start;
583
+
Page.set_u16_be target_buf 3 (target_header.Page.cell_count + 1);
584
+
Pager.write t.pager target_page (Bytes.unsafe_to_string target_buf);
585
+
586
+
(* Propagate split up *)
587
+
propagate_split t ~parent_stack ~left_page:page_num
588
+
~separator_key:split.separator_key ~right_page:split.new_page
589
+
end
590
+
591
+
and propagate_split t ~parent_stack ~left_page ~separator_key ~right_page =
592
+
match parent_stack with
593
+
| [] ->
594
+
(* Splitting root - create new root *)
595
+
let page_size = Pager.page_size t.pager in
596
+
let new_root = Pager.allocate t.pager in
597
+
let buf = Page.init ~page_size ~page_type:Page.Interior_index in
598
+
599
+
(* Single cell pointing to left page *)
600
+
let cell =
601
+
encode_index_interior_cell ~left_child:left_page ~payload:separator_key
602
+
in
603
+
let cell_start = write_cell buf ~cell_content_start:page_size ~cell in
604
+
Page.set_u16_be buf 5 cell_start;
605
+
Page.set_u16_be buf (Page.header_size Page.Interior_index) cell_start;
606
+
Page.set_u16_be buf 3 1;
607
+
Page.set_u32_be buf 8 right_page;
608
+
609
+
Pager.write t.pager new_root (Bytes.unsafe_to_string buf);
610
+
t.root_page <- new_root
611
+
| parent_page :: rest -> (
612
+
match
613
+
insert_into_interior t parent_page ~left_child:left_page ~separator_key
614
+
~right_child:right_page
615
+
with
616
+
| None -> () (* Fit in parent *)
617
+
| Some split ->
618
+
(* Parent also split, propagate up *)
619
+
propagate_split t ~parent_stack:rest ~left_page:parent_page
620
+
~separator_key:split.separator_key ~right_page:split.new_page)
621
+
622
+
(* Main insert - traverses tree and handles splits *)
623
+
let insert t key =
624
+
let rec traverse page_num parent_stack =
625
+
let page = Pager.read t.pager page_num in
626
+
let header = Page.parse_header page 0 in
627
+
match header.Page.page_type with
628
+
| Page.Leaf_index -> (
629
+
(* Check if key already exists *)
630
+
match find_in_leaf t page header key with
631
+
| Some _ -> () (* Key exists, do nothing (set semantics) *)
632
+
| None -> insert_into_leaf t page_num ~key ~parent_stack)
633
+
| Page.Interior_index ->
634
+
let child_idx = find_child_idx t page header key in
635
+
let child_page =
636
+
if child_idx >= header.Page.cell_count then
637
+
Option.get header.Page.right_child
638
+
else
639
+
let ptrs = cell_pointers page header in
640
+
let usable = usable_size t in
641
+
let cell, _ =
642
+
Cell.parse_index_interior page ptrs.(child_idx)
643
+
~usable_size:usable
644
+
in
645
+
cell.Cell.left_child
646
+
in
647
+
traverse child_page (page_num :: parent_stack)
648
+
| _ -> failwith "Invalid page type in index B-tree"
649
+
in
650
+
traverse t.root_page []
651
+
652
+
(* Delete a cell from a leaf page at given index *)
653
+
let delete_from_leaf t page_num ~index =
654
+
let page = Pager.read t.pager page_num in
655
+
let header = Page.parse_header page 0 in
656
+
if header.Page.cell_count = 0 then ()
657
+
else begin
658
+
let buf = Bytes.of_string page in
659
+
let ptr_start = Page.header_size Page.Leaf_index in
660
+
661
+
(* Shift pointers left to remove the entry at index *)
662
+
for i = index to header.Page.cell_count - 2 do
663
+
let next_ptr = Page.get_u16_be page (ptr_start + ((i + 1) * 2)) in
664
+
Page.set_u16_be buf (ptr_start + (i * 2)) next_ptr
665
+
done;
666
+
667
+
(* Decrease cell count *)
668
+
Page.set_u16_be buf 3 (header.Page.cell_count - 1);
669
+
670
+
(* Note: We don't reclaim space - it becomes fragmented.
671
+
A proper implementation would compact or track free space. *)
672
+
Pager.write t.pager page_num (Bytes.unsafe_to_string buf)
673
+
end
674
+
675
+
(* Delete implementation - simplified, doesn't rebalance *)
676
+
let delete t key =
677
+
let rec traverse page_num =
678
+
let page = Pager.read t.pager page_num in
679
+
let header = Page.parse_header page 0 in
680
+
match header.Page.page_type with
681
+
| Page.Leaf_index -> (
682
+
match find_in_leaf t page header key with
683
+
| Some (_, idx) -> delete_from_leaf t page_num ~index:idx
684
+
| None -> () (* Key not found, nothing to do *))
685
+
| Page.Interior_index ->
686
+
let child = find_child t page header key in
687
+
traverse child
688
+
| _ -> failwith "Invalid page type in index B-tree"
689
+
in
690
+
traverse t.root_page
691
+
692
+
(* Find by prefix - returns first entry starting with prefix *)
693
+
let rec find_by_prefix_in_page t page_num prefix =
694
+
let page = Pager.read t.pager page_num in
695
+
let header = Page.parse_header page 0 in
696
+
let ptrs = cell_pointers page header in
697
+
let usable = usable_size t in
698
+
let prefix_len = String.length prefix in
699
+
let starts_with payload =
700
+
String.length payload >= prefix_len
701
+
&& String.sub payload 0 prefix_len = prefix
702
+
in
703
+
match header.Page.page_type with
704
+
| Page.Leaf_index ->
705
+
(* Linear search for first entry with prefix *)
706
+
let rec find_first i =
707
+
if i >= header.Page.cell_count then None
708
+
else
709
+
let full_payload =
710
+
read_full_payload t page ptrs.(i) ~usable_size:usable
711
+
in
712
+
if starts_with full_payload then Some full_payload
713
+
else if full_payload > prefix then None
714
+
else find_first (i + 1)
715
+
in
716
+
find_first 0
717
+
| Page.Interior_index ->
718
+
let child = find_child t page header prefix in
719
+
find_by_prefix_in_page t child prefix
720
+
| _ -> failwith "Invalid page type in index B-tree"
721
+
722
+
let find_by_prefix t prefix = find_by_prefix_in_page t t.root_page prefix
723
+
724
+
(* Delete by prefix - deletes first entry starting with prefix *)
725
+
let rec delete_by_prefix_in_page t page_num prefix =
726
+
let page = Pager.read t.pager page_num in
727
+
let header = Page.parse_header page 0 in
728
+
let ptrs = cell_pointers page header in
729
+
let usable = usable_size t in
730
+
let prefix_len = String.length prefix in
731
+
let starts_with payload =
732
+
String.length payload >= prefix_len
733
+
&& String.sub payload 0 prefix_len = prefix
734
+
in
735
+
match header.Page.page_type with
736
+
| Page.Leaf_index -> (
737
+
(* Find first entry with prefix *)
738
+
let rec find_idx i =
739
+
if i >= header.Page.cell_count then None
740
+
else
741
+
let full_payload =
742
+
read_full_payload t page ptrs.(i) ~usable_size:usable
743
+
in
744
+
if starts_with full_payload then Some i
745
+
else if full_payload > prefix then None
746
+
else find_idx (i + 1)
747
+
in
748
+
match find_idx 0 with
749
+
| Some idx -> delete_from_leaf t page_num ~index:idx
750
+
| None -> ())
751
+
| Page.Interior_index ->
752
+
let child = find_child t page header prefix in
753
+
delete_by_prefix_in_page t child prefix
754
+
| _ -> failwith "Invalid page type in index B-tree"
755
+
756
+
let delete_by_prefix t prefix = delete_by_prefix_in_page t t.root_page prefix
757
+
758
+
let iter t f =
759
+
let rec iter_page page_num =
760
+
let page = Pager.read t.pager page_num in
761
+
let header = Page.parse_header page 0 in
762
+
let ptrs = cell_pointers page header in
763
+
let usable = usable_size t in
764
+
match header.Page.page_type with
765
+
| Page.Leaf_index ->
766
+
for i = 0 to header.Page.cell_count - 1 do
767
+
let full_payload =
768
+
read_full_payload t page ptrs.(i) ~usable_size:usable
769
+
in
770
+
f full_payload
771
+
done
772
+
| Page.Interior_index ->
773
+
for i = 0 to header.Page.cell_count - 1 do
774
+
let cell, _ =
775
+
Cell.parse_index_interior page ptrs.(i) ~usable_size:usable
776
+
in
777
+
iter_page cell.Cell.left_child
778
+
done;
779
+
Option.iter iter_page header.Page.right_child
780
+
| _ -> failwith "Invalid page type"
781
+
in
782
+
iter_page t.root_page
+131
lib/page.ml
+131
lib/page.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** B-tree page types and header parsing. *)
7
+
8
+
type page_type = Interior_index | Interior_table | Leaf_index | Leaf_table
9
+
10
+
let pp_page_type ppf = function
11
+
| Interior_index -> Format.pp_print_string ppf "interior_index"
12
+
| Interior_table -> Format.pp_print_string ppf "interior_table"
13
+
| Leaf_index -> Format.pp_print_string ppf "leaf_index"
14
+
| Leaf_table -> Format.pp_print_string ppf "leaf_table"
15
+
16
+
let page_type_of_byte = function
17
+
| 0x02 -> Interior_index
18
+
| 0x05 -> Interior_table
19
+
| 0x0a -> Leaf_index
20
+
| 0x0d -> Leaf_table
21
+
| b -> failwith (Printf.sprintf "Invalid page type: 0x%02x" b)
22
+
23
+
let byte_of_page_type = function
24
+
| Interior_index -> 0x02
25
+
| Interior_table -> 0x05
26
+
| Leaf_index -> 0x0a
27
+
| Leaf_table -> 0x0d
28
+
29
+
let header_size = function
30
+
| Interior_index | Interior_table -> 12
31
+
| Leaf_index | Leaf_table -> 8
32
+
33
+
let is_interior = function
34
+
| Interior_index | Interior_table -> true
35
+
| Leaf_index | Leaf_table -> false
36
+
37
+
type header = {
38
+
page_type : page_type;
39
+
first_freeblock : int;
40
+
cell_count : int;
41
+
cell_content_start : int;
42
+
fragmented_bytes : int;
43
+
right_child : int option;
44
+
}
45
+
(** Page header. *)
46
+
47
+
(* Binary helpers *)
48
+
49
+
let get_u16_be buf off = (Char.code buf.[off] lsl 8) lor Char.code buf.[off + 1]
50
+
51
+
let get_u32_be buf off =
52
+
(Char.code buf.[off] lsl 24)
53
+
lor (Char.code buf.[off + 1] lsl 16)
54
+
lor (Char.code buf.[off + 2] lsl 8)
55
+
lor Char.code buf.[off + 3]
56
+
57
+
let set_u16_be buf off v =
58
+
Bytes.set_uint8 buf off (v lsr 8);
59
+
Bytes.set_uint8 buf (off + 1) (v land 0xff)
60
+
61
+
let set_u32_be buf off v =
62
+
Bytes.set_uint8 buf off (v lsr 24);
63
+
Bytes.set_uint8 buf (off + 1) ((v lsr 16) land 0xff);
64
+
Bytes.set_uint8 buf (off + 2) ((v lsr 8) land 0xff);
65
+
Bytes.set_uint8 buf (off + 3) (v land 0xff)
66
+
67
+
let parse_header buf off =
68
+
let page_type = page_type_of_byte (Char.code buf.[off]) in
69
+
let first_freeblock = get_u16_be buf (off + 1) in
70
+
let cell_count = get_u16_be buf (off + 3) in
71
+
let cell_content_start =
72
+
let v = get_u16_be buf (off + 5) in
73
+
if v = 0 then 65536 else v
74
+
in
75
+
let fragmented_bytes = Char.code buf.[off + 7] in
76
+
let right_child =
77
+
if is_interior page_type then Some (get_u32_be buf (off + 8)) else None
78
+
in
79
+
{
80
+
page_type;
81
+
first_freeblock;
82
+
cell_count;
83
+
cell_content_start;
84
+
fragmented_bytes;
85
+
right_child;
86
+
}
87
+
88
+
let free_space header ~page_type =
89
+
let hdr_size = header_size page_type in
90
+
let ptr_area_end = hdr_size + (header.cell_count * 2) in
91
+
header.cell_content_start - ptr_area_end - header.fragmented_bytes
92
+
93
+
let init ~page_size ~page_type =
94
+
let buf = Bytes.create page_size in
95
+
Bytes.set_uint8 buf 0 (byte_of_page_type page_type);
96
+
set_u16_be buf 1 0;
97
+
(* first freeblock *)
98
+
set_u16_be buf 3 0;
99
+
(* cell count *)
100
+
set_u16_be buf 5 page_size;
101
+
(* cell content start *)
102
+
Bytes.set_uint8 buf 7 0;
103
+
(* fragmented bytes *)
104
+
if is_interior page_type then set_u32_be buf 8 0;
105
+
(* right child *)
106
+
buf
107
+
108
+
let write_cell buf ~cell_content_start ~cell =
109
+
let cell_len = String.length cell in
110
+
let cell_start = cell_content_start - cell_len in
111
+
Bytes.blit_string cell 0 buf cell_start cell_len;
112
+
cell_start
113
+
114
+
let cell_pointers page header_offset header =
115
+
let ptrs = Array.make header.cell_count 0 in
116
+
let ptr_start = header_offset + header_size header.page_type in
117
+
for i = 0 to header.cell_count - 1 do
118
+
ptrs.(i) <- get_u16_be page (ptr_start + (i * 2))
119
+
done;
120
+
ptrs
121
+
122
+
let insert_cell_pointer buf ~header_offset ~page_type ~cell_count ~index ~ptr =
123
+
let ptr_start = header_offset + header_size page_type in
124
+
(* Shift existing pointers right *)
125
+
for i = cell_count - 1 downto index do
126
+
let old_ptr =
127
+
get_u16_be (Bytes.unsafe_to_string buf) (ptr_start + (i * 2))
128
+
in
129
+
set_u16_be buf (ptr_start + ((i + 1) * 2)) old_ptr
130
+
done;
131
+
set_u16_be buf (ptr_start + (index * 2)) ptr
+66
lib/pager.ml
+66
lib/pager.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Page cache and file I/O for B-tree storage. *)
7
+
8
+
type t = {
9
+
file : Eio.File.rw_ty Eio.Resource.t;
10
+
page_size : int;
11
+
mutable page_count : int;
12
+
cache : (int, string) Hashtbl.t;
13
+
dirty : (int, string) Hashtbl.t;
14
+
}
15
+
16
+
let create ~page_size file =
17
+
let stat = Eio.File.stat file in
18
+
let file_size = Optint.Int63.to_int stat.size in
19
+
let page_count = if file_size = 0 then 0 else file_size / page_size in
20
+
{
21
+
file;
22
+
page_size;
23
+
page_count;
24
+
cache = Hashtbl.create 64;
25
+
dirty = Hashtbl.create 16;
26
+
}
27
+
28
+
let page_size t = t.page_size
29
+
let page_count t = t.page_count
30
+
31
+
let read t page_num =
32
+
if page_num < 1 || page_num > t.page_count then
33
+
failwith (Printf.sprintf "Invalid page number: %d" page_num);
34
+
match Hashtbl.find_opt t.dirty page_num with
35
+
| Some data -> data
36
+
| None -> (
37
+
match Hashtbl.find_opt t.cache page_num with
38
+
| Some data -> data
39
+
| None ->
40
+
let offset = Optint.Int63.of_int ((page_num - 1) * t.page_size) in
41
+
let buf = Cstruct.create t.page_size in
42
+
Eio.File.pread_exact t.file ~file_offset:offset [ buf ];
43
+
let data = Cstruct.to_string buf in
44
+
Hashtbl.replace t.cache page_num data;
45
+
data)
46
+
47
+
let write t page_num data =
48
+
if String.length data <> t.page_size then failwith "Invalid page size";
49
+
Hashtbl.replace t.dirty page_num data;
50
+
Hashtbl.replace t.cache page_num data
51
+
52
+
let allocate t =
53
+
t.page_count <- t.page_count + 1;
54
+
let data = String.make t.page_size '\x00' in
55
+
Hashtbl.replace t.dirty t.page_count data;
56
+
Hashtbl.replace t.cache t.page_count data;
57
+
t.page_count
58
+
59
+
let sync t =
60
+
Hashtbl.iter
61
+
(fun page_num data ->
62
+
let offset = Optint.Int63.of_int ((page_num - 1) * t.page_size) in
63
+
let buf = Cstruct.of_string data in
64
+
Eio.File.pwrite_all t.file ~file_offset:offset [ buf ])
65
+
t.dirty;
66
+
Hashtbl.clear t.dirty
+162
lib/record.ml
+162
lib/record.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SQLite record format encoding and decoding. *)
7
+
8
+
type serial_type =
9
+
| Null
10
+
| Int8
11
+
| Int16
12
+
| Int24
13
+
| Int32
14
+
| Int48
15
+
| Int64
16
+
| Float64
17
+
| Zero
18
+
| One
19
+
| Blob of int
20
+
| Text of int
21
+
22
+
type value =
23
+
| Vnull
24
+
| Vint of int64
25
+
| Vfloat of float
26
+
| Vblob of string
27
+
| Vtext of string
28
+
29
+
let serial_type_of_int = function
30
+
| 0 -> Null
31
+
| 1 -> Int8
32
+
| 2 -> Int16
33
+
| 3 -> Int24
34
+
| 4 -> Int32
35
+
| 5 -> Int48
36
+
| 6 -> Int64
37
+
| 7 -> Float64
38
+
| 8 -> Zero
39
+
| 9 -> One
40
+
| n when n >= 12 && n mod 2 = 0 -> Blob ((n - 12) / 2)
41
+
| n when n >= 13 -> Text ((n - 13) / 2)
42
+
| n -> failwith (Printf.sprintf "Invalid serial type: %d" n)
43
+
44
+
let decode_int buf off len =
45
+
let rec loop acc i =
46
+
if i >= len then acc
47
+
else
48
+
let b = Char.code buf.[off + i] in
49
+
let acc = Int64.logor (Int64.shift_left acc 8) (Int64.of_int b) in
50
+
loop acc (i + 1)
51
+
in
52
+
(* Sign extend for negative values *)
53
+
let v = loop 0L 0 in
54
+
if len > 0 && Char.code buf.[off] land 0x80 <> 0 then
55
+
let mask = Int64.shift_left (-1L) (len * 8) in
56
+
Int64.logor v mask
57
+
else v
58
+
59
+
let decode payload =
60
+
let header_size, consumed = Varint.decode payload 0 in
61
+
let header_size = Int64.to_int header_size in
62
+
(* Parse serial types *)
63
+
let rec parse_types off acc =
64
+
if off >= header_size then List.rev acc
65
+
else
66
+
let st, consumed = Varint.decode payload off in
67
+
let st = serial_type_of_int (Int64.to_int st) in
68
+
parse_types (off + consumed) (st :: acc)
69
+
in
70
+
let types = parse_types consumed [] in
71
+
(* Parse values *)
72
+
let rec parse_values types off acc =
73
+
match types with
74
+
| [] -> List.rev acc
75
+
| st :: rest ->
76
+
let value, sz =
77
+
match st with
78
+
| Null -> (Vnull, 0)
79
+
| Zero -> (Vint 0L, 0)
80
+
| One -> (Vint 1L, 0)
81
+
| Int8 -> (Vint (decode_int payload off 1), 1)
82
+
| Int16 -> (Vint (decode_int payload off 2), 2)
83
+
| Int24 -> (Vint (decode_int payload off 3), 3)
84
+
| Int32 -> (Vint (decode_int payload off 4), 4)
85
+
| Int48 -> (Vint (decode_int payload off 6), 6)
86
+
| Int64 -> (Vint (decode_int payload off 8), 8)
87
+
| Float64 ->
88
+
let bits = decode_int payload off 8 in
89
+
(Vfloat (Int64.float_of_bits bits), 8)
90
+
| Blob n -> (Vblob (String.sub payload off n), n)
91
+
| Text n -> (Vtext (String.sub payload off n), n)
92
+
in
93
+
parse_values rest (off + sz) (value :: acc)
94
+
in
95
+
parse_values types header_size []
96
+
97
+
let serial_type_of_value = function
98
+
| Vnull -> (0, 0)
99
+
| Vint 0L -> (8, 0)
100
+
| Vint 1L -> (9, 0)
101
+
| Vint n ->
102
+
if n >= -128L && n <= 127L then (1, 1)
103
+
else if n >= -32768L && n <= 32767L then (2, 2)
104
+
else if n >= -8388608L && n <= 8388607L then (3, 3)
105
+
else if n >= -2147483648L && n <= 2147483647L then (4, 4)
106
+
else if n >= -140737488355328L && n <= 140737488355327L then (5, 6)
107
+
else (6, 8)
108
+
| Vfloat _ -> (7, 8)
109
+
| Vblob s -> (12 + (String.length s * 2), String.length s)
110
+
| Vtext s -> (13 + (String.length s * 2), String.length s)
111
+
112
+
let encode_int buf off n len =
113
+
for i = 0 to len - 1 do
114
+
let shift = (len - 1 - i) * 8 in
115
+
Bytes.set_uint8 buf (off + i)
116
+
(Int64.to_int (Int64.shift_right n shift) land 0xff)
117
+
done
118
+
119
+
let encode values =
120
+
(* Calculate header *)
121
+
let types_and_sizes = List.map serial_type_of_value values in
122
+
let header_types =
123
+
List.map (fun (st, _) -> Varint.encode (Int64.of_int st)) types_and_sizes
124
+
in
125
+
let header_body = String.concat "" header_types in
126
+
let header_size = 1 + String.length header_body in
127
+
(* header size varint + types *)
128
+
let body_size =
129
+
List.fold_left (fun acc (_, sz) -> acc + sz) 0 types_and_sizes
130
+
in
131
+
let total = header_size + body_size in
132
+
let buf = Bytes.create total in
133
+
(* Write header size *)
134
+
Bytes.set_uint8 buf 0 header_size;
135
+
(* Write serial types *)
136
+
let _ =
137
+
List.fold_left
138
+
(fun off s ->
139
+
Bytes.blit_string s 0 buf off (String.length s);
140
+
off + String.length s)
141
+
1 header_types
142
+
in
143
+
(* Write values *)
144
+
let _ =
145
+
List.fold_left2
146
+
(fun off value (_, sz) ->
147
+
(match value with
148
+
| Vnull | Vint 0L | Vint 1L -> ()
149
+
| Vint n -> encode_int buf off n sz
150
+
| Vfloat f -> encode_int buf off (Int64.bits_of_float f) 8
151
+
| Vblob s | Vtext s -> Bytes.blit_string s 0 buf off sz);
152
+
off + sz)
153
+
header_size values types_and_sizes
154
+
in
155
+
Bytes.unsafe_to_string buf
156
+
157
+
let pp_value ppf = function
158
+
| Vnull -> Format.pp_print_string ppf "NULL"
159
+
| Vint n -> Format.fprintf ppf "%Ld" n
160
+
| Vfloat f -> Format.fprintf ppf "%f" f
161
+
| Vblob s -> Format.fprintf ppf "BLOB(%d)" (String.length s)
162
+
| Vtext s -> Format.fprintf ppf "%S" s
+473
lib/table.ml
+473
lib/table.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Table B-tree for SQLite row storage. *)
7
+
8
+
type t = { pager : Pager.t; mutable root_page : int }
9
+
10
+
let create pager =
11
+
let root = Pager.allocate pager in
12
+
let page_size = Pager.page_size pager in
13
+
let buf = Page.init ~page_size ~page_type:Page.Leaf_table in
14
+
Pager.write pager root (Bytes.unsafe_to_string buf);
15
+
{ pager; root_page = root }
16
+
17
+
let open_ pager ~root_page = { pager; root_page }
18
+
let root_page t = t.root_page
19
+
let usable_size t = Pager.page_size t.pager
20
+
21
+
(* Calculate free space in a page *)
22
+
let free_space header ~page_type =
23
+
let header_size = Page.header_size page_type in
24
+
let ptr_area_end = header_size + (header.Page.cell_count * 2) in
25
+
header.Page.cell_content_start - ptr_area_end - header.Page.fragmented_bytes
26
+
27
+
(* Encode a table leaf cell *)
28
+
let encode_table_leaf_cell ~rowid ~data =
29
+
let rowid_varint = Varint.encode rowid in
30
+
let payload_size_varint = Varint.encode (Int64.of_int (String.length data)) in
31
+
let cell =
32
+
Bytes.create
33
+
(String.length payload_size_varint
34
+
+ String.length rowid_varint + String.length data)
35
+
in
36
+
Bytes.blit_string payload_size_varint 0 cell 0
37
+
(String.length payload_size_varint);
38
+
Bytes.blit_string rowid_varint 0 cell
39
+
(String.length payload_size_varint)
40
+
(String.length rowid_varint);
41
+
Bytes.blit_string data 0 cell
42
+
(String.length payload_size_varint + String.length rowid_varint)
43
+
(String.length data);
44
+
Bytes.unsafe_to_string cell
45
+
46
+
(* Encode a table interior cell *)
47
+
let encode_table_interior_cell ~left_child ~rowid =
48
+
let rowid_varint = Varint.encode rowid in
49
+
let cell = Bytes.create (4 + String.length rowid_varint) in
50
+
Page.set_u32_be cell 0 left_child;
51
+
Bytes.blit_string rowid_varint 0 cell 4 (String.length rowid_varint);
52
+
Bytes.unsafe_to_string cell
53
+
54
+
(* Write a cell into a page buffer, returns new cell_content_start *)
55
+
let write_cell buf ~cell_content_start ~cell =
56
+
let cell_len = String.length cell in
57
+
let new_start = cell_content_start - cell_len in
58
+
Bytes.blit_string cell 0 buf new_start cell_len;
59
+
new_start
60
+
61
+
(* Insert a cell pointer at index, shifting others *)
62
+
let insert_cell_pointer buf ~header_offset ~page_type ~cell_count ~index ~ptr =
63
+
let ptr_start = header_offset + Page.header_size page_type in
64
+
(* Shift existing pointers right *)
65
+
for i = cell_count - 1 downto index do
66
+
let old_ptr =
67
+
Page.get_u16_be (Bytes.unsafe_to_string buf) (ptr_start + (i * 2))
68
+
in
69
+
Page.set_u16_be buf (ptr_start + ((i + 1) * 2)) old_ptr
70
+
done;
71
+
Page.set_u16_be buf (ptr_start + (index * 2)) ptr
72
+
73
+
(* Binary search for rowid in leaf page *)
74
+
let search_leaf t page header rowid =
75
+
let ptrs = Page.cell_pointers page 0 header in
76
+
let usable = usable_size t in
77
+
let rec loop lo hi =
78
+
if lo > hi then None
79
+
else
80
+
let mid = (lo + hi) / 2 in
81
+
let cell, _ = Cell.parse_table_leaf page ptrs.(mid) ~usable_size:usable in
82
+
if cell.Cell.rowid = rowid then Some cell.Cell.payload
83
+
else if cell.Cell.rowid < rowid then loop (mid + 1) hi
84
+
else loop lo (mid - 1)
85
+
in
86
+
loop 0 (header.Page.cell_count - 1)
87
+
88
+
(* Find insertion index for rowid in leaf page *)
89
+
let find_insert_idx t page header rowid =
90
+
let ptrs = Page.cell_pointers page 0 header in
91
+
let usable = usable_size t in
92
+
let rec find i =
93
+
if i >= header.Page.cell_count then i
94
+
else
95
+
let cell, _ = Cell.parse_table_leaf page ptrs.(i) ~usable_size:usable in
96
+
if rowid < cell.Cell.rowid then i else find (i + 1)
97
+
in
98
+
find 0
99
+
100
+
(* Find child page for rowid in interior page.
101
+
SQLite B-tree: keys < separator go left, keys >= separator go right. *)
102
+
let find_child _t page header rowid =
103
+
let ptrs = Page.cell_pointers page 0 header in
104
+
let rec loop i =
105
+
if i >= header.Page.cell_count then Option.get header.Page.right_child
106
+
else
107
+
let cell, _ = Cell.parse_table_interior page ptrs.(i) in
108
+
if rowid < cell.Cell.rowid then cell.Cell.left_child else loop (i + 1)
109
+
in
110
+
loop 0
111
+
112
+
(* Find child index for rowid in interior page *)
113
+
let find_child_idx page header rowid =
114
+
let ptrs = Page.cell_pointers page 0 header in
115
+
let rec loop i =
116
+
if i >= header.Page.cell_count then i (* right child *)
117
+
else
118
+
let cell, _ = Cell.parse_table_interior page ptrs.(i) in
119
+
if rowid < cell.Cell.rowid then i else loop (i + 1)
120
+
in
121
+
loop 0
122
+
123
+
let rec find_in_page t page_num rowid =
124
+
let page = Pager.read t.pager page_num in
125
+
let header = Page.parse_header page 0 in
126
+
match header.Page.page_type with
127
+
| Page.Leaf_table -> search_leaf t page header rowid
128
+
| Page.Interior_table ->
129
+
let child = find_child t page header rowid in
130
+
find_in_page t child rowid
131
+
| _ -> failwith "Invalid page type in table B-tree"
132
+
133
+
let find t rowid = find_in_page t t.root_page rowid
134
+
135
+
(* Split result: new page number and separator rowid *)
136
+
type split_result = { new_page : int; separator_rowid : int64 }
137
+
138
+
(* Split a leaf page, returns info about the new page *)
139
+
let split_leaf t page_num =
140
+
let page = Pager.read t.pager page_num in
141
+
let header = Page.parse_header page 0 in
142
+
let ptrs = Page.cell_pointers page 0 header in
143
+
let usable = usable_size t in
144
+
let page_size = Pager.page_size t.pager in
145
+
146
+
(* Find split point (middle) *)
147
+
let split_idx = header.Page.cell_count / 2 in
148
+
149
+
(* Get separator rowid (first key that goes to right page) *)
150
+
let sep_cell, _ =
151
+
Cell.parse_table_leaf page ptrs.(split_idx) ~usable_size:usable
152
+
in
153
+
let separator_rowid = sep_cell.Cell.rowid in
154
+
155
+
(* Create new right page *)
156
+
let new_page_num = Pager.allocate t.pager in
157
+
let new_buf = Page.init ~page_size ~page_type:Page.Leaf_table in
158
+
159
+
(* Copy cells [split_idx..cell_count-1] to new page *)
160
+
let new_cell_content_start = ref page_size in
161
+
for i = split_idx to header.Page.cell_count - 1 do
162
+
let cell_off = ptrs.(i) in
163
+
let cell, cell_len =
164
+
Cell.parse_table_leaf page cell_off ~usable_size:usable
165
+
in
166
+
let cell_data =
167
+
encode_table_leaf_cell ~rowid:cell.Cell.rowid ~data:cell.Cell.payload
168
+
in
169
+
new_cell_content_start :=
170
+
write_cell new_buf ~cell_content_start:!new_cell_content_start
171
+
~cell:cell_data;
172
+
let new_idx = i - split_idx in
173
+
let ptr_off = Page.header_size Page.Leaf_table + (new_idx * 2) in
174
+
Page.set_u16_be new_buf ptr_off !new_cell_content_start;
175
+
ignore cell_len
176
+
done;
177
+
let new_cell_count = header.Page.cell_count - split_idx in
178
+
Page.set_u16_be new_buf 3 new_cell_count;
179
+
Page.set_u16_be new_buf 5 !new_cell_content_start;
180
+
Pager.write t.pager new_page_num (Bytes.unsafe_to_string new_buf);
181
+
182
+
(* Update original page to only have cells [0..split_idx-1] *)
183
+
let old_buf = Bytes.of_string page in
184
+
Page.set_u16_be old_buf 3 split_idx;
185
+
(* Recalculate cell content start for remaining cells *)
186
+
if split_idx > 0 then begin
187
+
let min_ptr = ref page_size in
188
+
for i = 0 to split_idx - 1 do
189
+
if ptrs.(i) < !min_ptr then min_ptr := ptrs.(i)
190
+
done;
191
+
Page.set_u16_be old_buf 5 !min_ptr
192
+
end
193
+
else Page.set_u16_be old_buf 5 page_size;
194
+
Pager.write t.pager page_num (Bytes.unsafe_to_string old_buf);
195
+
196
+
{ new_page = new_page_num; separator_rowid }
197
+
198
+
(* Split an interior page *)
199
+
let split_interior t page_num =
200
+
let page = Pager.read t.pager page_num in
201
+
let header = Page.parse_header page 0 in
202
+
let ptrs = Page.cell_pointers page 0 header in
203
+
let page_size = Pager.page_size t.pager in
204
+
205
+
(* Split point - middle cell becomes separator, doesn't go to either page *)
206
+
let split_idx = header.Page.cell_count / 2 in
207
+
let sep_cell, _ = Cell.parse_table_interior page ptrs.(split_idx) in
208
+
let separator_rowid = sep_cell.Cell.rowid in
209
+
210
+
(* Create new right page *)
211
+
let new_page_num = Pager.allocate t.pager in
212
+
let new_buf = Page.init ~page_size ~page_type:Page.Interior_table in
213
+
214
+
(* The right child of split cell becomes the left-most child of new page *)
215
+
(* Cells [split_idx+1..cell_count-1] go to new page *)
216
+
let new_cell_content_start = ref page_size in
217
+
for i = split_idx + 1 to header.Page.cell_count - 1 do
218
+
let cell_off = ptrs.(i) in
219
+
let cell, _ = Cell.parse_table_interior page cell_off in
220
+
let cell_data =
221
+
encode_table_interior_cell ~left_child:cell.Cell.left_child
222
+
~rowid:cell.Cell.rowid
223
+
in
224
+
new_cell_content_start :=
225
+
write_cell new_buf ~cell_content_start:!new_cell_content_start
226
+
~cell:cell_data;
227
+
let new_idx = i - split_idx - 1 in
228
+
let ptr_off = Page.header_size Page.Interior_table + (new_idx * 2) in
229
+
Page.set_u16_be new_buf ptr_off !new_cell_content_start
230
+
done;
231
+
let new_cell_count = header.Page.cell_count - split_idx - 1 in
232
+
Page.set_u16_be new_buf 3 new_cell_count;
233
+
Page.set_u16_be new_buf 5 !new_cell_content_start;
234
+
(* Right child of new page is same as original *)
235
+
Page.set_u32_be new_buf 8 (Option.get header.Page.right_child);
236
+
Pager.write t.pager new_page_num (Bytes.unsafe_to_string new_buf);
237
+
238
+
(* Update original page: keep cells [0..split_idx-1], right child = sep_cell.left_child *)
239
+
let old_buf = Bytes.of_string page in
240
+
Page.set_u16_be old_buf 3 split_idx;
241
+
Page.set_u32_be old_buf 8 sep_cell.Cell.left_child;
242
+
if split_idx > 0 then begin
243
+
let min_ptr = ref page_size in
244
+
for i = 0 to split_idx - 1 do
245
+
if ptrs.(i) < !min_ptr then min_ptr := ptrs.(i)
246
+
done;
247
+
Page.set_u16_be old_buf 5 !min_ptr
248
+
end
249
+
else Page.set_u16_be old_buf 5 page_size;
250
+
Pager.write t.pager page_num (Bytes.unsafe_to_string old_buf);
251
+
252
+
{ new_page = new_page_num; separator_rowid }
253
+
254
+
(* Insert a separator into an interior page, potentially splitting *)
255
+
let rec insert_into_interior t page_num ~left_child ~separator_rowid
256
+
~right_child =
257
+
let page = Pager.read t.pager page_num in
258
+
let header = Page.parse_header page 0 in
259
+
let cell = encode_table_interior_cell ~left_child ~rowid:separator_rowid in
260
+
let cell_len = String.length cell in
261
+
let space_needed = cell_len + 2 in
262
+
(* cell + pointer *)
263
+
264
+
if free_space header ~page_type:Page.Interior_table >= space_needed then begin
265
+
(* Fits - insert directly *)
266
+
let buf = Bytes.of_string page in
267
+
let ptrs = Page.cell_pointers page 0 header in
268
+
269
+
(* Find insert position *)
270
+
let insert_idx =
271
+
let rec find i =
272
+
if i >= header.Page.cell_count then i
273
+
else
274
+
let c, _ = Cell.parse_table_interior page ptrs.(i) in
275
+
if separator_rowid < c.Cell.rowid then i else find (i + 1)
276
+
in
277
+
find 0
278
+
in
279
+
280
+
(* Write cell *)
281
+
let cell_start =
282
+
write_cell buf ~cell_content_start:header.Page.cell_content_start ~cell
283
+
in
284
+
Page.set_u16_be buf 5 cell_start;
285
+
286
+
(* Insert pointer *)
287
+
insert_cell_pointer buf ~header_offset:0 ~page_type:Page.Interior_table
288
+
~cell_count:header.Page.cell_count ~index:insert_idx ~ptr:cell_start;
289
+
290
+
(* Update cell count *)
291
+
Page.set_u16_be buf 3 (header.Page.cell_count + 1);
292
+
293
+
(* Update child pointers: the cell we displaced (now at insert_idx+1)
294
+
needs its left_child updated to right_child, OR if we inserted at end,
295
+
update the page's right_child. *)
296
+
if insert_idx < header.Page.cell_count then begin
297
+
(* Update the displaced cell's left_child to right_child *)
298
+
let ptr_start = Page.header_size Page.Interior_table in
299
+
let displaced_ptr =
300
+
Page.get_u16_be
301
+
(Bytes.unsafe_to_string buf)
302
+
(ptr_start + ((insert_idx + 1) * 2))
303
+
in
304
+
Page.set_u32_be buf displaced_ptr right_child
305
+
end
306
+
else Page.set_u32_be buf 8 right_child;
307
+
308
+
Pager.write t.pager page_num (Bytes.unsafe_to_string buf);
309
+
None
310
+
end
311
+
else begin
312
+
(* Need to split interior page *)
313
+
let split = split_interior t page_num in
314
+
315
+
(* Determine which page gets the new separator *)
316
+
if separator_rowid < split.separator_rowid then begin
317
+
(* Insert into left (original) page *)
318
+
ignore
319
+
(insert_into_interior t page_num ~left_child ~separator_rowid
320
+
~right_child)
321
+
end
322
+
else begin
323
+
(* Insert into right (new) page *)
324
+
ignore
325
+
(insert_into_interior t split.new_page ~left_child ~separator_rowid
326
+
~right_child)
327
+
end;
328
+
329
+
(* Return split info to propagate up *)
330
+
Some { split with separator_rowid = split.separator_rowid }
331
+
end
332
+
333
+
(* Insert into a leaf page, potentially splitting *)
334
+
let rec insert_into_leaf t page_num ~rowid ~data ~parent_stack =
335
+
let page = Pager.read t.pager page_num in
336
+
let header = Page.parse_header page 0 in
337
+
let cell = encode_table_leaf_cell ~rowid ~data in
338
+
let cell_len = String.length cell in
339
+
let space_needed = cell_len + 2 in
340
+
(* cell + pointer *)
341
+
342
+
if free_space header ~page_type:Page.Leaf_table >= space_needed then begin
343
+
(* Fits - insert directly *)
344
+
let buf = Bytes.of_string page in
345
+
let insert_idx = find_insert_idx t page header rowid in
346
+
347
+
(* Write cell *)
348
+
let cell_start =
349
+
write_cell buf ~cell_content_start:header.Page.cell_content_start ~cell
350
+
in
351
+
Page.set_u16_be buf 5 cell_start;
352
+
353
+
(* Insert pointer *)
354
+
insert_cell_pointer buf ~header_offset:0 ~page_type:Page.Leaf_table
355
+
~cell_count:header.Page.cell_count ~index:insert_idx ~ptr:cell_start;
356
+
357
+
(* Update cell count *)
358
+
Page.set_u16_be buf 3 (header.Page.cell_count + 1);
359
+
360
+
Pager.write t.pager page_num (Bytes.unsafe_to_string buf)
361
+
end
362
+
else begin
363
+
(* Need to split *)
364
+
let split = split_leaf t page_num in
365
+
366
+
(* Determine target page and insert directly (no recursion needed -
367
+
after split, both pages have ~half capacity, plenty of room) *)
368
+
let target_page =
369
+
if rowid < split.separator_rowid then page_num else split.new_page
370
+
in
371
+
let target = Pager.read t.pager target_page in
372
+
let target_header = Page.parse_header target 0 in
373
+
let target_buf = Bytes.of_string target in
374
+
let insert_idx = find_insert_idx t target target_header rowid in
375
+
let cell_start =
376
+
write_cell target_buf
377
+
~cell_content_start:target_header.Page.cell_content_start ~cell
378
+
in
379
+
Page.set_u16_be target_buf 5 cell_start;
380
+
insert_cell_pointer target_buf ~header_offset:0 ~page_type:Page.Leaf_table
381
+
~cell_count:target_header.Page.cell_count ~index:insert_idx
382
+
~ptr:cell_start;
383
+
Page.set_u16_be target_buf 3 (target_header.Page.cell_count + 1);
384
+
Pager.write t.pager target_page (Bytes.unsafe_to_string target_buf);
385
+
386
+
(* Propagate split up *)
387
+
propagate_split t ~parent_stack ~left_page:page_num
388
+
~separator_rowid:split.separator_rowid ~right_page:split.new_page
389
+
end
390
+
391
+
and propagate_split t ~parent_stack ~left_page ~separator_rowid ~right_page =
392
+
match parent_stack with
393
+
| [] ->
394
+
(* Splitting root - create new root *)
395
+
let page_size = Pager.page_size t.pager in
396
+
let new_root = Pager.allocate t.pager in
397
+
let buf = Page.init ~page_size ~page_type:Page.Interior_table in
398
+
399
+
(* Single cell pointing to left page *)
400
+
let cell =
401
+
encode_table_interior_cell ~left_child:left_page ~rowid:separator_rowid
402
+
in
403
+
let cell_start = write_cell buf ~cell_content_start:page_size ~cell in
404
+
Page.set_u16_be buf 5 cell_start;
405
+
Page.set_u16_be buf (Page.header_size Page.Interior_table) cell_start;
406
+
Page.set_u16_be buf 3 1;
407
+
Page.set_u32_be buf 8 right_page;
408
+
409
+
Pager.write t.pager new_root (Bytes.unsafe_to_string buf);
410
+
t.root_page <- new_root
411
+
| parent_page :: rest -> (
412
+
match
413
+
insert_into_interior t parent_page ~left_child:left_page
414
+
~separator_rowid ~right_child:right_page
415
+
with
416
+
| None -> () (* Fit in parent *)
417
+
| Some split ->
418
+
(* Parent also split, propagate up *)
419
+
propagate_split t ~parent_stack:rest ~left_page:parent_page
420
+
~separator_rowid:split.separator_rowid ~right_page:split.new_page)
421
+
422
+
(* Main insert - traverses tree and handles splits *)
423
+
let insert t ~rowid data =
424
+
let rec traverse page_num parent_stack =
425
+
let page = Pager.read t.pager page_num in
426
+
let header = Page.parse_header page 0 in
427
+
match header.Page.page_type with
428
+
| Page.Leaf_table -> insert_into_leaf t page_num ~rowid ~data ~parent_stack
429
+
| Page.Interior_table ->
430
+
let child_idx = find_child_idx page header rowid in
431
+
let child_page =
432
+
if child_idx >= header.Page.cell_count then
433
+
Option.get header.Page.right_child
434
+
else
435
+
let ptrs = Page.cell_pointers page 0 header in
436
+
let cell, _ = Cell.parse_table_interior page ptrs.(child_idx) in
437
+
cell.Cell.left_child
438
+
in
439
+
traverse child_page (page_num :: parent_stack)
440
+
| _ -> failwith "Invalid page type in table B-tree"
441
+
in
442
+
traverse t.root_page []
443
+
444
+
let delete _t _rowid = failwith "Delete not yet implemented"
445
+
446
+
let iter t f =
447
+
let rec iter_page page_num =
448
+
let page = Pager.read t.pager page_num in
449
+
let header = Page.parse_header page 0 in
450
+
let ptrs = Page.cell_pointers page 0 header in
451
+
let usable = usable_size t in
452
+
match header.Page.page_type with
453
+
| Page.Leaf_table ->
454
+
for i = 0 to header.Page.cell_count - 1 do
455
+
let cell, _ =
456
+
Cell.parse_table_leaf page ptrs.(i) ~usable_size:usable
457
+
in
458
+
f cell.Cell.rowid cell.Cell.payload
459
+
done
460
+
| Page.Interior_table ->
461
+
for i = 0 to header.Page.cell_count - 1 do
462
+
let cell, _ = Cell.parse_table_interior page ptrs.(i) in
463
+
iter_page cell.Cell.left_child
464
+
done;
465
+
Option.iter iter_page header.Page.right_child
466
+
| _ -> failwith "Invalid page type"
467
+
in
468
+
iter_page t.root_page
469
+
470
+
let fold t ~init ~f =
471
+
let acc = ref init in
472
+
iter t (fun rowid data -> acc := f rowid data !acc);
473
+
!acc
+48
lib/varint.ml
+48
lib/varint.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SQLite-style variable-length integer encoding. *)
7
+
8
+
let decode buf off =
9
+
let rec loop acc shift i =
10
+
if i >= String.length buf then (acc, i - off)
11
+
else
12
+
let byte = Char.code buf.[i] in
13
+
let value = Int64.of_int (byte land 0x7f) in
14
+
let acc = Int64.logor acc (Int64.shift_left value shift) in
15
+
if byte land 0x80 = 0 then (acc, i - off + 1)
16
+
else if shift >= 56 then
17
+
(* 9th byte - use all 8 bits *)
18
+
let byte9 = Char.code buf.[i + 1] in
19
+
let acc = Int64.logor acc (Int64.shift_left (Int64.of_int byte9) 56) in
20
+
(acc, i - off + 2)
21
+
else loop acc (shift + 7) (i + 1)
22
+
in
23
+
loop 0L 0 off
24
+
25
+
let size n =
26
+
if n < 0L then 9
27
+
else if n < 128L then 1
28
+
else if n < 16384L then 2
29
+
else if n < 2097152L then 3
30
+
else if n < 268435456L then 4
31
+
else if n < 34359738368L then 5
32
+
else if n < 4398046511104L then 6
33
+
else if n < 562949953421312L then 7
34
+
else if n < 72057594037927936L then 8
35
+
else 9
36
+
37
+
let encode n =
38
+
let sz = size n in
39
+
let buf = Bytes.create sz in
40
+
let rec loop n i =
41
+
if i = sz - 1 then Bytes.set_uint8 buf i (Int64.to_int n land 0x7f)
42
+
else begin
43
+
Bytes.set_uint8 buf i (Int64.to_int n land 0x7f lor 0x80);
44
+
loop (Int64.shift_right_logical n 7) (i + 1)
45
+
end
46
+
in
47
+
loop n 0;
48
+
Bytes.unsafe_to_string buf
+8
-7
test/test_btree.ml
+8
-7
test/test_btree.ml
···
110
110
(* cell content start = 0x0f00 *)
111
111
Bytes.set_uint8 page 7 0;
112
112
(* fragmented = 0 *)
113
-
let header = Btree.parse_page_header (Bytes.unsafe_to_string page) 0 in
114
-
Alcotest.(check int) "cell_count" 5 header.cell_count;
115
-
Alcotest.(check int) "cell_content_start" 0x0f00 header.cell_content_start;
113
+
let header = Btree.Page.parse_header (Bytes.unsafe_to_string page) 0 in
114
+
Alcotest.(check int) "cell_count" 5 header.Btree.Page.cell_count;
115
+
Alcotest.(check int)
116
+
"cell_content_start" 0x0f00 header.Btree.Page.cell_content_start;
116
117
Alcotest.(check bool)
117
118
"no right_child" true
118
-
(Option.is_none header.right_child)
119
+
(Option.is_none header.Btree.Page.right_child)
119
120
120
121
let test_page_header_interior () =
121
122
let page = Bytes.create 4096 in
···
133
134
Bytes.set_uint8 page 9 0;
134
135
Bytes.set_uint8 page 10 0;
135
136
Bytes.set_uint8 page 11 42;
136
-
let header = Btree.parse_page_header (Bytes.unsafe_to_string page) 0 in
137
-
Alcotest.(check int) "cell_count" 3 header.cell_count;
138
-
match header.right_child with
137
+
let header = Btree.Page.parse_header (Bytes.unsafe_to_string page) 0 in
138
+
Alcotest.(check int) "cell_count" 3 header.Btree.Page.cell_count;
139
+
match header.Btree.Page.right_child with
139
140
| Some n -> Alcotest.(check int) "right_child" 42 n
140
141
| None -> Alcotest.fail "expected right_child"
141
142