Source file allocator.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
open Rresult

type request = Request of {
    np : int ;
    mem : int ;
  }

type resource = Resource of {
    np : int ;
    mem : int ;
  }

type t = {
  np : int ;
  mem : int ;
  mutable current_np : int ;
  mutable current_mem : int ;
  mutable waiters : ((int * int) * resource Lwt.u) list ;
}

let create ~np ~mem = {
  np ; mem ;
  current_np = np ;
  current_mem = mem ;
  waiters = [] ;
}

let decr p ~np ~mem =
  p.current_np <- p.current_np - np ;
  p.current_mem <- p.current_mem - mem

let incr p ~np ~mem =
  p.current_np <- p.current_np + np ;
  p.current_mem <- p.current_mem + mem

let request p (Request { np ; mem }) =
  let np = min np p.np in
  if mem > p.mem then
    R.error_msgf
      "Bistro_engine.Allocator: asked more memory than available (%d against %d)"
      mem p.mem
    |> Lwt.return
  else
  if np <= p.current_np && mem <= p.current_mem then (
    decr p ~np ~mem ;
    Lwt.return (Ok (Resource { np ; mem }))
  )
  else (
    let t, u = Lwt.wait () in
    p.waiters <- ((np,mem), u) :: p.waiters ;
    Lwt.(t >|= R.ok)
  )

let release p (Resource { np ; mem }) =
  let rec wake_guys_up p = function
    | [] -> []
    | (((np, mem), u) as h) :: t ->
      if np <= p.current_np && mem <= p.current_mem then (
        decr p ~np ~mem ;
        Lwt.wakeup u (Resource { np ; mem }) ;
        if np = 0 || mem = 0 then t
        else wake_guys_up p t
      )
      else h :: (wake_guys_up p t)
  in
  incr p ~np ~mem ;
  p.waiters <- wake_guys_up p (List.sort (fun (x, _) (y,_) -> compare y x) p.waiters)