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