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
open Lwt.Infix
module Bindings = Dlm_bindings.Bindings.Make(Generated)
let host = Errno_unix.host
let fail_errno ?(call="") ?(label="") errno =
let open Errno in
Errno_unix.to_unix_exn (Error {
errno = of_code ~host errno;
call; label;
}) |> Lwt.fail
let check_opt ?(call="") ?(label="") v =
v.Generated.lwt >>= function
| None, errno ->
if errno = Signed.SInt.zero then
Unix.Unix_error(Unix.ENOSYS, call, label) |> Lwt.fail
else
fail_errno ~call ~label errno
| Some result, _ -> Lwt.return result
let check_int ?call ?label v =
v.Generated.lwt >>= function
| 0, _ -> Lwt.return_unit
| -1, errno -> fail_errno ?call ?label errno
| v, _ -> Lwt.fail_with (Printf.sprintf "Unknown return value %d" v)
open Bindings
type t = dlm_lshandle_t
let open_ name =
check_opt ~call:"dlm_open_lockspace" ~label:name @@
dlm_open_lockspace name >>= fun ls ->
check_int ~call:"dlm_ls_pthread_init" ~label:name @@
dlm_ls_pthread_init ls >>= fun () ->
Lwt.return ls
let close ls =
check_int ~call:"dlm_close_lockspace" @@ dlm_close_lockspace ls
let default_mode =
PosixTypes.Mode.of_int 0o600
let create_destroy = Lwt_mutex.create ()
let join ?(mode=default_mode) name =
Lwt.catch (fun () ->
open_ name)
(function
| Unix.Unix_error _ ->
Lwt_mutex.with_lock create_destroy (fun () ->
check_opt ~call:"dlm_create_lockspace" ~label:name @@
dlm_create_lockspace name mode)
| e -> Lwt.fail e
) >>= close
let leave ?(force=false) name =
let force_int = if force then 1 else 0 in
open_ name >>= fun ls ->
Lwt_mutex.with_lock create_destroy (fun () ->
check_int ~call:"dlm_release_lockspace" ~label:name @@
dlm_release_lockspace name ls force_int)
let with_lockspace name ~f =
open_ name >>= fun ls ->
Lwt.finalize (fun () -> f ls) (fun () -> close ls)
open Ctypes
open Dlm_bindings.Bindings.Types
let (|||) a b = Unsigned.UInt32.logor a b
type mode =
| LKM_NLMODE
| LKM_CRMODE
| LKM_CWMODE
| LKM_PRMODE
| LKM_PWMODE
| LKM_EXMODE
let mode_to_const = function
| LKM_NLMODE -> Mode.lkm_nlmode
| LKM_CRMODE -> Mode.lkm_crmode
| LKM_CWMODE -> Mode.lkm_cwmode
| LKM_PRMODE -> Mode.lkm_prmode
| LKM_PWMODE -> Mode.lkm_pwmode
| LKM_EXMODE -> Mode.lkm_exmode
let with_lock ls ?(mode=LKM_EXMODE) ?(try_=false) ?timeout name ~f =
let open Dlm_lksb in
let t = make t in
setf t sb_status (-1);
setf t sb_lkid Unsigned.UInt32.zero;
setf t sb_flags '\x00';
setf t sb_lvbptr '\x00';
let do_lock mode flags timeout =
let timeout_ptr = match timeout with
| Some t ->
Some (allocate uint64_t (t *. 100. |>
Int64.of_float |>
Unsigned.UInt64.of_int64))
| None -> None
in
let t_orig = t in
let t= addr t in
check_int ~call:"dlm_ls_lockx" ~label:name @@
Bindings.dlm_ls_lockx ls (mode_to_const mode) t flags
name (String.length name |> Unsigned.UInt.of_int)
Unsigned.UInt32.zero
None
None
None
None
timeout_ptr >>= fun () ->
let status = (getf t_orig sb_status) in
if status <> 0 then
fail_errno ~call:"dlm_ls_lockx.sb_status" ~label:name (Signed.SInt.of_int status)
else
Lwt.return_unit
in
do_lock LKM_NLMODE Flags.(lkf_expedite ||| lkf_wait) None >>= fun () ->
Lwt.finalize (fun () ->
let flags = Flags.(lkf_wait ||| lkf_convert) in
let flags = if try_ then Flags.lkf_noqueue ||| flags else flags in
let flags = if timeout = None then flags else Flags.(flags ||| lkf_timeout) in
do_lock mode flags timeout >>= f)
(fun () ->
let lkid = (getf t sb_lkid) in
let t= addr t in
let zero = Unsigned.UInt32.zero in
check_int ~call:"dlm_ls_unlock_wait" ~label:name @@ Bindings.dlm_ls_unlock_wait ls lkid zero t)