The unpac monorepo manager self-hosting as a monorepo using unpac
Merge pull request #81 from haesbaert/heapdec
Decouple Heap entries from ring size
authored by
Christiano Haesbaert
and committed by
GitHub
385bf2e1
2291cb27
+137
-88
+49
-15
lib/uring/heap.ml
+49
-15
lib/uring/heap.ml
···
28
28
29
29
(* Free-list allocator *)
30
30
type 'a t =
31
-
{ data: 'a entry array
31
+
{ mutable data: 'a entry array
32
32
(* Pool of potentially-empty data slots. Invariant: an unfreed pointer [p]
33
33
into this array is valid iff [free_tail_relation.(p) = slot_taken]. *)
34
34
; mutable free_head: ptr
35
-
; free_tail_relation: ptr array
35
+
; mutable free_tail_relation: ptr array
36
36
(* A linked list of pointers to free slots, with [free_head] being the first
37
37
element and [free_tail_relation] mapping each free slot to the next one.
38
38
Each entry [x] signals a state of the corresponding [data.(x)] slot:
···
66
66
in
67
67
{ data; free_head; free_tail_relation; in_use = 0 }
68
68
69
-
exception No_space
69
+
let in_use t = t.in_use
70
+
71
+
let is_released t = t.in_use < 0
72
+
73
+
let maybe_already_released t =
74
+
if is_released t then
75
+
invalid_arg "Heap already released!"
76
+
77
+
let release t =
78
+
if t.in_use > 0 then invalid_arg "Heap still in use!";
79
+
maybe_already_released t;
80
+
t.in_use <- -100;
81
+
t.free_head <- free_list_nil
82
+
83
+
(* Note: t must be full *)
84
+
let grow t =
85
+
maybe_already_released t;
86
+
if t.free_head <> free_list_nil then invalid_arg "Heap is not full";
87
+
let old_len = Array.length t.free_tail_relation in
88
+
if old_len = Sys.max_array_length then
89
+
invalid_arg "Heap at Sys.max_array_length already";
90
+
let new_len = min (max 64 (old_len * 2)) Sys.max_array_length in
91
+
(* Build new t.free_tail_relation, keep in sync with create() *)
92
+
let new_free_tail_relation =
93
+
Array.init new_len
94
+
(fun i ->
95
+
if i < old_len then
96
+
t.free_tail_relation.(i)
97
+
else succ i)
98
+
in
99
+
new_free_tail_relation.(new_len - 1) <- free_list_nil;
100
+
(* First element of enlarged array *)
101
+
let new_free_head = old_len in
102
+
(* Note: Keep in sync with create() *)
103
+
let new_data =
104
+
Array.init new_len
105
+
(fun i ->
106
+
if i < old_len then
107
+
t.data.(i)
108
+
else
109
+
Empty)
110
+
in
111
+
(* Commit *)
112
+
t.free_tail_relation <- new_free_tail_relation;
113
+
t.free_head <- new_free_head;
114
+
t.data <- new_data
70
115
71
116
let alloc t data ~extra_data =
117
+
if t.free_head = free_list_nil then grow t;
72
118
let ptr = t.free_head in
73
-
if ptr = free_list_nil then raise No_space;
74
119
let entry = Entry { data; extra_data; ptr } in
75
120
t.data.(ptr) <- entry;
76
-
77
121
(* Drop [ptr] from the free list. *)
78
122
let tail = t.free_tail_relation.(ptr) in
79
123
t.free_tail_relation.(ptr) <- slot_taken;
80
124
t.free_head <- tail;
81
125
t.in_use <- t.in_use + 1;
82
-
83
126
entry
84
127
85
128
let free t ptr =
···
109
152
110
153
datum
111
154
112
-
let in_use t = t.in_use
113
-
114
-
let release t =
115
-
if t.in_use > 0 then invalid_arg "Heap still in use!"
116
-
else if t.in_use < 0 then invalid_arg "Heap already released!";
117
-
t.in_use <- -100;
118
-
t.free_head <- free_list_nil
119
-
120
-
let is_released t = t.in_use < 0
+4
-5
lib/uring/heap.mli
+4
-5
lib/uring/heap.mli
···
30
30
(** [ptr e] is the index of [e].
31
31
@raise Invalid_arg if [e] has already been freed. *)
32
32
33
-
exception No_space
34
-
35
33
val alloc : 'a t -> 'a -> extra_data:'b -> 'a entry
36
-
(** [alloc t a ~extra_data] adds the value [a] to [t] and returns a pointer to that value,
37
-
or raises {!No_space} if no space exists in [t].
34
+
(** [alloc t a ~extra_data] adds the value [a] to [t] and returns a
35
+
pointer to that value, or raises {!Invalid_arg} if no extra space
36
+
can be created for [t], or [t] has already been [release]d.
38
37
@param extra_data Prevent this from being GC'd until [free] is called. *)
39
38
40
39
val free : 'a t -> ptr -> 'a
···
45
44
(** [in_use t] is the number of entries currently allocated. *)
46
45
47
46
val release : _ t -> unit
48
-
(**[ release t] marks [t] as unusable. Future operations on it will fail. [t] must be idle. *)
47
+
(** [release t] marks [t] as unusable. Future operations on it will fail. [t] must be idle. *)
49
48
50
49
val is_released : _ t -> bool
51
50
(** [is_released t] is [true] once {!release} has succeeded. *)
+10
-12
lib/uring/uring.ml
+10
-12
lib/uring/uring.ml
···
344
344
345
345
let with_id_full : type a. a t -> (Heap.ptr -> bool) -> a -> extra_data:'b -> a job option =
346
346
fun t fn datum ~extra_data ->
347
-
match Heap.alloc t.data datum ~extra_data with
348
-
| exception Heap.No_space ->
349
-
check t; (* Check if it's because we exited already. *)
350
-
None
347
+
match Heap.alloc t.data datum ~extra_data with
348
+
| exception (Invalid_argument _ as ex) -> check t; raise ex
351
349
| entry ->
352
-
let ptr = Heap.ptr entry in
353
-
let has_space = fn ptr in
354
-
if has_space then (
355
-
Some entry
356
-
) else (
357
-
ignore (Heap.free t.data ptr : a);
358
-
None
359
-
)
350
+
let ptr = Heap.ptr entry in
351
+
let has_space = fn ptr in
352
+
if has_space then
353
+
Some entry
354
+
else (
355
+
ignore (Heap.free t.data ptr : a);
356
+
None
357
+
)
360
358
361
359
let with_id t fn a = with_id_full t fn a ~extra_data:()
362
360
+43
-55
tests/heap.md
+43
-55
tests/heap.md
···
26
26
Test normal usage:
27
27
28
28
```ocaml
29
-
# let max_size = 10 in
30
-
let t = Heap.create max_size in
31
-
let reference : (Heap.ptr, int) Hashtbl.t = Hashtbl.create max_size in
29
+
# let initial_size = 10 in
30
+
let t = Heap.create initial_size in
31
+
let reference : (Heap.ptr, int) Hashtbl.t = Hashtbl.create initial_size in
32
32
let currently_allocated = ref 0 in
33
33
for _ = 1 to 100_000 do
34
34
let attempt_alloc = !currently_allocated = 0 || Random.bool () in
35
35
match attempt_alloc with
36
36
| true ->
37
-
if !currently_allocated = max_size then
38
-
try ignore (Heap.alloc t 0); assert false
39
-
with Heap.No_space -> ()
40
-
else
41
-
let data = Random.int 5000 in
42
-
let ptr = Heap.ptr (Heap.alloc t data) in
43
-
assert (not (Hashtbl.mem reference ptr));
44
-
Hashtbl.add reference ptr data;
45
-
incr currently_allocated
37
+
let data = Random.int 5000 in
38
+
let ptr = Heap.ptr (Heap.alloc t data) in
39
+
assert (not (Hashtbl.mem reference ptr));
40
+
Hashtbl.add reference ptr data;
41
+
incr currently_allocated
46
42
| false ->
47
43
let (k, v) = random_hashtbl_elt reference in
48
44
let v' = Heap.free t k in
49
45
Hashtbl.remove reference k;
50
46
assert (v = v');
51
47
decr currently_allocated
52
-
done;;
48
+
done;
49
+
Hashtbl.iter (fun k _ -> ignore (Heap.free t k)) reference;
50
+
Heap.release t;;
51
+
- : unit = ()
52
+
```
53
+
54
+
```ocaml
55
+
let shuffle_list l =
56
+
List.map (fun i -> Random.bits (), i) l |>
57
+
List.sort (fun a b -> compare (fst a) (fst b)) |>
58
+
List.map snd
59
+
```
60
+
61
+
```ocaml
62
+
# let t = Heap.create 0 in
63
+
let add_l = List.init 1024 (fun i -> i) |> shuffle_list in
64
+
assert (Heap.in_use t = 0);
65
+
let free_l = List.map (fun i -> Heap.alloc t i |> Heap.ptr) add_l |>
66
+
shuffle_list
67
+
in
68
+
assert (Heap.in_use t = 1024);
69
+
List.iter (fun p -> ignore (Heap.free t p)) free_l;
70
+
assert (Heap.in_use t = 0);
71
+
Heap.release t;;
53
72
- : unit = ()
54
73
```
55
74
···
64
83
- : int = 1
65
84
# Heap.free t p;;
66
85
Exception: Invalid_argument "Heap.free: pointer already freed".
86
+
# let t : unit = Heap.release t;;
87
+
val t : unit = ()
67
88
```
68
89
69
90
Double free in a non-empty heap:
···
71
92
```ocaml
72
93
# let t : int Heap.t = Heap.create 2;;;
73
94
val t : int Heap.t = <abstr>
74
-
# let p = Heap.ptr @@ Heap.alloc t 1;;;
75
-
val p : Heap.ptr = 0
76
-
# let _ = Heap.ptr @@ Heap.alloc t 2;;;
77
-
- : Heap.ptr = 1
78
-
# Heap.free t p;;
79
-
- : int = 1
80
-
# Heap.free t p;;
81
-
Exception: Invalid_argument "Heap.free: pointer already freed".
82
-
```
83
-
84
-
Out of space:
85
-
86
-
```ocaml
87
-
# let t : unit Heap.t = Heap.create 0 (* 1 > 0 *);;
88
-
val t : unit Heap.t = <abstr>
89
-
# Heap.ptr @@ Heap.alloc t ();;
90
-
Exception: Uring__Heap.No_space.
91
-
```
92
-
93
-
```ocaml
94
-
# let t : unit Heap.t = Heap.create 2;;
95
-
val t : unit Heap.t = <abstr>
96
-
# Heap.ptr @@ Heap.alloc t ();;
97
-
- : Heap.ptr = 0
98
-
# Heap.ptr @@ Heap.alloc t ();;
99
-
- : Heap.ptr = 1
100
-
# Heap.ptr @@ Heap.alloc t () (* 3 > 2 *);;
101
-
Exception: Uring__Heap.No_space.
102
-
```
103
-
104
-
```ocaml
105
-
# let t : int Heap.t = Heap.create 3;;
106
-
val t : int Heap.t = <abstr>
107
-
# let p1 = Heap.ptr @@ Heap.alloc t 1;;
95
+
# let p1 = Heap.ptr @@ Heap.alloc t 1;;;
108
96
val p1 : Heap.ptr = 0
109
-
# Heap.ptr @@ Heap.alloc t 2;;
110
-
- : Heap.ptr = 1
97
+
# let p2 = Heap.ptr @@ Heap.alloc t 2;;;
98
+
val p2 : Heap.ptr = 1
111
99
# Heap.free t p1;;
112
100
- : int = 1
113
-
# Heap.ptr @@ Heap.alloc t 3;;
114
-
- : Heap.ptr = 0
115
-
# Heap.ptr @@ Heap.alloc t 4;;
116
-
- : Heap.ptr = 2
117
-
# Heap.ptr @@ Heap.alloc t 5 (* 2 - 1 + 3 > 3 *);;
118
-
Exception: Uring__Heap.No_space.
101
+
# Heap.free t p1;;
102
+
Exception: Invalid_argument "Heap.free: pointer already freed".
103
+
# Heap.free t p2;;
104
+
- : int = 2
105
+
# let t : unit = Heap.release t;;
106
+
val t : unit = ()
119
107
```
+31
-1
tests/main.md
+31
-1
tests/main.md
···
25
25
Format.printf (fmt ^^ "@.")
26
26
```
27
27
28
-
## Invalid queue depth
28
+
## Queue depth
29
29
30
30
```ocaml
31
31
# Uring.create ~queue_depth:0 ();;
32
32
Exception: Invalid_argument "Non-positive queue depth: 0".
33
+
```
34
+
35
+
Prove we can wait more entries than queue depth
36
+
37
+
```ocaml
38
+
# let t : [ `Read ] Uring.t = Uring.create ~queue_depth:1 ();;
39
+
val t : [ `Read ] Uring.t = <abstr>
40
+
41
+
# let fd = Unix.openfile "/dev/zero" Unix.[O_RDONLY] 0;;
42
+
val fd : Unix.file_descr = <abstr>
43
+
# let b = Cstruct.create 1;;
44
+
val b : Cstruct.t = {Cstruct.buffer = <abstr>; off = 0; len = 1}
45
+
# Uring.read t fd b `Read ~file_offset:Int63.minus_one;;
46
+
- : [ `Read ] Uring.job option = Some <abstr>
47
+
# Uring.submit t;;
48
+
- : int = 1
49
+
# Uring.read t fd b `Read ~file_offset:Int63.minus_one;;
50
+
- : [ `Read ] Uring.job option = Some <abstr>
51
+
# Uring.read t fd b `Read ~file_offset:Int63.minus_one;;
52
+
- : [ `Read ] Uring.job option = None
53
+
# Uring.submit t;;
54
+
- : int = 1
55
+
# consume t;;
56
+
- : [ `Read ] * int = (`Read, 1)
57
+
# consume t;;
58
+
- : [ `Read ] * int = (`Read, 1)
59
+
# let fd : unit = Unix.close fd;;
60
+
val fd : unit = ()
61
+
# Uring.exit t;;
62
+
- : unit = ()
33
63
```
34
64
35
65
## Noop