Source file default.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
(** default[1] negotiator implementation
[1] "default" as defined in the canonical git implementation in C,
see https://github.com/git/git/tree/master/negotiator *)
open Sigs
type ('k, 'p, 't) psq =
(module Psq.S with type k = 'k and type p = 'p and type t = 't)
type ('uid, 'g, 's) parents =
'uid ->
('uid, 'uid * int ref * int64, 'g) store ->
(('uid * int ref * int64) list, 's) io
type 'uid t =
| State : {
mutable rev_list : 'psq;
psq : ('uid, 'uid * int ref * int64, 'psq) psq;
mutable non_common_revs : int;
}
-> 'uid t
let _common = 1 lsl 2
let _common_ref = 1 lsl 3
let _seen = 1 lsl 4
let _popped = 1 lsl 5
let make : type uid. compare:(uid -> uid -> int) -> uid t =
fun ~compare ->
let module K = struct
type t = uid
let compare = compare
end in
let module P = struct
type t = uid * int ref * int64
let compare (_, _, a) (_, _, b) = Int64.compare b a
end in
let module Psq = Psq.Make (K) (P) in
let rev_list = Psq.empty in
let non_common_revs = 0 in
State { rev_list; psq = (module Psq); non_common_revs }
let rev_list_push : type uid. uid t -> uid * int ref * int64 -> int -> unit =
fun (State ({ rev_list; psq = (module Psq); non_common_revs } as state))
(uid, p, ts) mark ->
if !p land mark = 0 then p := !p lor mark;
state.rev_list <- Psq.add uid (uid, p, ts) rev_list;
if !p land _common = 0 then state.non_common_revs <- non_common_revs + 1
let rec mark_common :
type g s uid.
s scheduler ->
parents:(uid, g, s) parents ->
(uid, uid * int ref * int64, g) store ->
uid t ->
uid * int ref * int64 ->
bool ->
(unit, s) io =
fun ({ bind; return } as scheduler) ~parents store
(State ({ non_common_revs; _ } as state) as t) (uid, p, ts) only_ancestors ->
let ( >>= ) = bind in
if only_ancestors then p := !p lor _common;
if !p land _seen = 0 then (
rev_list_push t (uid, p, ts) _seen;
return ())
else (
if (not only_ancestors) && !p land _popped = 0 then
state.non_common_revs <- non_common_revs - 1;
parents uid store
>>=
let rec go = function
| [] -> return ()
| (uid, p, ts) :: rest ->
mark_common scheduler ~parents store t (uid, p, ts) false
>>= fun () -> go rest
in
go)
let known_common :
type g s uid.
s scheduler ->
parents:(uid, g, s) parents ->
(uid, uid * int ref * int64, g) store ->
uid t ->
uid * int ref * int64 ->
(unit, s) io =
fun ({ return; _ } as scheduler) ~parents store t (uid, p, ts) ->
if !p land _seen = 0 then (
rev_list_push t (uid, p, ts) (_common_ref lor _seen);
mark_common scheduler ~parents store t (uid, p, ts) true)
else return ()
let tip t obj = rev_list_push t obj _seen
let ack :
type g s uid.
s scheduler ->
parents:(uid, g, s) parents ->
(uid, uid * int ref * int64, g) store ->
uid t ->
uid * int ref * int64 ->
(bool, s) io =
fun ({ bind; return } as scheduler) ~parents store t (uid, p, ts) ->
let ( >>= ) = bind in
let res = not (!p land _common = 0) in
mark_common scheduler ~parents store t (uid, p, ts) false >>= fun () ->
return res
let get_rev :
type g s uid.
s scheduler ->
parents:(uid, g, s) parents ->
(uid, uid * int ref * int64, g) store ->
uid t ->
(uid option, s) io =
fun ({ bind; return } as scheduler) ~parents store
(State ({ psq = (module Psq); _ } as state) as t) ->
let ( >>= ) = bind in
let rec go () =
if state.non_common_revs = 0 || Psq.is_empty state.rev_list then return None
else
match Psq.pop state.rev_list with
| None -> return None
| Some ((uid, (_, p, _)), rev_list) ->
state.rev_list <- rev_list;
parents uid store >>= fun ps ->
p := !p lor _popped;
if !p land _common = 0 then
state.non_common_revs <- state.non_common_revs - 1;
let mark = ref 0 in
let res = ref (Some uid) in
if !p land _common <> 0 then (
mark := _common lor _seen;
res := None)
else if !p land _common_ref <> 0 then mark := _common lor _seen
else mark := _seen;
let rec loop = function
| [] -> ( match !res with None -> go () | Some _ as v -> return v)
| (uid, p, ts) :: rest ->
if !p land _seen = 0 then rev_list_push t (uid, p, ts) !mark;
if !mark land _common <> 0 then
mark_common scheduler ~parents store t (uid, p, ts) true
>>= fun () -> loop rest
else loop rest
in
loop ps
in
go ()
let next :
type g s uid.
s scheduler ->
parents:(uid, g, s) parents ->
(uid, uid * int ref * int64, g) store ->
uid t ->
(uid option, s) io =
fun scheduler ~parents store t -> get_rev scheduler ~parents store t