diff --git a/src/camlp4/pa_lwt.ml b/src/camlp4/pa_lwt.ml index f660f4060b..047100f9bb 100644 --- a/src/camlp4/pa_lwt.ml +++ b/src/camlp4/pa_lwt.ml @@ -51,172 +51,172 @@ let gen_catch mc = let gen_binding l = let rec aux n = function | [] -> - assert false + assert false | [(_loc, _p, e)] -> - <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ >> + <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ >> | (_loc, _p, e) :: l -> - <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ and $aux (n + 1) l$ >> + <:binding< $lid:"__pa_lwt_" ^ string_of_int n$ = $e$ and $aux (n + 1) l$ >> in aux 0 l let gen_bind l e = let rec aux n = function | [] -> - e + e | (_loc, p, _e) :: l -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> - else - <:expr< Lwt.bind $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> + else + <:expr< Lwt.bind $lid:"__pa_lwt_" ^ string_of_int n$ (fun $p$ -> $aux (n + 1) l$) >> in aux 0 l let gen_top_bind _loc l = let rec aux n vars = function | [] -> - <:expr< Lwt.return ($tup:Ast.exCom_of_list (List.rev vars)$) >> + <:expr< Lwt.return ($tup:Ast.exCom_of_list (List.rev vars)$) >> | (_loc, _p, _e) :: l -> - let id = "__pa_lwt_" ^ string_of_int n in - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> - else - <:expr< Lwt.bind $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> + let id = "__pa_lwt_" ^ string_of_int n in + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> + else + <:expr< Lwt.bind $lid:id$ (fun $lid:id$ -> $aux (n + 1) (<:expr< $lid:id$ >> :: vars) l$) >> in aux 0 [] l EXTEND Gram GLOBAL: expr str_item; - cases: - [ [ "with"; c = match_case -> Some(gen_catch c) - | -> None ] ]; + cases: + [ [ "with"; c = match_case -> Some(gen_catch c) + | -> None ] ]; - finally: - [ [ "finally"; f = sequence -> Some f - | -> None ] ]; + finally: + [ [ "finally"; f = sequence -> Some f + | -> None ] ]; - letb_binding: - [ [ b1 = SELF; "and"; b2 = SELF -> b1 @ b2 - | p = patt; "="; e = expr -> [(_loc, p, e)] - ] ]; + letb_binding: + [ [ b1 = SELF; "and"; b2 = SELF -> b1 @ b2 + | p = patt; "="; e = expr -> [(_loc, p, e)] + ] ]; - for_scheme: - [ [ "="; s = sequence; "to"; e = sequence -> - `CountTo(s, e) - | "="; s = sequence; "downto"; e = sequence -> - `CountDownTo(s, e) - | "in"; e = sequence -> - `IterOver(e) ] ]; + for_scheme: + [ [ "="; s = sequence; "to"; e = sequence -> + `CountTo(s, e) + | "="; s = sequence; "downto"; e = sequence -> + `CountDownTo(s, e) + | "in"; e = sequence -> + `IterOver(e) ] ]; - expr: LEVEL "top" + expr: LEVEL "top" [ [ "try_lwt"; e = expr LEVEL ";"; c = cases; f = finally -> - begin match c, f with - | None, None -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) Lwt.fail >> - else - <:expr< Lwt.catch (fun () -> $e$) Lwt.fail >> - | Some c, None -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (function $c$) >> - else - <:expr< Lwt.catch (fun () -> $e$) (function $c$) >> - | None, Some f -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_finalize (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (fun () -> (begin $f$ end)) >> - else - <:expr< Lwt.finalize (fun () -> $e$) (fun () -> (begin $f$ end)) >> - | Some c, Some f -> - if !Pa_lwt_options.debug then - <:expr< Lwt.backtrace_try_bind (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) - (fun __pa_lwt_x -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) - (fun __pa_lwt_e -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) - >> - else - <:expr< Lwt.try_bind (fun () -> $e$) - (fun __pa_lwt_x -> Lwt.bind (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) - (fun __pa_lwt_e -> Lwt.bind (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) - >> - end + begin match c, f with + | None, None -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) Lwt.fail >> + else + <:expr< Lwt.catch (fun () -> $e$) Lwt.fail >> + | Some c, None -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (function $c$) >> + else + <:expr< Lwt.catch (fun () -> $e$) (function $c$) >> + | None, Some f -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_finalize (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) (fun () -> (begin $f$ end)) >> + else + <:expr< Lwt.finalize (fun () -> $e$) (fun () -> (begin $f$ end)) >> + | Some c, Some f -> + if !Pa_lwt_options.debug then + <:expr< Lwt.backtrace_try_bind (fun exn -> try raise exn with exn -> exn) (fun () -> $e$) + (fun __pa_lwt_x -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) + (fun __pa_lwt_e -> Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) + >> + else + <:expr< Lwt.try_bind (fun () -> $e$) + (fun __pa_lwt_x -> Lwt.bind (begin $f$ end) (fun () -> Lwt.return __pa_lwt_x)) + (fun __pa_lwt_e -> Lwt.bind (begin $f$ end) (fun () -> match __pa_lwt_e with $c$)) + >> + end | "lwt"; l = letb_binding; "in"; e = expr LEVEL ";" -> - <:expr< let $gen_binding l$ in $gen_bind l e$ >> + <:expr< let $gen_binding l$ in $gen_bind l e$ >> | "for_lwt"; p = patt; scheme = for_scheme; "do"; seq = do_sequence -> - (match p, scheme with - | <:patt< $lid:id$ >>, `CountTo(s, e) -> - <:expr< let __pa_lwt_max = $e$ in - let rec __pa_lwt_loop $lid:id$ = - if $lid:id$ > __pa_lwt_max then - Lwt.return () - else - Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ + 1)) - in - __pa_lwt_loop $s$ - >> - - | <:patt< $lid:id$ >>, `CountDownTo(s, e) -> - <:expr< let __pa_lwt_min = $e$ in - let rec __pa_lwt_loop $lid:id$ = - if $lid:id$ < __pa_lwt_min then - Lwt.return () - else - Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ - 1)) - in - __pa_lwt_loop $s$ - >> - - | p, `IterOver(e) -> - <:expr< Lwt_stream.iter_s (fun $p$ -> $seq$) $e$ >> - - | _ -> - Loc.raise _loc (Failure "syntax error")) + (match p, scheme with + | <:patt< $lid:id$ >>, `CountTo(s, e) -> + <:expr< let __pa_lwt_max = $e$ in + let rec __pa_lwt_loop $lid:id$ = + if $lid:id$ > __pa_lwt_max then + Lwt.return () + else + Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ + 1)) + in + __pa_lwt_loop $s$ + >> + + | <:patt< $lid:id$ >>, `CountDownTo(s, e) -> + <:expr< let __pa_lwt_min = $e$ in + let rec __pa_lwt_loop $lid:id$ = + if $lid:id$ < __pa_lwt_min then + Lwt.return () + else + Lwt.bind (begin $seq$ end) (fun () -> __pa_lwt_loop ($lid:id$ - 1)) + in + __pa_lwt_loop $s$ + >> + + | p, `IterOver(e) -> + <:expr< Lwt_stream.iter_s (fun $p$ -> $seq$) $e$ >> + + | _ -> + Loc.raise _loc (Failure "syntax error")) | "raise_lwt"; e = SELF -> - if !Pa_lwt_options.debug then - <:expr< Lwt.fail (try raise $e$ with exn -> exn) >> - else - <:expr< Lwt.fail $e$ >> + if !Pa_lwt_options.debug then + <:expr< Lwt.fail (try raise $e$ with exn -> exn) >> + else + <:expr< Lwt.fail $e$ >> | "assert_lwt"; e = SELF -> - <:expr< try Lwt.return (assert $e$) with exn -> Lwt.fail exn >> + <:expr< try Lwt.return (assert $e$) with exn -> Lwt.fail exn >> | "while_lwt"; cond = sequence; "do"; body = sequence; "done" -> - <:expr< - let rec __pa_lwt_loop () = - if $cond$ then - Lwt.bind (begin $body$ end) __pa_lwt_loop - else - Lwt.return () - in - __pa_lwt_loop () - >> + <:expr< + let rec __pa_lwt_loop () = + if $cond$ then + Lwt.bind (begin $body$ end) __pa_lwt_loop + else + Lwt.return () + in + __pa_lwt_loop () + >> | "match_lwt"; e = sequence; "with"; c = match_case -> - <:expr< - Lwt.bind (begin $e$ end) (function $c$) - >> - ] ]; - - str_item: - [ [ "lwt"; l = letb_binding -> begin - match l with - | [(_loc, p, e)] -> - <:str_item< - let $p$ = Lwt_main.run $e$ - >> - | _ -> - <:str_item< - let $tup:Ast.paCom_of_list (List.map (fun (_loc, p, _e) -> p) l)$ = - Lwt_main.run begin - let $gen_binding l$ in - $gen_top_bind _loc l$ - end - >> - end - | "lwt"; l = letb_binding; "in"; e = expr -> - <:str_item< let () = Lwt_main.run (let $gen_binding l$ in $gen_bind l e$) >> - ] ]; + <:expr< + Lwt.bind (begin $e$ end) (function $c$) + >> + ] ]; + + str_item: + [ [ "lwt"; l = letb_binding -> begin + match l with + | [(_loc, p, e)] -> + <:str_item< + let $p$ = Lwt_main.run $e$ + >> + | _ -> + <:str_item< + let $tup:Ast.paCom_of_list (List.map (fun (_loc, p, _e) -> p) l)$ = + Lwt_main.run begin + let $gen_binding l$ in + $gen_top_bind _loc l$ + end + >> + end + | "lwt"; l = letb_binding; "in"; e = expr -> + <:str_item< let () = Lwt_main.run (let $gen_binding l$ in $gen_bind l e$) >> + ] ]; END (* Replace the anonymous bind [x >> y] by [x >>= fun _ -> y] or [x >>= fun () -> @@ -225,10 +225,10 @@ let map_anonymous_bind = object inherit Ast.map as super method! expr e = match super#expr e with | <:expr@_loc< $lid:f$ $a$ $b$ >> when f = ">>" -> - if !Pa_lwt_options.strict_sequence then - <:expr< Lwt.bind $a$ (fun () -> $b$) >> - else - <:expr< Lwt.bind $a$ (fun _ -> $b$) >> + if !Pa_lwt_options.strict_sequence then + <:expr< Lwt.bind $a$ (fun () -> $b$) >> + else + <:expr< Lwt.bind $a$ (fun _ -> $b$) >> | e -> e end diff --git a/src/core/lwt_condition.ml b/src/core/lwt_condition.ml index 9656245baf..13569ea0e1 100644 --- a/src/core/lwt_condition.ml +++ b/src/core/lwt_condition.ml @@ -34,15 +34,15 @@ let wait ?mutex cvar = let waiter = Lwt.add_task_r cvar in let () = match mutex with - | Some m -> Lwt_mutex.unlock m - | None -> () + | Some m -> Lwt_mutex.unlock m + | None -> () in Lwt.finalize (fun () -> waiter) (fun () -> match mutex with - | Some m -> Lwt_mutex.lock m - | None -> Lwt.return_unit) + | Some m -> Lwt_mutex.lock m + | None -> Lwt.return_unit) let signal cvar arg = try diff --git a/src/core/lwt_list.ml b/src/core/lwt_list.ml index c1dcd57110..5d53dd905e 100644 --- a/src/core/lwt_list.ml +++ b/src/core/lwt_list.ml @@ -23,58 +23,58 @@ open Lwt.Infix let rec iter_s f l = match l with - | [] -> - Lwt.return_unit - | x :: l -> - f x >>= fun () -> - iter_s f l + | [] -> + Lwt.return_unit + | x :: l -> + f x >>= fun () -> + iter_s f l let rec iter_p f l = match l with - | [] -> - Lwt.return_unit - | x :: l -> - let tx = f x and tl = iter_p f l in - tx >>= fun () -> tl + | [] -> + Lwt.return_unit + | x :: l -> + let tx = f x and tl = iter_p f l in + tx >>= fun () -> tl let rec iteri_s i f l = match l with - | [] -> - Lwt.return_unit - | x :: l -> - f i x >>= fun () -> - iteri_s (i + 1) f l + | [] -> + Lwt.return_unit + | x :: l -> + f i x >>= fun () -> + iteri_s (i + 1) f l let iteri_s f l = iteri_s 0 f l let rec iteri_p i f l = match l with - | [] -> - Lwt.return_unit - | x :: l -> - let tx = f i x and tl = iteri_p (i + 1) f l in - tx >>= fun () -> tl + | [] -> + Lwt.return_unit + | x :: l -> + let tx = f i x and tl = iteri_p (i + 1) f l in + tx >>= fun () -> tl let iteri_p f l = iteri_p 0 f l let rec map_s f l = match l with - | [] -> - Lwt.return_nil - | x :: l -> - f x >>= fun x -> - map_s f l >|= fun l -> - x :: l + | [] -> + Lwt.return_nil + | x :: l -> + f x >>= fun x -> + map_s f l >|= fun l -> + x :: l let rec map_p f l = match l with - | [] -> - Lwt.return_nil - | x :: l -> - let tx = f x and tl = map_p f l in - tx >>= fun x -> - tl >|= fun l -> - x :: l + | [] -> + Lwt.return_nil + | x :: l -> + let tx = f x and tl = map_p f l in + tx >>= fun x -> + tl >|= fun l -> + x :: l let rec filter_map_s f l = match l with @@ -100,168 +100,168 @@ let rec filter_map_p f l = let rec mapi_s i f l = match l with - | [] -> - Lwt.return_nil - | x :: l -> - f i x >>= fun x -> - mapi_s (i + 1) f l >|= fun l -> - x :: l + | [] -> + Lwt.return_nil + | x :: l -> + f i x >>= fun x -> + mapi_s (i + 1) f l >|= fun l -> + x :: l let mapi_s f l = mapi_s 0 f l let rec mapi_p i f l = match l with - | [] -> - Lwt.return_nil - | x :: l -> - let tx = f i x and tl = mapi_p (i + 1) f l in - tx >>= fun x -> - tl >|= fun l -> - x :: l + | [] -> + Lwt.return_nil + | x :: l -> + let tx = f i x and tl = mapi_p (i + 1) f l in + tx >>= fun x -> + tl >|= fun l -> + x :: l let mapi_p f l = mapi_p 0 f l let rec rev_map_append_s acc f l = match l with - | [] -> - Lwt.return acc - | x :: l -> - f x >>= fun x -> - rev_map_append_s (x :: acc) f l + | [] -> + Lwt.return acc + | x :: l -> + f x >>= fun x -> + rev_map_append_s (x :: acc) f l let rev_map_s f l = rev_map_append_s [] f l let rec rev_map_append_p acc f l = match l with - | [] -> - acc - | x :: l -> - rev_map_append_p - (f x >>= fun x -> - acc >|= fun l -> - x :: l) f l + | [] -> + acc + | x :: l -> + rev_map_append_p + (f x >>= fun x -> + acc >|= fun l -> + x :: l) f l let rev_map_p f l = rev_map_append_p Lwt.return_nil f l let rec fold_left_s f acc l = match l with - | [] -> - Lwt.return acc - | x :: l -> - f acc x >>= fun acc -> - fold_left_s f acc l + | [] -> + Lwt.return acc + | x :: l -> + f acc x >>= fun acc -> + fold_left_s f acc l let rec fold_right_s f l acc = match l with - | [] -> - Lwt.return acc - | x :: l -> - fold_right_s f l acc >>= fun acc -> - f x acc + | [] -> + Lwt.return acc + | x :: l -> + fold_right_s f l acc >>= fun acc -> + f x acc let rec for_all_s f l = match l with - | [] -> - Lwt.return_true - | x :: l -> - f x >>= function - | true -> - for_all_s f l - | false -> - Lwt.return_false + | [] -> + Lwt.return_true + | x :: l -> + f x >>= function + | true -> + for_all_s f l + | false -> + Lwt.return_false let rec for_all_p f l = match l with - | [] -> - Lwt.return_true - | x :: l -> - let tx = f x and tl = for_all_p f l in - tx >>= fun bx -> - tl >|= fun bl -> - bx && bl + | [] -> + Lwt.return_true + | x :: l -> + let tx = f x and tl = for_all_p f l in + tx >>= fun bx -> + tl >|= fun bl -> + bx && bl let rec exists_s f l = match l with - | [] -> - Lwt.return_false - | x :: l -> - f x >>= function - | true -> - Lwt.return_true - | false -> - exists_s f l + | [] -> + Lwt.return_false + | x :: l -> + f x >>= function + | true -> + Lwt.return_true + | false -> + exists_s f l let rec exists_p f l = match l with - | [] -> - Lwt.return_false - | x :: l -> - let tx = f x and tl = exists_p f l in - tx >>= fun bx -> - tl >|= fun bl -> - bx || bl + | [] -> + Lwt.return_false + | x :: l -> + let tx = f x and tl = exists_p f l in + tx >>= fun bx -> + tl >|= fun bl -> + bx || bl let rec find_s f l = match l with - | [] -> - Lwt.fail Not_found - | x :: l -> - f x >>= function - | true -> - Lwt.return x - | false -> - find_s f l + | [] -> + Lwt.fail Not_found + | x :: l -> + f x >>= function + | true -> + Lwt.return x + | false -> + find_s f l let rec filter_s f l = match l with - | [] -> - Lwt.return_nil - | x :: l -> - f x >>= function - | true -> - filter_s f l >|= fun l -> - x :: l - | false -> - filter_s f l + | [] -> + Lwt.return_nil + | x :: l -> + f x >>= function + | true -> + filter_s f l >|= fun l -> + x :: l + | false -> + filter_s f l let rec filter_p f l = match l with - | [] -> - Lwt.return_nil - | x :: l -> - let tx = f x and tl = filter_p f l in - tx >>= fun bx -> - tl >|= fun l -> - if bx then - x :: l - else - l + | [] -> + Lwt.return_nil + | x :: l -> + let tx = f x and tl = filter_p f l in + tx >>= fun bx -> + tl >|= fun l -> + if bx then + x :: l + else + l let return_nil_nil = Lwt.return ([], []) let rec partition_s f l = match l with - | [] -> - return_nil_nil - | x :: l -> - f x >>= fun bx -> - partition_s f l >|= fun (l_l, l_r) -> - if bx then - (x :: l_l, l_r) - else - (l_l, x :: l_r) + | [] -> + return_nil_nil + | x :: l -> + f x >>= fun bx -> + partition_s f l >|= fun (l_l, l_r) -> + if bx then + (x :: l_l, l_r) + else + (l_l, x :: l_r) let rec partition_p f l = match l with - | [] -> - return_nil_nil - | x :: l -> - let tx = f x and tl = partition_p f l in - tx >>= fun bx -> - tl >|= fun (l_l, l_r) -> - if bx then - (x :: l_l, l_r) - else - (l_l, x :: l_r) + | [] -> + return_nil_nil + | x :: l -> + let tx = f x and tl = partition_p f l in + tx >>= fun bx -> + tl >|= fun (l_l, l_r) -> + if bx then + (x :: l_l, l_r) + else + (l_l, x :: l_r) diff --git a/src/core/lwt_mvar.ml b/src/core/lwt_mvar.ml index e0d9de5670..674d02dae3 100644 --- a/src/core/lwt_mvar.ml +++ b/src/core/lwt_mvar.ml @@ -49,30 +49,30 @@ let create v = let put mvar v = match mvar.mvar_contents with - | None -> - begin match Lwt_sequence.take_opt_l mvar.readers with - | None -> - mvar.mvar_contents <- Some v - | Some w -> - Lwt.wakeup_later w v - end; - Lwt.return_unit - | Some _ -> - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_r (v, w) mvar.writers in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - res + | None -> + begin match Lwt_sequence.take_opt_l mvar.readers with + | None -> + mvar.mvar_contents <- Some v + | Some w -> + Lwt.wakeup_later w v + end; + Lwt.return_unit + | Some _ -> + let (res, w) = Lwt.task () in + let node = Lwt_sequence.add_r (v, w) mvar.writers in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + res let take mvar = match mvar.mvar_contents with - | Some v -> - begin match Lwt_sequence.take_opt_l mvar.writers with - | Some(v', w) -> - mvar.mvar_contents <- Some v'; - Lwt.wakeup_later w () - | None -> - mvar.mvar_contents <- None - end; - Lwt.return v - | None -> - Lwt.add_task_r mvar.readers + | Some v -> + begin match Lwt_sequence.take_opt_l mvar.writers with + | Some(v', w) -> + mvar.mvar_contents <- Some v'; + Lwt.wakeup_later w () + | None -> + mvar.mvar_contents <- None + end; + Lwt.return v + | None -> + Lwt.add_task_r mvar.readers diff --git a/src/core/lwt_pool.ml b/src/core/lwt_pool.ml index 42042d7c79..4f6740f27f 100644 --- a/src/core/lwt_pool.ml +++ b/src/core/lwt_pool.ml @@ -68,29 +68,29 @@ let create_member p = (* Release a pool member. *) let release p c = match Lwt_sequence.take_opt_l p.waiters with - | Some wakener -> - (* A thread is waiting, give it the pool member. *) - Lwt.wakeup_later wakener c - | None -> - (* No one is waiting, queue it. *) - Queue.push c p.list + | Some wakener -> + (* A thread is waiting, give it the pool member. *) + Lwt.wakeup_later wakener c + | None -> + (* No one is waiting, queue it. *) + Queue.push c p.list (* Create a new member when one is thrown away. *) let replace_acquired p = match Lwt_sequence.take_opt_l p.waiters with - | None -> - (* No one is waiting, do not create a new member to avoid - loosing an error if creation fails. *) - p.count <- p.count - 1 - | Some wakener -> - Lwt.on_any - (Lwt.apply p.create ()) - (fun c -> - Lwt.wakeup_later wakener c) - (fun exn -> - (* Creation failed, notify the waiter of the failure. *) - p.count <- p.count - 1; - Lwt.wakeup_later_exn wakener exn) + | None -> + (* No one is waiting, do not create a new member to avoid + loosing an error if creation fails. *) + p.count <- p.count - 1 + | Some wakener -> + Lwt.on_any + (Lwt.apply p.create ()) + (fun c -> + Lwt.wakeup_later wakener c) + (fun exn -> + (* Creation failed, notify the waiter of the failure. *) + p.count <- p.count - 1; + Lwt.wakeup_later_exn wakener exn) let acquire p = if Queue.is_empty p.list then @@ -108,12 +108,12 @@ let acquire p = (fun () -> p.validate c) (function - | true -> - Lwt.return c - | false -> - (* Remove this member and create a new one. *) - p.count <- p.count - 1; - create_member p) + | true -> + Lwt.return c + | false -> + (* Remove this member and create a new one. *) + p.count <- p.count - 1; + create_member p) (fun e -> (* Validation failed: create a new member if at least one thread is waiting. *) diff --git a/src/core/lwt_pqueue.ml b/src/core/lwt_pqueue.ml index 2f2a6ad598..c3f7510c76 100644 --- a/src/core/lwt_pqueue.ml +++ b/src/core/lwt_pqueue.ml @@ -21,87 +21,87 @@ *) module type OrderedType = - sig - type t - val compare: t -> t -> int - end +sig + type t + val compare: t -> t -> int +end module type S = - sig - type elt - type t - val empty: t - val is_empty: t -> bool - val add: elt -> t -> t - val union: t -> t -> t - val find_min: t -> elt - val lookup_min: t -> elt option - val remove_min: t -> t - val size: t -> int - end +sig + type elt + type t + val empty: t + val is_empty: t -> bool + val add: elt -> t -> t + val union: t -> t -> t + val find_min: t -> elt + val lookup_min: t -> elt option + val remove_min: t -> t + val size: t -> int +end module Make(Ord: OrderedType) : (S with type elt = Ord.t) = - struct - type elt = Ord.t +struct + type elt = Ord.t - type t = tree list - and tree = Node of elt * int * tree list + type t = tree list + and tree = Node of elt * int * tree list - let root (Node (x, _, _)) = x - let rank (Node (_, r, _)) = r - let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) = - let c = Ord.compare x1 x2 in - if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2) - let rec ins t = - function - [] -> - [t] - | (t'::_) as ts when rank t < rank t' -> - t::ts - | t'::ts -> - ins (link t t') ts + let root (Node (x, _, _)) = x + let rank (Node (_, r, _)) = r + let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) = + let c = Ord.compare x1 x2 in + if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2) + let rec ins t = + function + [] -> + [t] + | (t'::_) as ts when rank t < rank t' -> + t::ts + | t'::ts -> + ins (link t t') ts - let empty = [] - let is_empty ts = ts = [] - let add x ts = ins (Node (x, 0, [])) ts - let rec union ts ts' = - match ts, ts' with - ([], _) -> ts' - | (_, []) -> ts - | (t1::ts1, t2::ts2) -> - if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2) - else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2 - else ins (link t1 t2) (union ts1 ts2) + let empty = [] + let is_empty ts = ts = [] + let add x ts = ins (Node (x, 0, [])) ts + let rec union ts ts' = + match ts, ts' with + ([], _) -> ts' + | (_, []) -> ts + | (t1::ts1, t2::ts2) -> + if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2) + else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2 + else ins (link t1 t2) (union ts1 ts2) - let rec find_min = - function - [] -> raise Not_found - | [t] -> root t - | t::ts -> - let x = find_min ts in - let c = Ord.compare (root t) x in - if c < 0 then root t else x + let rec find_min = + function + [] -> raise Not_found + | [t] -> root t + | t::ts -> + let x = find_min ts in + let c = Ord.compare (root t) x in + if c < 0 then root t else x - let lookup_min t = - try Some(find_min t) with Not_found -> None + let lookup_min t = + try Some(find_min t) with Not_found -> None - let rec get_min = - function - [] -> assert false - | [t] -> (t, []) - | t::ts -> - let (t', ts') = get_min ts in - let c = Ord.compare (root t) (root t') in - if c < 0 then (t, ts) else (t', t::ts') + let rec get_min = + function + [] -> assert false + | [t] -> (t, []) + | t::ts -> + let (t', ts') = get_min ts in + let c = Ord.compare (root t) (root t') in + if c < 0 then (t, ts) else (t', t::ts') - let remove_min = - function - [] -> raise Not_found - | ts -> - let (Node (_, _, c), ts) = get_min ts in - union (List.rev c) ts + let remove_min = + function + [] -> raise Not_found + | ts -> + let (Node (_, _, c), ts) = get_min ts in + union (List.rev c) ts - let rec size l = - let sizetree (Node (_,_,tl)) = 1 + size tl in - List.fold_left (fun s t -> s + sizetree t) 0 l - end + let rec size l = + let sizetree (Node (_,_,tl)) = 1 + size tl in + List.fold_left (fun s t -> s + sizetree t) 0 l +end diff --git a/src/core/lwt_stream.ml b/src/core/lwt_stream.ml index fc1d49aa55..c22d5bfffb 100644 --- a/src/core/lwt_stream.ml +++ b/src/core/lwt_stream.ml @@ -17,7 +17,7 @@ * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. -*) + *) open Lwt.Infix diff --git a/src/core/lwt_switch.ml b/src/core/lwt_switch.ml index d5b47466ac..63d99b5eaa 100644 --- a/src/core/lwt_switch.ml +++ b/src/core/lwt_switch.ml @@ -35,8 +35,8 @@ let create () = { state = St_on { hooks = [] } } let is_on switch = match switch.state with - | St_on _ -> true - | St_off -> false + | St_on _ -> true + | St_off -> false let check = function | Some{ state = St_off } -> raise Off @@ -44,30 +44,30 @@ let check = function let add_hook switch hook = match switch with - | Some { state = St_on os } -> - os.hooks <- hook :: os.hooks - | Some { state = St_off } -> - raise Off - | None -> - () + | Some { state = St_on os } -> + os.hooks <- hook :: os.hooks + | Some { state = St_off } -> + raise Off + | None -> + () let add_hook_or_exec switch hook = match switch with - | Some { state = St_on os } -> - os.hooks <- hook :: os.hooks; - Lwt.return_unit - | Some { state = St_off } -> - hook () - | None -> - Lwt.return_unit + | Some { state = St_on os } -> + os.hooks <- hook :: os.hooks; + Lwt.return_unit + | Some { state = St_off } -> + hook () + | None -> + Lwt.return_unit let turn_off switch = match switch.state with - | St_on { hooks = hooks } -> - switch.state <- St_off; - Lwt.join (List.map (fun hook -> Lwt.apply hook ()) hooks) - | St_off -> - Lwt.return_unit + | St_on { hooks = hooks } -> + switch.state <- St_off; + Lwt.join (List.map (fun hook -> Lwt.apply hook ()) hooks) + | St_off -> + Lwt.return_unit let with_switch fn = let switch = create () in diff --git a/src/glib/lwt_glib.ml b/src/glib/lwt_glib.ml index ae80c2490d..326de8bfcf 100644 --- a/src/glib/lwt_glib.ml +++ b/src/glib/lwt_glib.ml @@ -71,16 +71,16 @@ let enter () = for i = 0 to Array.length fds - 1 do let fd = fds.(i) in match watches.(i) with - | Watch_none -> - () - | Watch_in -> - events := engine#on_readable fd (fun _ -> glib_mark_readable i) :: !events - | Watch_out -> - events := engine#on_writable fd (fun _ -> glib_mark_writable i) :: !events - | Watch_in_out -> - events := engine#on_readable fd (fun _ -> glib_mark_readable i) - :: engine#on_writable fd (fun _ -> glib_mark_writable i) - :: !events + | Watch_none -> + () + | Watch_in -> + events := engine#on_readable fd (fun _ -> glib_mark_readable i) :: !events + | Watch_out -> + events := engine#on_writable fd (fun _ -> glib_mark_writable i) :: !events + | Watch_in_out -> + events := engine#on_readable fd (fun _ -> glib_mark_readable i) + :: engine#on_writable fd (fun _ -> glib_mark_writable i) + :: !events done; if timeout = 0. then ignore (Lwt_main.yield ()) @@ -102,32 +102,32 @@ let leave () = let install ?(mode=`lwt_into_glib) () = match !state with - | State_lwt_into_glib _ | State_glib_into_lwt _ -> - () - | State_none -> - glib_init (); - match mode with - | `glib_into_lwt -> - state := State_glib_into_lwt(Lwt_sequence.add_l enter Lwt_main.enter_iter_hooks, - Lwt_sequence.add_l leave Lwt_main.leave_iter_hooks) - | `lwt_into_glib -> - let engine = Lwt_engine.get () in - Lwt_engine.set ~destroy:false (new engine); - state := State_lwt_into_glib engine + | State_lwt_into_glib _ | State_glib_into_lwt _ -> + () + | State_none -> + glib_init (); + match mode with + | `glib_into_lwt -> + state := State_glib_into_lwt(Lwt_sequence.add_l enter Lwt_main.enter_iter_hooks, + Lwt_sequence.add_l leave Lwt_main.leave_iter_hooks) + | `lwt_into_glib -> + let engine = Lwt_engine.get () in + Lwt_engine.set ~destroy:false (new engine); + state := State_lwt_into_glib engine let remove () = match !state with - | State_none -> - () - | State_glib_into_lwt(node_enter, node_leave) -> - state := State_none; - Lwt_sequence.remove node_enter; - Lwt_sequence.remove node_leave; - List.iter Lwt_engine.stop_event !events; - events := []; - glib_stop () - | State_lwt_into_glib engine -> - Lwt_engine.set engine + | State_none -> + () + | State_glib_into_lwt(node_enter, node_leave) -> + state := State_none; + Lwt_sequence.remove node_enter; + Lwt_sequence.remove node_leave; + List.iter Lwt_engine.stop_event !events; + events := []; + glib_stop () + | State_lwt_into_glib engine -> + Lwt_engine.set engine (* +-----------------------------------------------------------------+ | Misc | diff --git a/src/logger/lwt_log_core.ml b/src/logger/lwt_log_core.ml index 6a5afde005..aca2a8855b 100644 --- a/src/logger/lwt_log_core.ml +++ b/src/logger/lwt_log_core.ml @@ -61,9 +61,9 @@ let level_of_string str = | Patterns and rules | +-----------------------------------------------------------------+ *) - (* A pattern is represented by a list of literals: +(* A pattern is represented by a list of literals: - For example ["foo*bar*"] is represented by ["foo"; "bar"; ""]. *) + For example ["foo*bar*"] is represented by ["foo"; "bar"; ""]. *) let sub_equal str ofs patt = let str_len = String.length str and patt_len = String.length patt in @@ -79,23 +79,23 @@ let pattern_match pattern string = pattern = [] || pattern = [""] else match pattern with - | [] -> - false - | literal :: pattern -> - let literal_length = String.length literal in - let max_offset = length - literal_length in - let rec search offset = - offset <= max_offset - && ((sub_equal string offset literal && loop (offset + literal_length) pattern) - || search (offset + 1)) - in - search offset + | [] -> + false + | literal :: pattern -> + let literal_length = String.length literal in + let max_offset = length - literal_length in + let rec search offset = + offset <= max_offset + && ((sub_equal string offset literal && loop (offset + literal_length) pattern) + || search (offset + 1)) + in + search offset in match pattern with - | [] -> - string = "" - | literal :: pattern -> - sub_equal string 0 literal && loop (String.length literal) pattern + | [] -> + string = "" + | literal :: pattern -> + sub_equal string 0 literal && loop (String.length literal) pattern let split pattern = let len = String.length pattern in @@ -104,10 +104,10 @@ let split pattern = [""] else match try Some(String.index_from pattern ofs '*') with Not_found -> None with - | Some ofs' -> - String.sub pattern ofs (ofs' - ofs) :: loop (ofs' + 1) - | None -> - [String.sub pattern ofs (len - ofs)] + | Some ofs' -> + String.sub pattern ofs (ofs' - ofs) :: loop (ofs' + 1) + | None -> + [String.sub pattern ofs (len - ofs)] in loop 0 @@ -115,15 +115,15 @@ let rules = ref [] let load_rules' str fail_on_error = let rec loop = function - | [] -> [] - | (pattern, level_str) :: rest -> - let pattern = split pattern in - let level = level_of_string level_str in - match level with - | Some level -> (pattern, level) :: loop rest - | None -> - if fail_on_error then raise (Failure "Invalid log rules") - else log_intern "invalid log level (%s)" level_str; loop rest + | [] -> [] + | (pattern, level_str) :: rest -> + let pattern = split pattern in + let level = level_of_string level_str in + match level with + | Some level -> (pattern, level) :: loop rest + | None -> + if fail_on_error then raise (Failure "Invalid log rules") + else log_intern "invalid log level (%s)" level_str; loop rest in match Lwt_log_rules.rules (Lexing.from_string str) with | None -> @@ -134,8 +134,8 @@ let load_rules' str fail_on_error = let _ = match try Some(Sys.getenv "LWT_LOG") with Not_found -> None with - | Some str -> load_rules' str false - | None -> () + | Some str -> load_rules' str false + | None -> () (* +-----------------------------------------------------------------+ | Sections | @@ -152,22 +152,22 @@ struct type section = t module Sections = Weak.Make(struct - type t = section - let equal a b = a.name = b.name - let hash s = Hashtbl.hash s.name - end) + type t = section + let equal a b = a.name = b.name + let hash s = Hashtbl.hash s.name + end) let sections = Sections.create 32 let find_level name = let rec loop = function | [] -> - Notice + Notice | (pattern, level) :: rest -> - if pattern_match pattern name then - level - else - loop rest + if pattern_match pattern name then + level + else + loop rest in loop !rules @@ -248,7 +248,7 @@ let make ~output ~close = let broadcast loggers = make ~output:(fun section level lines -> - Lwt_list.iter_p (fun logger -> logger.lg_output section level lines) loggers) + Lwt_list.iter_p (fun logger -> logger.lg_output section level lines) loggers) ~close:Lwt.return let dispatch f = @@ -267,8 +267,8 @@ let location_key = Lwt.new_key () let render ~buffer ~template ~section ~level ~message = let file, line, column = match Lwt.get location_key with - | Some loc -> loc - | None -> ("", -1, -1) + | Some loc -> loc + | None -> ("", -1, -1) in Buffer.add_substitute buffer (function @@ -321,17 +321,17 @@ let log ?exn ?(section=Section.main) ?location ?logger ~level message = Lwt.fail Logger_closed else if level >= section.Section.level then match exn with - | None -> - Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) - | Some exn -> - let bt = if Printexc.backtrace_status () then Printexc.get_backtrace () - else "" in - let message = message ^ ": " ^ Printexc.to_string exn in - let message = - if String.length bt = 0 then message - else message ^ "\nbacktrace:\n" ^ bt - in - Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) + | None -> + Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) + | Some exn -> + let bt = if Printexc.backtrace_status () then Printexc.get_backtrace () + else "" in + let message = message ^ ": " ^ Printexc.to_string exn in + let message = + if String.length bt = 0 then message + else message ^ "\nbacktrace:\n" ^ bt + in + Lwt.with_value location_key location (fun () -> logger.lg_output section level (split message)) else Lwt.return_unit diff --git a/src/ppx/ppx_lwt.ml b/src/ppx/ppx_lwt.ml index 886388712c..2fac7d673f 100644 --- a/src/ppx/ppx_lwt.ml +++ b/src/ppx/ppx_lwt.ml @@ -76,7 +76,7 @@ let gen_binds e_loc l e = let new_exp = if !debug then [%expr Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) - [%e name] [%e fun_]] [@metaloc e_loc] + [%e name] [%e fun_]] [@metaloc e_loc] else [%expr Lwt.bind [%e name] [%e fun_]] [@metaloc e_loc] in @@ -96,7 +96,7 @@ let gen_top_binds vbs = | {pvb_expr; _}::_rest -> if !debug then [%expr Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) - [%e pvb_expr] (fun [%p pvar (gen_name i)] -> gen_exp _rest (i + 1))] + [%e pvb_expr] (fun [%p pvar (gen_name i)] -> gen_exp _rest (i + 1))] else [%expr Lwt.bind [%e pvb_expr] (fun [%p pvar (gen_name i)] -> gen_exp rest (i + 1))] | [] -> @@ -105,7 +105,7 @@ let gen_top_binds vbs = in Exp.tuple (names i) in [Vb.mk (Pat.tuple (vbs |> List.map (fun { pvb_pat; _ } -> pvb_pat))) - [%expr Lwt_main.run [%e gen_exp vbs 0]]] + [%expr Lwt_main.run [%e gen_exp vbs 0]]] (** For expressions only *) (* We only expand the first level after a %lwt. @@ -117,12 +117,12 @@ let lwt_expression mapper exp attributes = (* [let%lwt $p$ = $e$ in $e'$] ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *) | Pexp_let (Nonrecursive, vbl , e) -> - let new_exp = - Exp.let_ - Nonrecursive - (gen_bindings vbl) - (gen_binds exp.pexp_loc vbl e) - in mapper.expr mapper { new_exp with pexp_attributes } + let new_exp = + Exp.let_ + Nonrecursive + (gen_bindings vbl) + (gen_binds exp.pexp_loc vbl e) + in mapper.expr mapper { new_exp with pexp_attributes } (* [match%lwt $e$ with $c$] ≡ [Lwt.bind $e$ (function $c$)] [match%lwt $e$ with exception $x$ | $c$] ≡ @@ -146,59 +146,60 @@ let lwt_expression mapper exp attributes = match exns with | [] -> [%expr Lwt.bind [%e e] [%e Exp.function_ cases]] | _ -> [%expr Lwt.try_bind (fun () -> [%e e]) - [%e Exp.function_ cases] [%e Exp.function_ exns]] + [%e Exp.function_ cases] + [%e Exp.function_ exns]] in mapper.expr mapper { new_exp with pexp_attributes } (* [assert%lwt $e$] ≡ [try Lwt.return (assert $e$) with exn -> Lwt.fail exn] *) | Pexp_assert e -> - let new_exp = - [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn] - in mapper.expr mapper { new_exp with pexp_attributes } + let new_exp = + [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn] + in mapper.expr mapper { new_exp with pexp_attributes } (* [while%lwt $cond$ do $body$ done] ≡ [let rec __ppx_lwt_loop () = if $cond$ then Lwt.bind $body$ __ppx_lwt_loop else Lwt.return_unit in __ppx_lwt_loop] - *) + *) | Pexp_while (cond, body) -> - let new_exp = - [%expr + let new_exp = + [%expr let rec __ppx_lwt_loop () = if [%e cond] then Lwt.bind [%e body] __ppx_lwt_loop else Lwt.return_unit in __ppx_lwt_loop () - ] - in mapper.expr mapper { new_exp with pexp_attributes } + ] + in mapper.expr mapper { new_exp with pexp_attributes } (* [for%lwt $p$ = $start$ (to|downto) $end$ do $body$ done] ≡ [let __ppx_lwt_bound = $end$ in - let rec __ppx_lwt_loop $p$ = - if $p$ COMP __ppx_lwt_bound then Lwt.return_unit - else Lwt.bind $body$ (fun () -> __ppx_lwt_loop ($p$ OP 1)) - in __ppx_lwt_loop $start$] - *) + let rec __ppx_lwt_loop $p$ = + if $p$ COMP __ppx_lwt_bound then Lwt.return_unit + else Lwt.bind $body$ (fun () -> __ppx_lwt_loop ($p$ OP 1)) + in __ppx_lwt_loop $start$] + *) | Pexp_for ({ppat_desc = Ppat_var p_var; _} as p, start, bound, dir, body) -> - let comp, op = match dir with - | Upto -> evar ">", evar "+" - | Downto -> evar "<", evar "-" - in - let p' = with_loc (fun s -> evar s) p_var in + let comp, op = match dir with + | Upto -> evar ">", evar "+" + | Downto -> evar "<", evar "-" + in + let p' = with_loc (fun s -> evar s) p_var in - let exp_bound = [%expr __ppx_lwt_bound] [@metaloc bound.pexp_loc] in - let pat_bound = [%pat? __ppx_lwt_bound] [@metaloc bound.pexp_loc] in + let exp_bound = [%expr __ppx_lwt_bound] [@metaloc bound.pexp_loc] in + let pat_bound = [%pat? __ppx_lwt_bound] [@metaloc bound.pexp_loc] in - let new_exp = - [%expr + let new_exp = + [%expr let [%p pat_bound] : int = [%e bound] in let rec __ppx_lwt_loop [%p p] = if [%e comp] [%e p'] [%e exp_bound] then Lwt.return_unit else Lwt.bind [%e body] (fun () -> __ppx_lwt_loop ([%e op] [%e p'] 1)) in __ppx_lwt_loop [%e start] - ] - in mapper.expr mapper { new_exp with pexp_attributes } + ] + in mapper.expr mapper { new_exp with pexp_attributes } (* [try%lwt $e$ with $c$] ≡ @@ -209,7 +210,7 @@ let lwt_expression mapper exp attributes = let new_exp = if !debug then [%expr Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) - (fun () -> [%e expr]) [%e Exp.function_ cases]] + (fun () -> [%e expr]) [%e Exp.function_ cases]] else [%expr Lwt.catch (fun () -> [%e expr]) [%e Exp.function_ cases]] in @@ -221,14 +222,14 @@ let lwt_expression mapper exp attributes = [match%lwt $c$ with true -> $e1$ | false -> Lwt.return_unit] *) | Pexp_ifthenelse (cond, e1, e2) -> - let e2 = match e2 with None -> [%expr Lwt.return_unit] | Some e -> e in - let cases = - [ - Exp.case [%pat? true] e1 ; - Exp.case [%pat? false] e2 ; - ] - in - let new_exp = [%expr Lwt.bind [%e cond] [%e Exp.function_ cases]] in + let e2 = match e2 with None -> [%expr Lwt.return_unit] | Some e -> e in + let cases = + [ + Exp.case [%pat? true] e1 ; + Exp.case [%pat? false] e2 ; + ] + in + let new_exp = [%expr Lwt.bind [%e cond] [%e Exp.function_ cases]] in mapper.expr mapper { new_exp with pexp_attributes } (* [[%lwt $e$]] ≡ [Lwt.catch (fun () -> $e$) Lwt.fail] *) @@ -243,7 +244,7 @@ let lwt_expression mapper exp attributes = let new_exp = if !debug then [%expr Lwt.backtrace_catch (fun exn -> try raise exn with exn -> exn) - (fun () -> [%e exp]) Lwt.fail] + (fun () -> [%e exp]) Lwt.fail] else [%expr Lwt.catch (fun () -> [%e exp]) Lwt.fail] in @@ -254,14 +255,14 @@ let make_loc {Location.loc_start; _} = [%expr ([%e str file], [%e int line], [%e int char])] (** - [Lwt_log.error "message"] ≡ - [let __pa_log_section = Lwt_log.Section.main in + [Lwt_log.error "message"] ≡ + [let __pa_log_section = Lwt_log.Section.main in if Lwt_log.Error >= (Lwt_log.Section.level __pa_log_section) then Lwt_log.error ~location:("foo.ml", 1, 0) ~section:__pa_log_section "message" else Lwt.return_unit]; - [Lwt_log.error ~section "message"] ≡ - [let __pa_log_section = section in ...]. - Additionally, remove debug-level statements if -no-debug is given. **) + [Lwt_log.error ~section "message"] ≡ + [let __pa_log_section = section in ...]. + Additionally, remove debug-level statements if -no-debug is given. **) let lwt_log mapper fn args attrs loc = let open Longident in match fn with @@ -288,7 +289,7 @@ let lwt_log mapper fn args attrs loc = List.remove_assoc (Label.labelled "section") args in [%expr if [%e Exp.construct (def_loc (Ldot (Lident "Lwt_log", level))) None] >= - Lwt_log.Section.level __pa_log_section then + Lwt_log.Section.level __pa_log_section then [%e Exp.apply (Exp.ident (def_loc (Ldot (Lident "Lwt_log", func)))) args] else [%e if ign then [%expr ()] else [%expr Lwt.return_unit]]] @@ -308,7 +309,6 @@ let mapper = | [%expr [%lwt [%e? exp]]] -> lwt_expression mapper exp expr.pexp_attributes - (* [($e$)[%finally $f$]] ≡ [Lwt.finalize (fun () -> $e$) (fun () -> $f$)] *) | [%expr [%e? exp ] [%finally [%e? finally]] ] @@ -316,7 +316,8 @@ let mapper = let new_exp = if !debug then [%expr Lwt.backtrace_finalize (fun exn -> try raise exn with exn -> exn) - (fun () -> [%e exp]) (fun () -> [%e finally])] + (fun () -> [%e exp]) + (fun () -> [%e finally])] else [%expr Lwt.finalize (fun () -> [%e exp]) (fun () -> [%e finally])] in @@ -328,11 +329,10 @@ let mapper = | [%expr [%finally [%e? _ ]]] | [%expr [%lwt.finally [%e? _ ]]] -> raise (Location.Error ( - Location.errorf - ~loc:expr.pexp_loc - "Lwt's finally should be used only with the syntax: \"()[%%finally ...]\"." - )) - + Location.errorf + ~loc:expr.pexp_loc + "Lwt's finally should be used only with the syntax: \"()[%%finally ...]\"." + )) | [%expr [%e? lhs] >> [%e? rhs]] -> if !sequence then @@ -340,7 +340,8 @@ let mapper = let lhs, rhs = mapper.expr mapper lhs, mapper.expr mapper rhs in if !debug then [%expr Lwt.backtrace_bind (fun exn -> try raise exn with exn -> exn) - [%e lhs] (fun [%p pat] -> [%e rhs])] + [%e lhs] + (fun [%p pat] -> [%e rhs])] else [%expr Lwt.bind [%e lhs] (fun [%p pat] -> [%e rhs])] else @@ -348,32 +349,35 @@ let mapper = | { pexp_desc = Pexp_apply (fn, args); pexp_attributes; pexp_loc } when !log -> default_loc := pexp_loc; lwt_log mapper fn args pexp_attributes pexp_loc - | _ -> default_mapper.expr mapper expr); - structure_item = (fun mapper stri -> - default_loc := stri.pstr_loc; - match stri with - | [%stri let%lwt [%p? var] = [%e? exp]] -> - [%stri let [%p var] = Lwt_main.run [%e mapper.expr mapper exp]] - | {pstr_desc = Pstr_extension (({txt = "lwt"; _}, PStr [ + | _ -> + default_mapper.expr mapper expr); + structure_item = (fun mapper stri -> + default_loc := stri.pstr_loc; + match stri with + | [%stri let%lwt [%p? var] = [%e? exp]] -> + [%stri let [%p var] = Lwt_main.run [%e mapper.expr mapper exp]] + + | {pstr_desc = Pstr_extension (({txt = "lwt"; _}, PStr [ {pstr_desc = Pstr_value (Recursive, _); _}]) as content, attrs); pstr_loc} -> - {stri with pstr_desc = - Pstr_extension (content, warn_let_lwt_rec pstr_loc attrs)} - | {pstr_desc = Pstr_extension (({txt = "lwt"; _}, PStr [ + {stri with pstr_desc = + Pstr_extension (content, warn_let_lwt_rec pstr_loc attrs)} + + | {pstr_desc = Pstr_extension (({txt = "lwt"; _}, PStr [ {pstr_desc = Pstr_value (Nonrecursive, vbs); _}]), _); _} -> - mapper.structure_item mapper (Str.value Nonrecursive (gen_top_binds vbs)) - | x -> default_mapper.structure_item mapper x); - } + mapper.structure_item mapper (Str.value Nonrecursive (gen_top_binds vbs)) + | x -> default_mapper.structure_item mapper x); +} let args = Arg.([ - "-no-debug", Clear debug, "disable debug mode"; - "-log", Set log, "enable logging"; - "-no-log", Clear log, "disable logging"; - "-no-sequence", Clear sequence, "disable sequence operator"; - "-no-strict-sequence", Clear strict_seq, "allow non-unit sequence operations"; + "-no-debug", Clear debug, "disable debug mode"; + "-log", Set log, "enable logging"; + "-no-log", Clear log, "disable logging"; + "-no-sequence", Clear sequence, "disable sequence operator"; + "-no-strict-sequence", Clear strict_seq, "allow non-unit sequence operations"; ]) let () = - Driver.register ~name:"ppx_lwt" ~args Versions.ocaml_404 - (fun _config _cookies -> mapper) + Driver.register ~name:"ppx_lwt" ~args Versions.ocaml_404 + (fun _config _cookies -> mapper) diff --git a/src/preemptive/lwt_preemptive.ml b/src/preemptive/lwt_preemptive.ml index e69fd61ca5..2de32081e8 100644 --- a/src/preemptive/lwt_preemptive.ml +++ b/src/preemptive/lwt_preemptive.ml @@ -74,16 +74,16 @@ struct let get t = let rec await_value t = match t.cell with - | None -> - Condition.wait t.cv t.m; - await_value t - | Some v -> - t.cell <- None; - Mutex.unlock t.m; - v + | None -> + Condition.wait t.cv t.m; + await_value t + | Some v -> + t.cell <- None; + Mutex.unlock t.m; + v in - Mutex.lock t.m; - await_value t + Mutex.lock t.m; + await_value t let set t v = Mutex.lock t.m; @@ -136,10 +136,10 @@ let make_worker () = (* Add a worker to the pool: *) let add_worker worker = match Lwt_sequence.take_opt_l waiters with - | None -> - Queue.add worker workers - | Some w -> - Lwt.wakeup w worker + | None -> + Queue.add worker workers + | Some w -> + Lwt.wakeup w worker (* Wait for worker to be available, then return it: *) let get_worker () = @@ -207,20 +207,20 @@ let detach f args = in Lwt.finalize (fun () -> - (* Send the id and the task to the worker: *) + (* Send the id and the task to the worker: *) CELL.set worker.task_cell (id, task); waiter) (fun () -> - if worker.reuse then - (* Put back the worker to the pool: *) - add_worker worker - else begin - decr threads_count; - (* Or wait for the thread to terminates, to free its associated - resources: *) - Thread.join worker.thread - end; - Lwt.return_unit) + if worker.reuse then + (* Put back the worker to the pool: *) + add_worker worker + else begin + decr threads_count; + (* Or wait for the thread to terminates, to free its associated + resources: *) + Thread.join worker.thread + end; + Lwt.return_unit) (* +-----------------------------------------------------------------+ | Running Lwt threads in the main thread | @@ -267,5 +267,5 @@ let run_in_main f = Lwt_unix.send_notification job_notification; (* Wait for the result. *) match CELL.get cell with - | Result.Ok ret -> ret - | Result.Error exn -> raise exn + | Result.Ok ret -> ret + | Result.Error exn -> raise exn diff --git a/src/react/lwt_react.ml b/src/react/lwt_react.ml index b9f32a74e9..27ef8dd72e 100644 --- a/src/react/lwt_react.ml +++ b/src/react/lwt_react.ml @@ -49,15 +49,15 @@ module E = struct (* The limiter is sleeping, we queue the event for later delivering. *) match !delayed with - | Some cell -> - (* An occurence is alreayd queued, replace it. *) - cell := x; - None - | None -> - let cell = ref x in - delayed := Some cell; - Lwt.on_success !limiter (fun () -> let x = !cell in delayed := None; push x); - None + | Some cell -> + (* An occurence is alreayd queued, replace it. *) + cell := x; + None + | None -> + let cell = ref x in + delayed := Some cell; + Lwt.on_success !limiter (fun () -> let x = !cell in delayed := None; push x); + None end else begin (* Set the limiter for future events. *) limiter := f (); @@ -96,12 +96,12 @@ module E = struct let delay thread = match Lwt.poll thread with - | Some e -> - e - | None -> - let event, send = create () in - Lwt.on_success thread (fun e -> send e; stop event); - switch never event + | Some e -> + e + | None -> + let event, send = create () in + Lwt.on_success thread (fun e -> send e; stop event); + switch never event let keeped = ref [] @@ -123,10 +123,10 @@ module E = struct let iter = fmap (fun t -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> t)) - (fun v -> push v); - None) e + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> t)) + (fun v -> push v); + None) e in select [iter; event] @@ -141,10 +141,10 @@ module E = struct let iter = fmap (fun x -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> f x)) - (fun v -> push v); - None) e + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (fun v -> push v); + None) e in select [iter; event] @@ -153,8 +153,8 @@ module E = struct let iter = fmap (fun (f, x) -> - Lwt.on_success (f x) (fun v -> push v); - None) + Lwt.on_success (f x) (fun v -> push v); + None) (app (map (fun f x -> (f, x)) ef) e) in select [iter; event] @@ -165,10 +165,10 @@ module E = struct let iter = fmap (fun (f, x) -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> f x)) - (fun v -> push v); - None) + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (fun v -> push v); + None) (app (map (fun f x -> (f, x)) ef) e) in select [iter; event] @@ -203,15 +203,15 @@ module E = struct fmap (fun x -> match !previous with - | None -> - previous := Some x; - None - | Some y -> - previous := Some x; - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> f x y)) - (fun v -> push v); - None) + | None -> + previous := Some x; + None + | Some y -> + previous := Some x; + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x y)) + (fun v -> push v); + None) e in select [iter; event] @@ -232,10 +232,10 @@ module E = struct let rec rev_fold f acc = function | [] -> - Lwt.return acc + Lwt.return acc | x :: l -> - rev_fold f acc l >>= fun acc -> - f acc x + rev_fold f acc l >>= fun acc -> + f acc x let merge_s f acc el = let event, push = create () in @@ -243,10 +243,10 @@ module E = struct let iter = fmap (fun l -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) - (fun v -> push v); - None) + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) + (fun v -> push v); + None) (merge (fun acc x -> x :: acc) [] el) in select [iter; event] @@ -283,15 +283,15 @@ module S = struct (* The limiter is sleeping, we queue the event for later delivering. *) match !delayed with - | Some cell -> - (* An occurence is alreayd queued, replace it. *) - cell := x; - None - | None -> - let cell = ref x in - delayed := Some cell; - Lwt.on_success !limiter (fun () -> let x = !cell in delayed := None; push x); - None + | Some cell -> + (* An occurence is alreayd queued, replace it. *) + cell := x; + None + | None -> + let cell = ref x in + delayed := Some cell; + Lwt.on_success !limiter (fun () -> let x = !cell in delayed := None; push x); + None end else begin (* Set the limiter for future events. *) limiter := f (); @@ -319,10 +319,10 @@ module S = struct let iter = E.fmap (fun t -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> t)) - (fun v -> push v); - None) + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> t)) + (fun v -> push v); + None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> value s) >>= fun x -> @@ -334,9 +334,9 @@ module S = struct let iter = E.fmap (fun x -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v); - None) + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v); + None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> @@ -348,10 +348,10 @@ module S = struct let iter = E.fmap (fun (f, x) -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> f x)) - (fun v -> push v); - None) + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (fun v -> push v); + None) (E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s)) in Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) >>= fun x -> @@ -363,20 +363,20 @@ module S = struct let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in let x = value s in Lwt_mutex.with_lock mutex (fun () -> f x) >>= function - | true -> - Lwt.return (hold ?eq x (E.select [iter; event])) - | false -> - Lwt.return (hold ?eq i (E.select [iter; event])) + | true -> + Lwt.return (hold ?eq x (E.select [iter; event])) + | false -> + Lwt.return (hold ?eq i (E.select [iter; event])) let fmap_s ?eq f i s = let event, push = E.create () in let mutex = Lwt_mutex.create () in let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= function - | Some x -> - Lwt.return (hold ?eq x (E.select [iter; event])) - | None -> - Lwt.return (hold ?eq i (E.select [iter; event])) + | Some x -> + Lwt.return (hold ?eq x (E.select [iter; event])) + | None -> + Lwt.return (hold ?eq i (E.select [iter; event])) let diff_s f s = let previous = ref (value s) in @@ -406,10 +406,10 @@ module S = struct let rec rev_fold f acc = function | [] -> - Lwt.return acc + Lwt.return acc | x :: l -> - rev_fold f acc l >>= fun acc -> - f acc x + rev_fold f acc l >>= fun acc -> + f acc x let merge_s ?eq f acc sl = let s = merge (fun acc x -> x :: acc) [] sl in @@ -418,10 +418,10 @@ module S = struct let iter = E.fmap (fun l -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) - (fun v -> push v); - None) + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l)) + (fun v -> push v); + None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) >>= fun x -> @@ -458,10 +458,10 @@ module S = struct let iter = E.fmap (fun x -> - Lwt.on_success - (Lwt_mutex.with_lock mutex (fun () -> f x)) - (fun v -> push v); - None) + Lwt.on_success + (Lwt_mutex.with_lock mutex (fun () -> f x)) + (fun v -> push v); + None) (changes s) in Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x -> diff --git a/src/simple_top/lwt_simple_top.ml b/src/simple_top/lwt_simple_top.ml index c3f5d4bc0f..5f4f56663f 100644 --- a/src/simple_top/lwt_simple_top.ml +++ b/src/simple_top/lwt_simple_top.ml @@ -34,14 +34,14 @@ let read_input_non_interactive prompt buffer len = Lwt.return (i, false) else Lwt_io.read_char_opt Lwt_io.stdin >>= function - | Some c -> - Bytes.set buffer i c; - if c = '\n' then - Lwt.return (i + 1, false) - else - loop (i + 1) - | None -> - Lwt.return (i, true) + | Some c -> + Bytes.set buffer i c; + if c = '\n' then + Lwt.return (i + 1, false) + else + loop (i + 1) + | None -> + Lwt.return (i, true) in Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0) diff --git a/src/ssl/lwt_ssl.ml b/src/ssl/lwt_ssl.ml index 2e6d38d9ed..88e9f95591 100644 --- a/src/ssl/lwt_ssl.ml +++ b/src/ssl/lwt_ssl.ml @@ -32,8 +32,8 @@ type uninitialized_socket = Lwt_unix.file_descr * Ssl.socket let ssl_socket (_fd, kind) = match kind with - | Plain -> None - | SSL socket -> Some socket + | Plain -> None + | SSL socket -> Some socket let ssl_socket_of_uninitialized_socket (_fd, socket) = socket @@ -48,13 +48,13 @@ let wrap_call f () = with (Ssl.Connection_error err | Ssl.Accept_error err | Ssl.Read_error err | Ssl.Write_error err) as e -> - (match err with - Ssl.Error_want_read -> - raise Lwt_unix.Retry_read + (match err with + Ssl.Error_want_read -> + raise Lwt_unix.Retry_read | Ssl.Error_want_write -> - raise Lwt_unix.Retry_write + raise Lwt_unix.Retry_write | _ -> - raise e) [@ocaml.warning "-4"] + raise e) [@ocaml.warning "-4"] let repeat_call fd f = try @@ -62,11 +62,11 @@ let repeat_call fd f = Lwt.return (wrap_call f ()) with Lwt_unix.Retry_read -> - Lwt_unix.register_action Lwt_unix.Read fd (wrap_call f) + Lwt_unix.register_action Lwt_unix.Read fd (wrap_call f) | Lwt_unix.Retry_write -> - Lwt_unix.register_action Lwt_unix.Write fd (wrap_call f) + Lwt_unix.register_action Lwt_unix.Write fd (wrap_call f) | e -> - Lwt.fail e + Lwt.fail e (****) @@ -79,76 +79,76 @@ let ssl_accept fd ctx = let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in Lwt.bind (repeat_call fd (fun () -> Ssl.accept socket)) (fun () -> - Lwt.return (fd, SSL socket)) + Lwt.return (fd, SSL socket)) let ssl_connect fd ctx = let socket = Ssl.embed_socket (Lwt_unix.unix_file_descr fd) ctx in Lwt.bind (repeat_call fd (fun () -> Ssl.connect socket)) (fun () -> - Lwt.return (fd, SSL socket)) + Lwt.return (fd, SSL socket)) let ssl_accept_handshake (fd, socket) = Lwt.bind (repeat_call fd (fun () -> Ssl.accept socket)) (fun () -> - Lwt.return (fd, SSL socket)) + Lwt.return (fd, SSL socket)) let ssl_perform_handshake (fd, socket) = Lwt.bind (repeat_call fd (fun () -> Ssl.connect socket)) (fun () -> - Lwt.return (fd, SSL socket)) + Lwt.return (fd, SSL socket)) let read (fd, s) buf pos len = match s with - | Plain -> - Lwt_unix.read fd buf pos len - | SSL s -> - if len = 0 then - Lwt.return 0 - else - repeat_call fd - (fun () -> - try - Ssl.read s buf pos len - with Ssl.Read_error Ssl.Error_zero_return -> - 0) + | Plain -> + Lwt_unix.read fd buf pos len + | SSL s -> + if len = 0 then + Lwt.return 0 + else + repeat_call fd + (fun () -> + try + Ssl.read s buf pos len + with Ssl.Read_error Ssl.Error_zero_return -> + 0) let read_bytes (fd, s) buf pos len = match s with - | Plain -> - Lwt_bytes.read fd buf pos len - | SSL s -> - if len = 0 then - Lwt.return 0 - else - repeat_call fd - (fun () -> - try - Ssl.read_into_bigarray s buf pos len - with Ssl.Read_error Ssl.Error_zero_return -> - 0) + | Plain -> + Lwt_bytes.read fd buf pos len + | SSL s -> + if len = 0 then + Lwt.return 0 + else + repeat_call fd + (fun () -> + try + Ssl.read_into_bigarray s buf pos len + with Ssl.Read_error Ssl.Error_zero_return -> + 0) let write (fd, s) buf pos len = match s with - | Plain -> - Lwt_unix.write fd buf pos len - | SSL s -> - if len = 0 then - Lwt.return 0 - else - repeat_call fd - (fun () -> - Ssl.write s buf pos len) + | Plain -> + Lwt_unix.write fd buf pos len + | SSL s -> + if len = 0 then + Lwt.return 0 + else + repeat_call fd + (fun () -> + Ssl.write s buf pos len) let write_bytes (fd, s) buf pos len = match s with - | Plain -> - Lwt_bytes.write fd buf pos len - | SSL s -> - if len = 0 then - Lwt.return 0 - else - repeat_call fd - (fun () -> Ssl.write_bigarray s buf pos len) + | Plain -> + Lwt_bytes.write fd buf pos len + | SSL s -> + if len = 0 then + Lwt.return 0 + else + repeat_call fd + (fun () -> Ssl.write_bigarray s buf pos len) let wait_read (fd, s) = match s with @@ -194,8 +194,8 @@ let get_fd (fd, _socket) = fd let get_unix_fd (fd,socket) = match socket with - | Plain -> Lwt_unix.unix_file_descr fd - | SSL socket -> (Ssl.file_descr_of_socket socket) + | Plain -> Lwt_unix.unix_file_descr fd + | SSL socket -> (Ssl.file_descr_of_socket socket) let getsockname s = Unix.getsockname (get_unix_fd s) diff --git a/src/unix/lwt_bytes.ml b/src/unix/lwt_bytes.ml index 7cfa6ef21f..ea219eeda2 100644 --- a/src/unix/lwt_bytes.ml +++ b/src/unix/lwt_bytes.ml @@ -126,11 +126,11 @@ let read fd buf pos len = invalid_arg "Lwt_bytes.read" else blocking fd >>= function - | true -> - wait_read fd >>= fun () -> - run_job (read_job (unix_file_descr fd) buf pos len) - | false -> - wrap_syscall Read fd (fun () -> stub_read (unix_file_descr fd) buf pos len) + | true -> + wait_read fd >>= fun () -> + run_job (read_job (unix_file_descr fd) buf pos len) + | false -> + wrap_syscall Read fd (fun () -> stub_read (unix_file_descr fd) buf pos len) external stub_write : Unix.file_descr -> t -> int -> int -> int = "lwt_unix_bytes_write" external write_job : Unix.file_descr -> t -> int -> int -> int job = "lwt_unix_bytes_write_job" @@ -140,11 +140,11 @@ let write fd buf pos len = invalid_arg "Lwt_bytes.write" else blocking fd >>= function - | true -> - wait_write fd >>= fun () -> - run_job (write_job (unix_file_descr fd) buf pos len) - | false -> - wrap_syscall Write fd (fun () -> stub_write (unix_file_descr fd) buf pos len) + | true -> + wait_write fd >>= fun () -> + run_job (write_job (unix_file_descr fd) buf pos len) + | false -> + wrap_syscall Write fd (fun () -> stub_write (unix_file_descr fd) buf pos len) external stub_recv : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_recv" @@ -178,9 +178,9 @@ let check_io_vectors func_name iovs = List.iter (fun (iov : io_vector) -> if iov.iov_offset < 0 - || iov.iov_length < 0 - || iov.iov_offset > length iov.iov_buffer - iov.iov_length then - Printf.ksprintf invalid_arg "Lwt_bytes.%s" func_name) + || iov.iov_length < 0 + || iov.iov_offset > length iov.iov_buffer - iov.iov_length then + Printf.ksprintf invalid_arg "Lwt_bytes.%s" func_name) iovs external stub_recv_msg : Unix.file_descr -> int -> io_vector list -> int * Unix.file_descr list = "lwt_unix_bytes_recv_msg" diff --git a/src/unix/lwt_chan.ml b/src/unix/lwt_chan.ml index f5821000c3..ced91eed54 100644 --- a/src/unix/lwt_chan.ml +++ b/src/unix/lwt_chan.ml @@ -39,21 +39,21 @@ let make_in_channel ?close read = let input_line ic = let rec loop buf = Lwt_io.read_char_opt ic >>= function - | None | Some '\n' -> - Lwt.return (Buffer.contents buf) - | Some char -> - Buffer.add_char buf char; - loop buf + | None | Some '\n' -> + Lwt.return (Buffer.contents buf) + | Some char -> + Buffer.add_char buf char; + loop buf in Lwt_io.read_char_opt ic >>= function - | Some '\n' -> - Lwt.return "" - | Some char -> - let buf = Buffer.create 128 in - Buffer.add_char buf char; - loop buf - | None -> - Lwt.fail End_of_file + | Some '\n' -> + Lwt.return "" + | Some char -> + let buf = Buffer.create 128 in + Buffer.add_char buf char; + loop buf + | None -> + Lwt.fail End_of_file let input_value = Lwt_io.read_value let input = Lwt_io.read_into diff --git a/src/unix/lwt_daemon.ml b/src/unix/lwt_daemon.ml index bc7cd010a5..79d1de41a1 100644 --- a/src/unix/lwt_daemon.ml +++ b/src/unix/lwt_daemon.ml @@ -36,15 +36,15 @@ let redirect fd logger = let redirect_output dev_null fd mode = match mode with | `Dev_null -> - Unix.dup2 dev_null fd + Unix.dup2 dev_null fd | `Close -> - Unix.close fd + Unix.close fd | `Keep -> - () + () | `Log_default -> - redirect fd None + redirect fd None | `Log logger -> - redirect fd (Some logger) + redirect fd (Some logger) let daemonize ?(syslog=true) ?(stdin=`Dev_null) ?(stdout=`Log_default) ?(stderr=`Log_default) ?(directory="/") ?(umask=`Set 0o022) () = Unix.chdir directory; diff --git a/src/unix/lwt_engine.ml b/src/unix/lwt_engine.ml index 90c13bcd87..eca386c7b3 100644 --- a/src/unix/lwt_engine.ml +++ b/src/unix/lwt_engine.ml @@ -58,15 +58,15 @@ class virtual abstract = object(self) method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t val readables = Lwt_sequence.create () - (* Sequence of callbacks waiting for a file descriptor to become - readable. *) + (* Sequence of callbacks waiting for a file descriptor to become + readable. *) val writables = Lwt_sequence.create () - (* Sequence of callbacks waiting for a file descriptor to become - writable. *) + (* Sequence of callbacks waiting for a file descriptor to become + writable. *) val timers = Lwt_sequence.create () - (* Sequence of timers. *) + (* Sequence of timers. *) method destroy = Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) readables; @@ -222,36 +222,36 @@ type sleeper = { module Sleep_queue = Lwt_pqueue.Make(struct - type t = sleeper - let compare {time = t1; _} {time = t2; _} = compare t1 t2 - end) + type t = sleeper + let compare {time = t1; _} {time = t2; _} = compare t1 t2 + end) [@@ocaml.warning "-3"] module Fd_map = Map.Make(struct type t = Unix.file_descr let compare = compare end) let rec restart_actions sleep_queue now = match Sleep_queue.lookup_min sleep_queue with - | Some{ stopped = true; _ } -> - restart_actions (Sleep_queue.remove_min sleep_queue) now - | Some{ time = time; action = action; _ } when time <= now -> - (* We have to remove the sleeper to the queue before performing - the action. The action can change the sleeper's time, and this - might break the priority queue invariant if the sleeper is - still in the queue. *) - let q = Sleep_queue.remove_min sleep_queue in - action (); - restart_actions q now - | _ -> - sleep_queue + | Some{ stopped = true; _ } -> + restart_actions (Sleep_queue.remove_min sleep_queue) now + | Some{ time = time; action = action; _ } when time <= now -> + (* We have to remove the sleeper to the queue before performing + the action. The action can change the sleeper's time, and this + might break the priority queue invariant if the sleeper is + still in the queue. *) + let q = Sleep_queue.remove_min sleep_queue in + action (); + restart_actions q now + | _ -> + sleep_queue let rec get_next_timeout sleep_queue = match Sleep_queue.lookup_min sleep_queue with - | Some{ stopped = true; _ } -> - get_next_timeout (Sleep_queue.remove_min sleep_queue) - | Some{ time = time; _ } -> - max 0. (time -. Unix.gettimeofday ()) - | None -> - -1. + | Some{ stopped = true; _ } -> + get_next_timeout (Sleep_queue.remove_min sleep_queue) + | Some{ time = time; _ } -> + max 0. (time -. Unix.gettimeofday ()) + | None -> + -1. let bad_fd fd = try @@ -262,28 +262,28 @@ let bad_fd fd = let invoke_actions fd map = match try Some(Fd_map.find fd map) with Not_found -> None with - | Some actions -> Lwt_sequence.iter_l (fun f -> f ()) actions - | None -> () + | Some actions -> Lwt_sequence.iter_l (fun f -> f ()) actions + | None -> () class virtual select_or_poll_based = object inherit abstract val mutable sleep_queue = Sleep_queue.empty - (* Threads waiting for a timeout to expire. *) + (* Threads waiting for a timeout to expire. *) val mutable new_sleeps = [] - (* Sleepers added since the last iteration of the main loop: + (* Sleepers added since the last iteration of the main loop: - They are not added immediately to the main sleep queue in order - to prevent them from being wakeup immediately. *) + They are not added immediately to the main sleep queue in order + to prevent them from being wakeup immediately. *) val mutable wait_readable = Fd_map.empty - (* Sequences of actions waiting for file descriptors to become - readable. *) + (* Sequences of actions waiting for file descriptors to become + readable. *) val mutable wait_writable = Fd_map.empty - (* Sequences of actions waiting for file descriptors to become - writable. *) + (* Sequences of actions waiting for file descriptors to become + writable. *) method private cleanup = () @@ -350,13 +350,13 @@ class virtual select_based = object(self) try self#select fds_r fds_w timeout with - | Unix.Unix_error (Unix.EINTR, _, _) -> - ([], []) - | Unix.Unix_error (Unix.EBADF, _, _) -> - (* Keeps only bad file descriptors. Actions registered on - them have to handle the error: *) - (List.filter bad_fd fds_r, - List.filter bad_fd fds_w) + | Unix.Unix_error (Unix.EINTR, _, _) -> + ([], []) + | Unix.Unix_error (Unix.EBADF, _, _) -> + (* Keeps only bad file descriptors. Actions registered on + them have to handle the error: *) + (List.filter bad_fd fds_r, + List.filter bad_fd fds_w) in (* Restart threads waiting for a timeout: *) sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); @@ -386,12 +386,12 @@ class virtual poll_based = object(self) try self#poll fds timeout with - | Unix.Unix_error (Unix.EINTR, _, _) -> - [] - | Unix.Unix_error (Unix.EBADF, _, _) -> - (* Keeps only bad file descriptors. Actions registered on - them have to handle the error: *) - List.filter (fun (fd, _, _) -> bad_fd fd) fds + | Unix.Unix_error (Unix.EINTR, _, _) -> + [] + | Unix.Unix_error (Unix.EBADF, _, _) -> + (* Keeps only bad file descriptors. Actions registered on + them have to handle the error: *) + List.filter (fun (fd, _, _) -> bad_fd fd) fds in (* Restart threads waiting for a timeout: *) sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ()); diff --git a/src/unix/lwt_gc.ml b/src/unix/lwt_gc.ml index a5643943f1..144ce1da2c 100644 --- a/src/unix/lwt_gc.ml +++ b/src/unix/lwt_gc.ml @@ -39,11 +39,11 @@ let finaliser f = ~once:true (fun () -> match !opt with - | None -> - assert false - | Some x -> - opt := None; - ensure_termination (f x)) + | None -> + assert false + | Some x -> + opt := None; + ensure_termination (f x)) in (* The real finaliser: fill the cell and send a notification. *) (fun x -> @@ -56,19 +56,19 @@ let finalise f x = (* Exit hook for a finalise_or_exit *) let foe_exit f called weak () = match Weak.get weak 0 with - | None -> - (* The value has been garbage collected, normally this point - is never reached *) - Lwt.return_unit - | Some x -> - (* Just to avoid double finalisation *) - Weak.set weak 0 None; - if !called then - Lwt.return_unit - else begin - called := true; - f x - end + | None -> + (* The value has been garbage collected, normally this point + is never reached *) + Lwt.return_unit + | Some x -> + (* Just to avoid double finalisation *) + Weak.set weak 0 None; + if !called then + Lwt.return_unit + else begin + called := true; + f x + end (* Finaliser for a finalise_or_exit *) let foe_finaliser f called hook = diff --git a/src/unix/lwt_io.ml b/src/unix/lwt_io.ml index d29993b312..9e46422236 100644 --- a/src/unix/lwt_io.ml +++ b/src/unix/lwt_io.ml @@ -56,24 +56,24 @@ let output : output mode = Output (* A channel state *) type 'mode state = | Busy_primitive - (* A primitive is running on the channel *) + (* A primitive is running on the channel *) | Busy_atomic of 'mode channel - (* An atomic operations is being performed on the channel. The - argument is the temporary atomic wrapper. *) + (* An atomic operations is being performed on the channel. The + argument is the temporary atomic wrapper. *) | Waiting_for_busy - (* A queued operation has not yet started. *) + (* A queued operation has not yet started. *) | Idle - (* The channel is unused *) + (* The channel is unused *) | Closed - (* The channel has been closed *) + (* The channel has been closed *) | Invalid - (* The channel is a temporary channel created for an atomic - operation which has terminated. *) + (* The channel is a temporary channel created for an atomic + operation which has terminated. *) (* A wrapper, which ensures that io operations are atomic: *) and 'mode channel = { @@ -123,11 +123,11 @@ and 'mode _channel = { and typ = | Type_normal of (Lwt_bytes.t -> int -> int -> int Lwt.t) * (int64 -> Unix.seek_command -> int64 Lwt.t) - (* The channel has been created with [make]. The first argument - is the refill/flush function and the second is the seek - function. *) + (* The channel has been created with [make]. The first argument + is the refill/flush function and the second is the seek + function. *) | Type_bytes - (* The channel has been created with [of_bytes]. *) + (* The channel has been created with [of_bytes]. *) type input_channel = input channel type output_channel = output channel @@ -160,10 +160,10 @@ let hash_output_channel = !index module Outputs = Weak.Make(struct - type t = output_channel - let hash _ = hash_output_channel () - let equal = ( == ) - end) + type t = output_channel + let hash _ = hash_output_channel () + let equal = ( == ) + end) (* Table of all opened output channels. On exit they are all flushed: *) @@ -172,94 +172,94 @@ let outputs = Outputs.create 32 let position : type mode. mode channel -> int64 = fun wrapper -> let ch = wrapper.channel in match ch.mode with - | Input -> - Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) - | Output -> - Int64.add ch.offset (Int64.of_int ch.ptr) + | Input -> + Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) + | Output -> + Int64.add ch.offset (Int64.of_int ch.ptr) let name : type mode. mode _channel -> string = fun ch -> match ch.mode with - | Input -> "input" - | Output -> "output" + | Input -> "input" + | Output -> "output" let closed_channel ch = Channel_closed(name ch) let invalid_channel ch = Failure(Printf.sprintf "temporary atomic channel %s no more valid" (name ch)) let is_busy ch = match ch.state with - | Invalid -> - raise (invalid_channel ch.channel) - | Idle | Closed -> - false - | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - true + | Invalid -> + raise (invalid_channel ch.channel) + | Idle | Closed -> + false + | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> + true (* Flush/refill the buffer. No race condition could happen because this function is always called atomically: *) let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> match ch.main.state with | Busy_primitive | Busy_atomic _ -> begin match ch.typ with - | Type_normal(perform_io, _) -> - let ptr, len = match ch.mode with - | Input -> - (* Size of data in the buffer *) - let size = ch.max - ch.ptr in - (* If there are still data in the buffer, keep them: *) - if size > 0 then Lwt_bytes.unsafe_blit ch.buffer ch.ptr ch.buffer 0 size; - (* Update positions: *) - ch.ptr <- 0; - ch.max <- size; - (size, ch.length - size) - | Output -> - (0, ch.ptr) in - Lwt.pick [ch.abort_waiter; - if Sys.win32 then - Lwt.catch - (fun () -> perform_io ch.buffer ptr len) - (function - | Unix.Unix_error (Unix.EPIPE, _, _) -> - Lwt.return 0 - | exn -> Lwt.fail exn) [@ocaml.warning "-4"] - else - perform_io ch.buffer ptr len - ] >>= fun n -> - (* Never trust user functions... *) - if n < 0 || n > len then - Lwt.fail (Failure (Printf.sprintf "Lwt_io.perform_io: invalid result of the [%s] function" - (match ch.mode with Input -> "read" | Output -> "write"))) - else begin - (* Update the global offset: *) - ch.offset <- Int64.add ch.offset (Int64.of_int n); - (* Update buffer positions: *) - begin match ch.mode with - | Input -> - ch.max <- ch.max + n - | Output -> - (* Shift remaining data: *) - let len = len - n in - Lwt_bytes.unsafe_blit ch.buffer n ch.buffer 0 len; - ch.ptr <- len - end; - Lwt.return n - end - - | Type_bytes -> begin - match ch.mode with - | Input -> - Lwt.return 0 - | Output -> - Lwt.fail (Failure "cannot flush a channel created with Lwt_io.of_string") - end + | Type_normal(perform_io, _) -> + let ptr, len = match ch.mode with + | Input -> + (* Size of data in the buffer *) + let size = ch.max - ch.ptr in + (* If there are still data in the buffer, keep them: *) + if size > 0 then Lwt_bytes.unsafe_blit ch.buffer ch.ptr ch.buffer 0 size; + (* Update positions: *) + ch.ptr <- 0; + ch.max <- size; + (size, ch.length - size) + | Output -> + (0, ch.ptr) in + Lwt.pick [ch.abort_waiter; + if Sys.win32 then + Lwt.catch + (fun () -> perform_io ch.buffer ptr len) + (function + | Unix.Unix_error (Unix.EPIPE, _, _) -> + Lwt.return 0 + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] + else + perform_io ch.buffer ptr len + ] >>= fun n -> + (* Never trust user functions... *) + if n < 0 || n > len then + Lwt.fail (Failure (Printf.sprintf "Lwt_io.perform_io: invalid result of the [%s] function" + (match ch.mode with Input -> "read" | Output -> "write"))) + else begin + (* Update the global offset: *) + ch.offset <- Int64.add ch.offset (Int64.of_int n); + (* Update buffer positions: *) + begin match ch.mode with + | Input -> + ch.max <- ch.max + n + | Output -> + (* Shift remaining data: *) + let len = len - n in + Lwt_bytes.unsafe_blit ch.buffer n ch.buffer 0 len; + ch.ptr <- len + end; + Lwt.return n + end + + | Type_bytes -> begin + match ch.mode with + | Input -> + Lwt.return 0 + | Output -> + Lwt.fail (Failure "cannot flush a channel created with Lwt_io.of_string") + end end | Closed -> - Lwt.fail (closed_channel ch) + Lwt.fail (closed_channel ch) | Invalid -> - Lwt.fail (invalid_channel ch) + Lwt.fail (invalid_channel ch) | Idle | Waiting_for_busy -> - assert false + assert false let refill = perform_io let flush_partial = perform_io @@ -279,10 +279,10 @@ let safe_flush_total oc = let deepest_wrapper ch = let rec loop wrapper = match wrapper.state with - | Busy_atomic wrapper -> - loop wrapper - | Busy_primitive | Waiting_for_busy | Idle | Closed | Invalid -> - wrapper + | Busy_atomic wrapper -> + loop wrapper + | Busy_primitive | Waiting_for_busy | Idle | Closed | Invalid -> + wrapper in loop ch.main @@ -290,165 +290,165 @@ let auto_flush oc = Lwt.pause () >>= fun () -> let wrapper = deepest_wrapper oc in match wrapper.state with - | Busy_primitive | Waiting_for_busy -> - (* The channel is used, cancel auto flushing. It will be - restarted when the channel Lwt.returns to the [Idle] state: *) - oc.auto_flushing <- false; - Lwt.return_unit + | Busy_primitive | Waiting_for_busy -> + (* The channel is used, cancel auto flushing. It will be + restarted when the channel Lwt.returns to the [Idle] state: *) + oc.auto_flushing <- false; + Lwt.return_unit - | Busy_atomic _ -> - (* Cannot happen since we took the deepest wrapper: *) - assert false + | Busy_atomic _ -> + (* Cannot happen since we took the deepest wrapper: *) + assert false - | Idle -> - oc.auto_flushing <- false; - wrapper.state <- Busy_primitive; - safe_flush_total oc >>= fun () -> - if wrapper.state = Busy_primitive then - wrapper.state <- Idle; - if not (Lwt_sequence.is_empty wrapper.queued) then - Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) (); - Lwt.return_unit + | Idle -> + oc.auto_flushing <- false; + wrapper.state <- Busy_primitive; + safe_flush_total oc >>= fun () -> + if wrapper.state = Busy_primitive then + wrapper.state <- Idle; + if not (Lwt_sequence.is_empty wrapper.queued) then + Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) (); + Lwt.return_unit - | Closed | Invalid -> - Lwt.return_unit + | Closed | Invalid -> + Lwt.return_unit (* A ``locked'' channel is a channel in the state [Busy_primitive] or [Busy_atomic] *) let unlock : type m. m channel -> unit = fun wrapper -> match wrapper.state with | Busy_primitive | Busy_atomic _ -> - if Lwt_sequence.is_empty wrapper.queued then - wrapper.state <- Idle - else begin - wrapper.state <- Waiting_for_busy; - Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () - end; - (* Launches the auto-flusher: *) - let ch = wrapper.channel in - if (* Launch the auto-flusher only if the channel is not busy: *) - (wrapper.state = Idle && - (* Launch the auto-flusher only for output channel: *) - (match ch.mode with Input -> false | Output -> true) && - (* Do not launch two auto-flusher: *) - not ch.auto_flushing && - (* Do not launch the auto-flusher if operations are queued: *) - Lwt_sequence.is_empty wrapper.queued) then begin - ch.auto_flushing <- true; - ignore (auto_flush ch) - end + if Lwt_sequence.is_empty wrapper.queued then + wrapper.state <- Idle + else begin + wrapper.state <- Waiting_for_busy; + Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () + end; + (* Launches the auto-flusher: *) + let ch = wrapper.channel in + if (* Launch the auto-flusher only if the channel is not busy: *) + (wrapper.state = Idle && + (* Launch the auto-flusher only for output channel: *) + (match ch.mode with Input -> false | Output -> true) && + (* Do not launch two auto-flusher: *) + not ch.auto_flushing && + (* Do not launch the auto-flusher if operations are queued: *) + Lwt_sequence.is_empty wrapper.queued) then begin + ch.auto_flushing <- true; + ignore (auto_flush ch) + end | Closed | Invalid -> - (* Do not change channel state if the channel has been closed *) - if not (Lwt_sequence.is_empty wrapper.queued) then - Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () + (* Do not change channel state if the channel has been closed *) + if not (Lwt_sequence.is_empty wrapper.queued) then + Lwt.wakeup_later (Lwt_sequence.take_l wrapper.queued) () | Idle | Waiting_for_busy -> - (* We must never unlock an unlocked channel *) - assert false + (* We must never unlock an unlocked channel *) + assert false (* Wrap primitives into atomic io operations: *) let primitive f wrapper = match wrapper.state with | Idle -> - wrapper.state <- Busy_primitive; - Lwt.finalize - (fun () -> f wrapper.channel) - (fun () -> - unlock wrapper; - Lwt.return_unit) + wrapper.state <- Busy_primitive; + Lwt.finalize + (fun () -> f wrapper.channel) + (fun () -> + unlock wrapper; + Lwt.return_unit) | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - Lwt.add_task_r wrapper.queued >>= fun () -> - begin match wrapper.state with - | Closed -> - (* The channel has been closed while we were waiting *) - unlock wrapper; - Lwt.fail (closed_channel wrapper.channel) - - | Idle | Waiting_for_busy -> - wrapper.state <- Busy_primitive; - Lwt.finalize - (fun () -> f wrapper.channel) - (fun () -> - unlock wrapper; - Lwt.return_unit) - - | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) - - | Busy_primitive | Busy_atomic _ -> - assert false - end + Lwt.add_task_r wrapper.queued >>= fun () -> + begin match wrapper.state with + | Closed -> + (* The channel has been closed while we were waiting *) + unlock wrapper; + Lwt.fail (closed_channel wrapper.channel) + + | Idle | Waiting_for_busy -> + wrapper.state <- Busy_primitive; + Lwt.finalize + (fun () -> f wrapper.channel) + (fun () -> + unlock wrapper; + Lwt.return_unit) + + | Invalid -> + Lwt.fail (invalid_channel wrapper.channel) + + | Busy_primitive | Busy_atomic _ -> + assert false + end | Closed -> - Lwt.fail (closed_channel wrapper.channel) + Lwt.fail (closed_channel wrapper.channel) | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) + Lwt.fail (invalid_channel wrapper.channel) (* Wrap a sequence of io operations into an atomic operation: *) let atomic f wrapper = match wrapper.state with | Idle -> - let tmp_wrapper = { state = Idle; - channel = wrapper.channel; - queued = Lwt_sequence.create () } in - wrapper.state <- Busy_atomic tmp_wrapper; - Lwt.finalize - (fun () -> f tmp_wrapper) - (fun () -> - (* The temporary wrapper is no more valid: *) - tmp_wrapper.state <- Invalid; - unlock wrapper; - Lwt.return_unit) + let tmp_wrapper = { state = Idle; + channel = wrapper.channel; + queued = Lwt_sequence.create () } in + wrapper.state <- Busy_atomic tmp_wrapper; + Lwt.finalize + (fun () -> f tmp_wrapper) + (fun () -> + (* The temporary wrapper is no more valid: *) + tmp_wrapper.state <- Invalid; + unlock wrapper; + Lwt.return_unit) | Busy_primitive | Busy_atomic _ | Waiting_for_busy -> - Lwt.add_task_r wrapper.queued >>= fun () -> - begin match wrapper.state with - | Closed -> - (* The channel has been closed while we were waiting *) - unlock wrapper; - Lwt.fail (closed_channel wrapper.channel) - - | Idle | Waiting_for_busy -> - let tmp_wrapper = { state = Idle; - channel = wrapper.channel; - queued = Lwt_sequence.create () } in - wrapper.state <- Busy_atomic tmp_wrapper; - Lwt.finalize - (fun () -> f tmp_wrapper) - (fun () -> - tmp_wrapper.state <- Invalid; - unlock wrapper; - Lwt.return_unit) - - | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) - - | Busy_primitive | Busy_atomic _ -> - assert false - end + Lwt.add_task_r wrapper.queued >>= fun () -> + begin match wrapper.state with + | Closed -> + (* The channel has been closed while we were waiting *) + unlock wrapper; + Lwt.fail (closed_channel wrapper.channel) + + | Idle | Waiting_for_busy -> + let tmp_wrapper = { state = Idle; + channel = wrapper.channel; + queued = Lwt_sequence.create () } in + wrapper.state <- Busy_atomic tmp_wrapper; + Lwt.finalize + (fun () -> f tmp_wrapper) + (fun () -> + tmp_wrapper.state <- Invalid; + unlock wrapper; + Lwt.return_unit) + + | Invalid -> + Lwt.fail (invalid_channel wrapper.channel) + + | Busy_primitive | Busy_atomic _ -> + assert false + end | Closed -> - Lwt.fail (closed_channel wrapper.channel) + Lwt.fail (closed_channel wrapper.channel) | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) + Lwt.fail (invalid_channel wrapper.channel) let rec abort wrapper = match wrapper.state with | Busy_atomic tmp_wrapper -> - (* Close the depest opened wrapper: *) - abort tmp_wrapper + (* Close the depest opened wrapper: *) + abort tmp_wrapper | Closed -> - (* Double close, just returns the same thing as before *) - Lazy.force wrapper.channel.close + (* Double close, just returns the same thing as before *) + Lazy.force wrapper.channel.close | Invalid -> - Lwt.fail (invalid_channel wrapper.channel) + Lwt.fail (invalid_channel wrapper.channel) | Idle | Busy_primitive | Waiting_for_busy -> - wrapper.state <- Closed; - (* Abort any current real reading/writing operation on the - channel: *) - Lwt.wakeup_exn wrapper.channel.abort_wakener (closed_channel wrapper.channel); - Lazy.force wrapper.channel.close + wrapper.state <- Closed; + (* Abort any current real reading/writing operation on the + channel: *) + Lwt.wakeup_exn wrapper.channel.abort_wakener (closed_channel wrapper.channel); + Lazy.force wrapper.channel.close let close : type mode. mode channel -> unit Lwt.t = fun wrapper -> let channel = wrapper.channel in @@ -456,17 +456,17 @@ let close : type mode. mode channel -> unit Lwt.t = fun wrapper -> Lwt.fail (Failure "Lwt_io.close: cannot close a channel obtained via Lwt_io.atomic") else match channel.mode with - | Input -> - (* Just close it now: *) - abort wrapper - | Output -> - Lwt.catch - (fun () -> - (* Performs all pending actions, flush the buffer, then close it: *) - primitive (fun channel -> - safe_flush_total channel >>= fun () -> abort wrapper) wrapper) - (fun _ -> - abort wrapper) + | Input -> + (* Just close it now: *) + abort wrapper + | Output -> + Lwt.catch + (fun () -> + (* Performs all pending actions, flush the buffer, then close it: *) + primitive (fun channel -> + safe_flush_total channel >>= fun () -> abort wrapper) wrapper) + (fun _ -> + abort wrapper) let is_closed wrapper = match wrapper.state with @@ -478,8 +478,8 @@ let flush_all () = Lwt_list.iter_p (fun wrapper -> Lwt.catch - (fun () -> primitive safe_flush_total wrapper) - (fun _ -> Lwt.return_unit)) + (fun () -> primitive safe_flush_total wrapper) + (fun _ -> Lwt.return_unit)) wrappers let () = @@ -491,20 +491,20 @@ let no_seek _pos _cmd = let make : type m. - ?buffer : Lwt_bytes.t -> - ?close : (unit -> unit Lwt.t) -> - ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> - mode : m mode -> - (Lwt_bytes.t -> int -> int -> int Lwt.t) -> - m channel = fun ?buffer ?(close=Lwt.return) ?(seek=no_seek) ~mode perform_io -> + ?buffer : Lwt_bytes.t -> + ?close : (unit -> unit Lwt.t) -> + ?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) -> + mode : m mode -> + (Lwt_bytes.t -> int -> int -> int Lwt.t) -> + m channel = fun ?buffer ?(close=Lwt.return) ?(seek=no_seek) ~mode perform_io -> let (buffer, size) = match buffer with - | Some buffer -> - check_buffer "Lwt_io.make" buffer; - (buffer, Lwt_bytes.length buffer) - | None -> - let size = !default_buffer_size in - (Lwt_bytes.create size, size) + | Some buffer -> + check_buffer "Lwt_io.make" buffer; + (buffer, Lwt_bytes.length buffer) + | None -> + let size = !default_buffer_size in + (Lwt_bytes.create size, size) in let abort_waiter, abort_wakener = Lwt.wait () in let rec ch = { @@ -512,8 +512,8 @@ let make : length = size; ptr = 0; max = (match mode with - | Input -> 0 - | Output -> size); + | Input -> 0 + | Output -> size); close = lazy(Lwt.catch close Lwt.fail); abort_waiter = abort_waiter; abort_wakener = abort_wakener; @@ -528,8 +528,8 @@ let make : queued = Lwt_sequence.create (); } in (match mode with - | Input -> () - | Output -> Outputs.add outputs wrapper); + | Input -> () + | Output -> Outputs.add outputs wrapper); wrapper let of_bytes ~mode bytes = @@ -565,8 +565,8 @@ let of_fd : type m. ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) -> mo make ?buffer ~close:(match close with - | Some f -> f - | None -> (fun () -> Lwt_unix.close fd)) + | Some f -> f + | None -> (fun () -> Lwt_unix.close fd)) ~seek:(fun pos cmd -> Lwt_unix.LargeFile.lseek fd pos cmd) ~mode perform_io @@ -576,53 +576,53 @@ let of_unix_fd : type m. ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) let buffered : type m. m channel -> int = fun ch -> match ch.channel.mode with - | Input -> ch.channel.max - ch.channel.ptr - | Output -> ch.channel.ptr + | Input -> ch.channel.max - ch.channel.ptr + | Output -> ch.channel.ptr let buffer_size ch = ch.channel.length let resize_buffer : type m. m channel -> int -> unit Lwt.t = fun wrapper len -> if len < min_buffer_size then invalid_arg "Lwt_io.resize_buffer: buffer size too small"; match wrapper.channel.typ with - | Type_bytes -> - Lwt.fail (Failure "Lwt_io.resize_buffer: cannot resize the buffer of a channel created with Lwt_io.of_string") - | Type_normal _ -> - let f : type m. m _channel -> unit Lwt.t = fun ch -> - match ch.mode with - | Input -> - let unread_count = ch.max - ch.ptr in - (* Fail if we want to decrease the buffer size and there is - too much unread data in the buffer: *) - if len < unread_count then - Lwt.fail (Failure "Lwt_io.resize_buffer: cannot decrease buffer size, too much unread data") - else begin - let buffer = Lwt_bytes.create len in - Lwt_bytes.unsafe_blit ch.buffer ch.ptr buffer 0 unread_count; - ch.buffer <- buffer; - ch.length <- len; - ch.ptr <- 0; - ch.max <- unread_count; - Lwt.return_unit - end - | Output -> - (* If we decrease the buffer size, flush the buffer until - the number of buffered bytes fits into the new buffer: *) - let rec loop () = - if ch.ptr > len then - flush_partial ch >>= fun _ -> - loop () - else - Lwt.return_unit - in - loop () >>= fun () -> - let buffer = Lwt_bytes.create len in - Lwt_bytes.unsafe_blit ch.buffer 0 buffer 0 ch.ptr; - ch.buffer <- buffer; - ch.length <- len; - ch.max <- len; - Lwt.return_unit + | Type_bytes -> + Lwt.fail (Failure "Lwt_io.resize_buffer: cannot resize the buffer of a channel created with Lwt_io.of_string") + | Type_normal _ -> + let f : type m. m _channel -> unit Lwt.t = fun ch -> + match ch.mode with + | Input -> + let unread_count = ch.max - ch.ptr in + (* Fail if we want to decrease the buffer size and there is + too much unread data in the buffer: *) + if len < unread_count then + Lwt.fail (Failure "Lwt_io.resize_buffer: cannot decrease buffer size, too much unread data") + else begin + let buffer = Lwt_bytes.create len in + Lwt_bytes.unsafe_blit ch.buffer ch.ptr buffer 0 unread_count; + ch.buffer <- buffer; + ch.length <- len; + ch.ptr <- 0; + ch.max <- unread_count; + Lwt.return_unit + end + | Output -> + (* If we decrease the buffer size, flush the buffer until + the number of buffered bytes fits into the new buffer: *) + let rec loop () = + if ch.ptr > len then + flush_partial ch >>= fun _ -> + loop () + else + Lwt.return_unit in - primitive f wrapper + loop () >>= fun () -> + let buffer = Lwt_bytes.create len in + Lwt_bytes.unsafe_blit ch.buffer 0 buffer 0 ch.ptr; + ch.buffer <- buffer; + ch.length <- len; + ch.max <- len; + Lwt.return_unit + in + primitive f wrapper (* +-----------------------------------------------------------------+ | Byte-order | @@ -699,8 +699,8 @@ struct let ptr = ic.ptr in if ptr = ic.max then refill ic >>= function - | 0 -> Lwt.fail End_of_file - | _ -> read_char ic + | 0 -> Lwt.fail End_of_file + | _ -> read_char ic else begin ic.ptr <- ptr + 1; Lwt.return (Lwt_bytes.unsafe_get ic.buffer ptr) @@ -710,41 +710,41 @@ struct Lwt.catch (fun () -> read_char ic >|= fun ch -> Some ch) (function - | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) + | End_of_file -> Lwt.return_none + | exn -> Lwt.fail exn) let read_line ic = let buf = Buffer.create 128 in let rec loop cr_read = Lwt.try_bind (fun _ -> read_char ic) (function - | '\n' -> - Lwt.return(Buffer.contents buf) - | '\r' -> - if cr_read then Buffer.add_char buf '\r'; - loop true - | ch -> - if cr_read then Buffer.add_char buf '\r'; - Buffer.add_char buf ch; - loop false) + | '\n' -> + Lwt.return(Buffer.contents buf) + | '\r' -> + if cr_read then Buffer.add_char buf '\r'; + loop true + | ch -> + if cr_read then Buffer.add_char buf '\r'; + Buffer.add_char buf ch; + loop false) (function - | End_of_file -> - if cr_read then Buffer.add_char buf '\r'; - Lwt.return(Buffer.contents buf) - | exn -> - Lwt.fail exn) + | End_of_file -> + if cr_read then Buffer.add_char buf '\r'; + Lwt.return(Buffer.contents buf) + | exn -> + Lwt.fail exn) in read_char ic >>= function - | '\r' -> loop true - | '\n' -> Lwt.return "" - | ch -> Buffer.add_char buf ch; loop false + | '\r' -> loop true + | '\n' -> Lwt.return "" + | ch -> Buffer.add_char buf ch; loop false let read_line_opt ic = Lwt.catch (fun () -> read_line ic >|= fun ch -> Some ch) (function - | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) + | End_of_file -> Lwt.return_none + | exn -> Lwt.fail exn) let unsafe_read_into ic buf ofs len = let avail = ic.max - ic.ptr in @@ -755,11 +755,11 @@ struct Lwt.return len end else begin refill ic >>= fun n -> - let len = min len n in - Lwt_bytes.unsafe_blit_to_bytes ic.buffer 0 buf ofs len; - ic.ptr <- len; - ic.max <- n; - Lwt.return len + let len = min len n in + Lwt_bytes.unsafe_blit_to_bytes ic.buffer 0 buf ofs len; + ic.ptr <- len; + ic.max <- n; + Lwt.return len end let read_into ic buf ofs len = @@ -774,14 +774,14 @@ struct let rec unsafe_read_into_exactly ic buf ofs len = unsafe_read_into ic buf ofs len >>= function - | 0 -> - Lwt.fail End_of_file - | n -> - let len = len - n in - if len = 0 then - Lwt.return_unit - else - unsafe_read_into_exactly ic buf (ofs + n) len + | 0 -> + Lwt.fail End_of_file + | n -> + let len = len - n in + if len = 0 then + Lwt.return_unit + else + unsafe_read_into_exactly ic buf (ofs + n) len let read_into_exactly ic buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then @@ -813,22 +813,22 @@ struct let str = Bytes.unsafe_to_string buf in ic.ptr <- ic.max; refill ic >>= function - | 0 -> - Lwt.return (rev_concat (len + total_len) (str :: acc)) - | _ -> - read_all ic (len + total_len) (str :: acc) + | 0 -> + Lwt.return (rev_concat (len + total_len) (str :: acc)) + | _ -> + read_all ic (len + total_len) (str :: acc) let read count ic = match count with - | None -> - read_all ic 0 [] >|= Bytes.unsafe_to_string - | Some len -> - let buf = Bytes.create len in - unsafe_read_into ic buf 0 len >>= fun real_len -> - if real_len < len then - Lwt.return Bytes.(sub buf 0 real_len |> unsafe_to_string) - else - Lwt.return (Bytes.unsafe_to_string buf) + | None -> + read_all ic 0 [] >|= Bytes.unsafe_to_string + | Some len -> + let buf = Bytes.create len in + unsafe_read_into ic buf 0 len >>= fun real_len -> + if real_len < len then + Lwt.return Bytes.(sub buf 0 real_len |> unsafe_to_string) + else + Lwt.return (Bytes.unsafe_to_string buf) let read_value ic = let header = Bytes.create 20 in @@ -896,10 +896,10 @@ struct let rec unsafe_write_from_exactly oc buf ofs len = unsafe_write_from oc buf ofs len >>= function - | 0 -> - Lwt.return_unit - | n -> - unsafe_write_from_exactly oc buf (ofs + len - n) n + | 0 -> + Lwt.return_unit + | n -> + unsafe_write_from_exactly oc buf (ofs + len - n) n let write_from_exactly oc buf ofs len = if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then @@ -934,10 +934,10 @@ struct let rec read_block_unsafe ic size f = if ic.max - ic.ptr < size then refill ic >>= function - | 0 -> - Lwt.fail End_of_file - | _ -> - read_block_unsafe ic size f + | 0 -> + Lwt.fail End_of_file + | _ -> + read_block_unsafe ic size f else begin let ptr = ic.ptr in ic.ptr <- ptr + size; @@ -958,16 +958,16 @@ struct if size < 0 || size > min_buffer_size then Lwt.fail (Invalid_argument "Lwt_io.block") else - if ch.max - ch.ptr >= size then begin - let ptr = ch.ptr in - ch.ptr <- ptr + size; - f ch.buffer ptr - end else - match ch.mode with - | Input -> - read_block_unsafe ch size f - | Output -> - write_block_unsafe ch size f + if ch.max - ch.ptr >= size then begin + let ptr = ch.ptr in + ch.ptr <- ptr + size; + f ch.buffer ptr + end else + match ch.mode with + | Input -> + read_block_unsafe ch size f + | Output -> + write_block_unsafe ch size f let perform token da ch = if !token then begin @@ -1042,12 +1042,12 @@ struct and v2 = get buffer (ptr + pos32_2) and v3 = get buffer (ptr + pos32_3) in Lwt.return (Int32.logor - (Int32.logor - (Int32.of_int v0) - (Int32.shift_left (Int32.of_int v1) 8)) - (Int32.logor - (Int32.shift_left (Int32.of_int v2) 16) - (Int32.shift_left (Int32.of_int v3) 24)))) + (Int32.logor + (Int32.of_int v0) + (Int32.shift_left (Int32.of_int v1) 8)) + (Int32.logor + (Int32.shift_left (Int32.of_int v2) 16) + (Int32.shift_left (Int32.of_int v3) 24)))) let read_int64 ic = read_block_unsafe ic 8 @@ -1061,20 +1061,20 @@ struct and v6 = get buffer (ptr + pos64_6) and v7 = get buffer (ptr + pos64_7) in Lwt.return (Int64.logor - (Int64.logor - (Int64.logor - (Int64.of_int v0) - (Int64.shift_left (Int64.of_int v1) 8)) - (Int64.logor - (Int64.shift_left (Int64.of_int v2) 16) - (Int64.shift_left (Int64.of_int v3) 24))) - (Int64.logor - (Int64.logor - (Int64.shift_left (Int64.of_int v4) 32) - (Int64.shift_left (Int64.of_int v5) 40)) - (Int64.logor - (Int64.shift_left (Int64.of_int v6) 48) - (Int64.shift_left (Int64.of_int v7) 56))))) + (Int64.logor + (Int64.logor + (Int64.of_int v0) + (Int64.shift_left (Int64.of_int v1) 8)) + (Int64.logor + (Int64.shift_left (Int64.of_int v2) 16) + (Int64.shift_left (Int64.of_int v3) 24))) + (Int64.logor + (Int64.logor + (Int64.shift_left (Int64.of_int v4) 32) + (Int64.shift_left (Int64.of_int v5) 40)) + (Int64.logor + (Int64.shift_left (Int64.of_int v6) 48) + (Int64.shift_left (Int64.of_int v7) 56))))) let read_float32 ic = read_int32 ic >>= fun x -> Lwt.return (Int32.float_of_bits x) let read_float64 ic = read_int64 ic >>= fun x -> Lwt.return (Int64.float_of_bits x) @@ -1140,37 +1140,37 @@ struct let set_position : type m. m _channel -> int64 -> unit Lwt.t = fun ch pos -> match ch.typ, ch.mode with | Type_normal(_, seek), Output -> - flush_total ch >>= fun () -> + flush_total ch >>= fun () -> + do_seek "set_position" seek pos >>= fun () -> + ch.offset <- pos; + Lwt.return_unit + | Type_normal(_, seek), Input -> + let current = Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) in + if pos >= current && pos <= ch.offset then begin + ch.ptr <- ch.max - (Int64.to_int (Int64.sub ch.offset pos)); + Lwt.return_unit + end else begin do_seek "set_position" seek pos >>= fun () -> ch.offset <- pos; + ch.ptr <- 0; + ch.max <- 0; Lwt.return_unit - | Type_normal(_, seek), Input -> - let current = Int64.sub ch.offset (Int64.of_int (ch.max - ch.ptr)) in - if pos >= current && pos <= ch.offset then begin - ch.ptr <- ch.max - (Int64.to_int (Int64.sub ch.offset pos)); - Lwt.return_unit - end else begin - do_seek "set_position" seek pos >>= fun () -> - ch.offset <- pos; - ch.ptr <- 0; - ch.max <- 0; - Lwt.return_unit - end + end | Type_bytes, _ -> - if pos < 0L || pos > Int64.of_int ch.length then - Lwt.fail (Failure "Lwt_io.set_position: out of bounds") - else begin - ch.ptr <- Int64.to_int pos; - Lwt.return_unit - end + if pos < 0L || pos > Int64.of_int ch.length then + Lwt.fail (Failure "Lwt_io.set_position: out of bounds") + else begin + ch.ptr <- Int64.to_int pos; + Lwt.return_unit + end let length ch = match ch.typ with | Type_normal(_, seek) -> - seek 0L Unix.SEEK_END >>= fun len -> - do_seek "length" seek ch.offset >>= fun () -> - Lwt.return len + seek 0L Unix.SEEK_END >>= fun len -> + do_seek "length" seek ch.offset >>= fun () -> + Lwt.return len | Type_bytes -> - Lwt.return (Int64.of_int ch.length) + Lwt.return (Int64.of_int ch.length) end (* +-----------------------------------------------------------------+ @@ -1277,8 +1277,8 @@ type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian let system_byte_order = Lwt_sys.byte_order include (val (match system_byte_order with - | Little_endian -> (module LE : NumberIO) - | Big_endian -> (module BE : NumberIO)) : NumberIO) + | Little_endian -> (module LE : NumberIO) + | Big_endian -> (module BE : NumberIO)) : NumberIO) (* +-----------------------------------------------------------------+ | Other | @@ -1332,18 +1332,18 @@ type file_name = string let open_file : type m. ?buffer : Lwt_bytes.t -> ?flags : Unix.open_flag list -> ?perm : Unix.file_perm -> mode : m mode -> file_name -> m channel Lwt.t = fun ?buffer ?flags ?perm ~mode filename -> let flags = match flags, mode with | Some l, _ -> - l + l | None, Input -> - [Unix.O_RDONLY; Unix.O_NONBLOCK] + [Unix.O_RDONLY; Unix.O_NONBLOCK] | None, Output -> - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] and perm = match perm, mode with | Some p, _ -> - p + p | None, Input -> - 0 + 0 | None, Output -> - 0o666 + 0o666 in Lwt_unix.openfile filename flags perm >>= fun fd -> Lwt.return (of_fd ?buffer ~mode fd) @@ -1359,16 +1359,16 @@ let file_length filename = with_file ~mode:input filename length let close_socket fd = Lwt.finalize (fun () -> - Lwt.catch - (fun () -> - Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; - Lwt.return_unit) - (function - (* Occurs if the peer closes the connection first. *) - | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit - | exn -> Lwt.fail exn) [@ocaml.warning "-4"]) + Lwt.catch + (fun () -> + Lwt_unix.shutdown fd Unix.SHUTDOWN_ALL; + Lwt.return_unit) + (function + (* Occurs if the peer closes the connection first. *) + | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit + | exn -> Lwt.fail exn) [@ocaml.warning "-4"]) (fun () -> - Lwt_unix.close fd) + Lwt_unix.close fd) let open_connection ?fd ?in_buffer ?out_buffer sockaddr = let fd = match fd with @@ -1378,17 +1378,17 @@ let open_connection ?fd ?in_buffer ?out_buffer sockaddr = let close = lazy (close_socket fd) in Lwt.catch (fun () -> - Lwt_unix.connect fd sockaddr >>= fun () -> - (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); - Lwt.return (make ?buffer:in_buffer - ~close:(fun _ -> Lazy.force close) - ~mode:input (Lwt_bytes.read fd), - make ?buffer:out_buffer - ~close:(fun _ -> Lazy.force close) - ~mode:output (Lwt_bytes.write fd))) + Lwt_unix.connect fd sockaddr >>= fun () -> + (try Lwt_unix.set_close_on_exec fd with Invalid_argument _ -> ()); + Lwt.return (make ?buffer:in_buffer + ~close:(fun _ -> Lazy.force close) + ~mode:input (Lwt_bytes.read fd), + make ?buffer:out_buffer + ~close:(fun _ -> Lazy.force close) + ~mode:output (Lwt_bytes.write fd))) (fun exn -> - Lwt_unix.close fd >>= fun () -> - Lwt.fail exn) + Lwt_unix.close fd >>= fun () -> + Lwt.fail exn) let with_close_connection f (ic, oc) = (* If the user already tried to close the socket and got an exception, we @@ -1486,8 +1486,8 @@ let establish_server_with_client_address Lwt.catch (fun () -> close channel) (fun exn -> - !Lwt.async_exception_hook exn; - Lwt.return_unit) + !Lwt.async_exception_hook exn; + Lwt.return_unit) in let handler addr ((input_channel, output_channel) as channels) = @@ -1498,14 +1498,14 @@ let establish_server_with_client_address Lwt.catch (fun () -> f addr channels) (fun exn -> - !Lwt.async_exception_hook exn; - Lwt.return_unit) + !Lwt.async_exception_hook exn; + Lwt.return_unit) >>= fun () -> - if no_close then Lwt.return_unit - else - best_effort_close input_channel >>= fun () -> - best_effort_close output_channel) + if no_close then Lwt.return_unit + else + best_effort_close input_channel >>= fun () -> + best_effort_close output_channel) in let server, started = @@ -1530,13 +1530,13 @@ let make_stream f lazy_ic = Lwt.return ic) in Lwt_stream.from (fun _ -> - Lazy.force lazy_ic >>= fun ic -> - f ic >>= fun x -> - if x = None then - close ic >>= fun () -> - Lwt.return x - else - Lwt.return x) + Lazy.force lazy_ic >>= fun ic -> + f ic >>= fun x -> + if x = None then + close ic >>= fun () -> + Lwt.return x + else + Lwt.return x) let lines_of_file filename = make_stream read_line_opt (lazy(open_file ~mode:input filename)) diff --git a/src/unix/lwt_log.ml b/src/unix/lwt_log.ml index 69863a9ddb..895e7c5737 100644 --- a/src/unix/lwt_log.ml +++ b/src/unix/lwt_log.ml @@ -40,19 +40,19 @@ let date_string time = let tm = Unix.localtime time in let month_string = match tm.Unix.tm_mon with - | 0 -> "Jan" - | 1 -> "Feb" - | 2 -> "Mar" - | 3 -> "Apr" - | 4 -> "May" - | 5 -> "Jun" - | 6 -> "Jul" - | 7 -> "Aug" - | 8 -> "Sep" - | 9 -> "Oct" - | 10 -> "Nov" - | 11 -> "Dec" - | _ -> Printf.ksprintf failwith "Lwt_log.date_string: invalid month, %d" tm.Unix.tm_mon + | 0 -> "Jan" + | 1 -> "Feb" + | 2 -> "Mar" + | 3 -> "Apr" + | 4 -> "May" + | 5 -> "Jun" + | 6 -> "Jul" + | 7 -> "Aug" + | 8 -> "Sep" + | 9 -> "Oct" + | 10 -> "Nov" + | 11 -> "Dec" + | _ -> Printf.ksprintf failwith "Lwt_log.date_string: invalid month, %d" tm.Unix.tm_mon in Printf.sprintf "%s %2d %02d:%02d:%02d" month_string tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec @@ -60,22 +60,22 @@ let render ~buffer ~template ~section ~level ~message = let time = lazy(Unix.gettimeofday ()) in let file, line, column = match Lwt.get location_key with - | Some loc -> loc - | None -> ("", -1, -1) + | Some loc -> loc + | None -> ("", -1, -1) in Buffer.add_substitute buffer (function - | "date" -> date_string (Lazy.force time) - | "milliseconds" -> Printf.sprintf "%03.0f" (mod_float (Lazy.force time *. 1000.) 1000.) - | "name" -> program_name - | "pid" -> string_of_int (Unix.getpid ()) - | "message" -> message - | "level" -> Lwt_log_core.string_of_level level - | "section" -> Section.name section - | "loc-file" -> file - | "loc-line" -> string_of_int line - | "loc-column" -> string_of_int column - | var -> Printf.ksprintf invalid_arg "Lwt_log.render: unknown variable %S" var) + | "date" -> date_string (Lazy.force time) + | "milliseconds" -> Printf.sprintf "%03.0f" (mod_float (Lazy.force time *. 1000.) 1000.) + | "name" -> program_name + | "pid" -> string_of_int (Unix.getpid ()) + | "message" -> message + | "level" -> Lwt_log_core.string_of_level level + | "section" -> Section.name section + | "loc-file" -> file + | "loc-line" -> string_of_int line + | "loc-column" -> string_of_int column + | var -> Printf.ksprintf invalid_arg "Lwt_log.render: unknown variable %S" var) template (* +-----------------------------------------------------------------+ @@ -85,29 +85,29 @@ let render ~buffer ~template ~section ~level ~message = let channel ?(template="$(name): $(section): $(message)") ~close_mode ~channel () = make ~output:(fun section level lines -> - Lwt_io.atomic begin fun oc -> - let buf = Buffer.create 42 in - Lwt_list.iter_s - (fun line -> - Buffer.clear buf; - render ~buffer:buf ~template ~section ~level ~message:line; - Buffer.add_char buf '\n'; - Lwt_io.write oc (Buffer.contents buf)) - lines >>= fun () -> - Lwt_io.flush oc - end channel) + Lwt_io.atomic begin fun oc -> + let buf = Buffer.create 42 in + Lwt_list.iter_s + (fun line -> + Buffer.clear buf; + render ~buffer:buf ~template ~section ~level ~message:line; + Buffer.add_char buf '\n'; + Lwt_io.write oc (Buffer.contents buf)) + lines >>= fun () -> + Lwt_io.flush oc + end channel) ~close:(match close_mode with - | `Keep -> Lwt.return - | `Close -> (fun () -> Lwt_io.close channel)) + | `Keep -> Lwt.return + | `Close -> (fun () -> Lwt_io.close channel)) let _ = Lwt_log_core.default := channel ~close_mode:`Keep ~channel:Lwt_io.stderr () let file ?(template="$(date): $(section): $(message)") ?(mode=`Append) ?(perm=0o640) ~file_name () = let flags = match mode with | `Append -> - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND; Unix.O_NONBLOCK] + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND; Unix.O_NONBLOCK] | `Truncate -> - [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] in + [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_NONBLOCK] in Lwt_unix.openfile file_name flags perm >>= fun fd -> Lwt_unix.set_close_on_exec fd; let oc = Lwt_io.of_fd ~mode:Lwt_io.output fd in @@ -122,9 +122,9 @@ let level_code = function | Debug -> 7 type syslog_facility = - [ `Auth | `Authpriv | `Cron | `Daemon | `FTP | `Kernel - | `Local0 | `Local1 | `Local2 | `Local3 | `Local4 | `Local5 | `Local6 | `Local7 - | `LPR | `Mail | `News | `Syslog | `User | `UUCP | `NTP | `Security | `Console ] + [ `Auth | `Authpriv | `Cron | `Daemon | `FTP | `Kernel + | `Local0 | `Local1 | `Local2 | `Local3 | `Local4 | `Local5 | `Local6 | `Local7 + | `LPR | `Mail | `News | `Syslog | `User | `UUCP | `NTP | `Security | `Console ] let facility_code = function | `Kernel -> 0 @@ -163,56 +163,56 @@ let shutdown fd = let syslog_connect paths = let rec loop = function | [] -> - (* No working socket found *) - log_intern "no working socket found in {%s}; is syslogd running?" - (String.concat ", " (List.map (Printf.sprintf "\"%s\"") paths)); - Lwt.fail (Sys_error(Unix.error_message Unix.ENOENT)) + (* No working socket found *) + log_intern "no working socket found in {%s}; is syslogd running?" + (String.concat ", " (List.map (Printf.sprintf "\"%s\"") paths)); + Lwt.fail (Sys_error(Unix.error_message Unix.ENOENT)) | path :: paths -> - begin try + begin try Lwt.return (Some (Unix.stat path).Unix.st_kind) with - | Unix.Unix_error(Unix.ENOENT, _, _) -> - Lwt.return_none - | Unix.Unix_error(error, _, _) -> - log_intern "can not stat \"%s\": %s" path (Unix.error_message error); - Lwt.return_none - end >>= (function - | None -> - loop paths - | Some Unix.S_SOCK -> begin - (* First, we try with a dgram socket : *) - let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_DGRAM 0 in - Lwt.catch - (fun () -> - Lwt_unix.connect fd (Unix.ADDR_UNIX path) >>= fun () -> - Lwt_unix.set_close_on_exec fd; - Lwt.return (DGRAM, fd)) - (function + | Unix.Unix_error(Unix.ENOENT, _, _) -> + Lwt.return_none + | Unix.Unix_error(error, _, _) -> + log_intern "can not stat \"%s\": %s" path (Unix.error_message error); + Lwt.return_none + end >>= (function + | None -> + loop paths + | Some Unix.S_SOCK -> begin + (* First, we try with a dgram socket : *) + let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_DGRAM 0 in + Lwt.catch + (fun () -> + Lwt_unix.connect fd (Unix.ADDR_UNIX path) >>= fun () -> + Lwt_unix.set_close_on_exec fd; + Lwt.return (DGRAM, fd)) + (function | Unix.Unix_error(Unix.EPROTOTYPE, _, _) -> begin Lwt_unix.close fd >>= fun () -> (* Then try with a stream socket: *) let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in Lwt.catch (fun () -> - Lwt_unix.connect fd (Unix.ADDR_UNIX path) >>= fun () -> - Lwt_unix.set_close_on_exec fd; - Lwt.return (STREAM, fd)) + Lwt_unix.connect fd (Unix.ADDR_UNIX path) >>= fun () -> + Lwt_unix.set_close_on_exec fd; + Lwt.return (STREAM, fd)) (function - | Unix.Unix_error(error, _, _) -> + | Unix.Unix_error(error, _, _) -> Lwt_unix.close fd >>= fun () -> log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); loop paths - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) end | Unix.Unix_error(error, _, _) -> - Lwt_unix.close fd >>= fun () -> - log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); - loop paths + Lwt_unix.close fd >>= fun () -> + log_intern "can not connect to \"%s\": %s" path (Unix.error_message error); + loop paths | exn -> Lwt.fail exn) [@ocaml.warning "-4"] - end - | Some _ -> - log_intern "\"%s\" is not a socket" path; - loop paths) [@ocaml.warning "-4"] + end + | Some _ -> + log_intern "\"%s\" is not a socket" path; + loop paths) [@ocaml.warning "-4"] in loop paths @@ -244,47 +244,47 @@ let syslog ?(template="$(date) $(name)[$(pid)]: $(section): $(message)") ?(paths let syslog_socket = ref None and mutex = Lwt_mutex.create () in let get_syslog () = match !syslog_socket with | Some x -> - Lwt.return x + Lwt.return x | None -> - syslog_connect paths >>= fun x -> - syslog_socket := Some x; - Lwt.return x + syslog_connect paths >>= fun x -> + syslog_socket := Some x; + Lwt.return x in make ~output:(fun section level lines -> - Lwt_mutex.with_lock mutex + Lwt_mutex.with_lock mutex + (fun () -> + let buf = Buffer.create 42 in + let make_line socket_type msg = + Buffer.clear buf; + Printf.bprintf buf "<%d>" ((facility_code facility lsl 3) lor level_code level); + render ~buffer:buf ~template ~section ~level ~message:msg; + if socket_type = STREAM then Buffer.add_char buf '\x00'; + truncate buf 1024 + in + let rec print socket_type fd = function + | [] -> + Lwt.return_unit + | line :: lines -> + Lwt.catch (fun () -> - let buf = Buffer.create 42 in - let make_line socket_type msg = - Buffer.clear buf; - Printf.bprintf buf "<%d>" ((facility_code facility lsl 3) lor level_code level); - render ~buffer:buf ~template ~section ~level ~message:msg; - if socket_type = STREAM then Buffer.add_char buf '\x00'; - truncate buf 1024 - in - let rec print socket_type fd = function - | [] -> - Lwt.return_unit - | line :: lines -> - Lwt.catch - (fun () -> - write_string fd (make_line socket_type line) >>= fun () -> - print socket_type fd lines) - (function - | Unix.Unix_error(_, _, _) -> - (* Try to reconnect *) - shutdown fd >>= fun () -> - syslog_socket := None; - get_syslog () >>= fun (socket_type, fd) -> - write_string fd (make_line socket_type line) >>= fun () -> - print socket_type fd lines - | exn -> Lwt.fail exn) - in - get_syslog () >>= fun (socket_type, fd) -> - print socket_type fd lines)) + write_string fd (make_line socket_type line) >>= fun () -> + print socket_type fd lines) + (function + | Unix.Unix_error(_, _, _) -> + (* Try to reconnect *) + shutdown fd >>= fun () -> + syslog_socket := None; + get_syslog () >>= fun (socket_type, fd) -> + write_string fd (make_line socket_type line) >>= fun () -> + print socket_type fd lines + | exn -> Lwt.fail exn) + in + get_syslog () >>= fun (socket_type, fd) -> + print socket_type fd lines)) ~close:(fun () -> - match !syslog_socket with - | None -> - Lwt.return_unit - | Some(_socket_type, fd) -> - shutdown fd) + match !syslog_socket with + | None -> + Lwt.return_unit + | Some(_socket_type, fd) -> + shutdown fd) diff --git a/src/unix/lwt_main.ml b/src/unix/lwt_main.ml index b27080c86f..d31abbfa8b 100644 --- a/src/unix/lwt_main.ml +++ b/src/unix/lwt_main.ml @@ -31,36 +31,36 @@ let rec run t = (* Wakeup paused threads now. *) Lwt.wakeup_paused (); match Lwt.poll t with - | Some x -> - x - | None -> - (* Call enter hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; - (* Do the main loop call. *) - Lwt_engine.iter (Lwt.paused_count () = 0 && Lwt_sequence.is_empty yielded); - (* Wakeup paused threads again. *) - Lwt.wakeup_paused (); - (* Wakeup yielded threads now. *) - if not (Lwt_sequence.is_empty yielded) then begin - let tmp = Lwt_sequence.create () in - Lwt_sequence.transfer_r yielded tmp; - Lwt_sequence.iter_l (fun wakener -> Lwt.wakeup wakener ()) tmp - end; - (* Call leave hooks. *) - Lwt_sequence.iter_l (fun f -> f ()) leave_iter_hooks; - run t + | Some x -> + x + | None -> + (* Call enter hooks. *) + Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; + (* Do the main loop call. *) + Lwt_engine.iter (Lwt.paused_count () = 0 && Lwt_sequence.is_empty yielded); + (* Wakeup paused threads again. *) + Lwt.wakeup_paused (); + (* Wakeup yielded threads now. *) + if not (Lwt_sequence.is_empty yielded) then begin + let tmp = Lwt_sequence.create () in + Lwt_sequence.transfer_r yielded tmp; + Lwt_sequence.iter_l (fun wakener -> Lwt.wakeup wakener ()) tmp + end; + (* Call leave hooks. *) + Lwt_sequence.iter_l (fun f -> f ()) leave_iter_hooks; + run t let exit_hooks = Lwt_sequence.create () let rec call_hooks () = match Lwt_sequence.take_opt_l exit_hooks with - | None -> - Lwt.return_unit - | Some f -> - Lwt.catch - (fun () -> f ()) - (fun _ -> Lwt.return_unit) >>= fun () -> - call_hooks () + | None -> + Lwt.return_unit + | Some f -> + Lwt.catch + (fun () -> f ()) + (fun _ -> Lwt.return_unit) >>= fun () -> + call_hooks () let () = at_exit (fun () -> diff --git a/src/unix/lwt_process.ml b/src/unix/lwt_process.ml index dfe6b6983c..874b9eabf5 100644 --- a/src/unix/lwt_process.ml +++ b/src/unix/lwt_process.ml @@ -30,11 +30,11 @@ let shell = fun cmd -> ("", [|"/bin/sh"; "-c"; cmd|]) type redirection = - [ `Keep - | `Dev_null - | `Close - | `FD_copy of Unix.file_descr - | `FD_move of Unix.file_descr ] + [ `Keep + | `Dev_null + | `Close + | `FD_copy of Unix.file_descr + | `FD_move of Unix.file_descr ] (* +-----------------------------------------------------------------+ | OS-depentent command spawning | @@ -49,16 +49,16 @@ type proc = { let win32_get_fd fd redirection = match redirection with - | `Keep -> - Some fd - | `Dev_null -> - Some (Unix.openfile "nul" [Unix.O_RDWR] 0o666) - | `Close -> - None - | `FD_copy fd' -> - Some fd' - | `FD_move fd' -> - Some fd' + | `Keep -> + Some fd + | `Dev_null -> + Some (Unix.openfile "nul" [Unix.O_RDWR] 0o666) + | `Close -> + None + | `FD_copy fd' -> + Some fd' + | `FD_move fd' -> + Some fd' external win32_create_process : string option -> string -> string option -> (Unix.file_descr option * Unix.file_descr option * Unix.file_descr option) -> proc = "lwt_process_create_process" @@ -72,34 +72,34 @@ let win32_spawn (prog, args) env ?(stdin:redirection=`Keep) ?(stdout:redirection let cmdline = String.concat " " (List.map win32_quote (Array.to_list args)) in let env = match env with - | None -> - None - | Some env -> - let len = Array.fold_left (fun len str -> String.length str + len + 1) 1 env in - let res = Bytes.create len in - let ofs = - Array.fold_left - (fun ofs str -> - let len = String.length str in - String.blit str 0 res ofs len; - Bytes.set res (ofs + len) '\000'; - ofs + len + 1) - 0 env - in - Bytes.set res ofs '\000'; - Some (Bytes.unsafe_to_string res) + | None -> + None + | Some env -> + let len = Array.fold_left (fun len str -> String.length str + len + 1) 1 env in + let res = Bytes.create len in + let ofs = + Array.fold_left + (fun ofs str -> + let len = String.length str in + String.blit str 0 res ofs len; + Bytes.set res (ofs + len) '\000'; + ofs + len + 1) + 0 env + in + Bytes.set res ofs '\000'; + Some (Bytes.unsafe_to_string res) in List.iter Unix.set_close_on_exec toclose; let stdin_fd = win32_get_fd Unix.stdin stdin and stdout_fd = win32_get_fd Unix.stdout stdout and stderr_fd = win32_get_fd Unix.stderr stderr in let proc = win32_create_process (if prog = "" then None else Some prog) cmdline env - (stdin_fd, stdout_fd, stderr_fd) in + (stdin_fd, stdout_fd, stderr_fd) in let close = function | `FD_move fd -> - Unix.close fd + Unix.close fd | _ -> - () + () in close stdin; close stdout; @@ -119,54 +119,54 @@ let win32_terminate proc = let unix_redirect fd redirection = match redirection with | `Keep -> - () + () | `Dev_null -> - Unix.close fd; - let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0o666 in - if fd <> dev_null then begin - Unix.dup2 dev_null fd; - Unix.close dev_null - end + Unix.close fd; + let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR] 0o666 in + if fd <> dev_null then begin + Unix.dup2 dev_null fd; + Unix.close dev_null + end | `Close -> - Unix.close fd + Unix.close fd | `FD_copy fd' -> - Unix.dup2 fd' fd + Unix.dup2 fd' fd | `FD_move fd' -> - Unix.dup2 fd' fd; - Unix.close fd' + Unix.dup2 fd' fd; + Unix.close fd' external sys_exit : int -> 'a = "caml_sys_exit" let unix_spawn (prog, args) env ?(stdin:redirection=`Keep) ?(stdout:redirection=`Keep) ?(stderr:redirection=`Keep) toclose = let prog = if prog = "" && Array.length args > 0 then args.(0) else prog in match Lwt_unix.fork () with - | 0 -> - unix_redirect Unix.stdin stdin; - unix_redirect Unix.stdout stdout; - unix_redirect Unix.stderr stderr; - List.iter Unix.close toclose; - begin - try - match env with - | None -> - Unix.execvp prog args - | Some env -> - Unix.execvpe prog args env - with _ -> - (* Do not run at_exit hooks *) - sys_exit 127 - end - | id -> - let close = function - | `FD_move fd -> - Unix.close fd - | _ -> - () - in - close stdin; - close stdout; - close stderr; - { id; fd = Unix.stdin } + | 0 -> + unix_redirect Unix.stdin stdin; + unix_redirect Unix.stdout stdout; + unix_redirect Unix.stderr stderr; + List.iter Unix.close toclose; + begin + try + match env with + | None -> + Unix.execvp prog args + | Some env -> + Unix.execvpe prog args env + with _ -> + (* Do not run at_exit hooks *) + sys_exit 127 + end + | id -> + let close = function + | `FD_move fd -> + Unix.close fd + | _ -> + () + in + close stdin; + close stdout; + close stderr; + { id; fd = Unix.stdin } let unix_waitproc proc = Lwt_unix.wait4 [] proc.id @@ -189,91 +189,91 @@ let status (_pid, status, _rusage) = status let rusage (_pid, _status, rusage) = rusage external cast_chan : 'a Lwt_io.channel -> unit Lwt_io.channel = "%identity" - (* Transform a channel into a channel that only support closing. *) +(* Transform a channel into a channel that only support closing. *) let ignore_close chan = ignore (Lwt_io.close chan) class virtual common timeout proc channels = let wait = waitproc proc in -object(self) - val mutable closed = false + object(self) + val mutable closed = false - method pid = proc.id + method pid = proc.id - method state = - match Lwt.poll wait with + method state = + match Lwt.poll wait with | None -> Running | Some (_pid, status, _rusage) -> Exited status - method kill signum = - if Lwt.state wait = Lwt.Sleep then - Unix.kill proc.id signum - - method terminate = - if Lwt.state wait = Lwt.Sleep then - terminate proc - - method close = - if closed then self#status - else ( - closed <- true; - Lwt.protected (Lwt.join (List.map Lwt_io.close channels)) - >>= fun () -> self#status - ) - method status = Lwt.protected wait >|= status - method rusage = Lwt.protected wait >|= rusage - - initializer - (* Ensure channels are closed when no longer used. *) - List.iter (Gc.finalise ignore_close) channels; - (* Handle timeout. *) - match timeout with + method kill signum = + if Lwt.state wait = Lwt.Sleep then + Unix.kill proc.id signum + + method terminate = + if Lwt.state wait = Lwt.Sleep then + terminate proc + + method close = + if closed then self#status + else ( + closed <- true; + Lwt.protected (Lwt.join (List.map Lwt_io.close channels)) + >>= fun () -> self#status + ) + method status = Lwt.protected wait >|= status + method rusage = Lwt.protected wait >|= rusage + + initializer + (* Ensure channels are closed when no longer used. *) + List.iter (Gc.finalise ignore_close) channels; + (* Handle timeout. *) + match timeout with | None -> - () + () | Some dt -> - ignore ( - (* Ignore errors since they can be obtained by - self#close. *) - Lwt.try_bind - (fun () -> - Lwt.choose [(Lwt_unix.sleep dt >>= fun () -> Lwt.return_false); - (wait >>= fun _ -> Lwt.return_true)]) - (function - | true -> - Lwt.return_unit - | false -> - self#terminate; - self#close >>= fun _ -> Lwt.return_unit) - (fun _ -> - (* The exception is dropped because it can be - obtained with self#close. *) - Lwt.return_unit) - ) -end + ignore ( + (* Ignore errors since they can be obtained by + self#close. *) + Lwt.try_bind + (fun () -> + Lwt.choose [(Lwt_unix.sleep dt >>= fun () -> Lwt.return_false); + (wait >>= fun _ -> Lwt.return_true)]) + (function + | true -> + Lwt.return_unit + | false -> + self#terminate; + self#close >>= fun _ -> Lwt.return_unit) + (fun _ -> + (* The exception is dropped because it can be + obtained with self#close. *) + Lwt.return_unit) + ) + end class process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = let proc = spawn cmd env ?stdin ?stdout ?stderr [] in -object - inherit common timeout proc [] -end + object + inherit common timeout proc [] + end class process_in ?timeout ?env ?stdin ?stderr cmd = let stdout_r, stdout_w = Unix.pipe () in let proc = spawn cmd env ?stdin ~stdout:(`FD_move stdout_w) ?stderr [stdout_r] in let stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r in -object - inherit common timeout proc [cast_chan stdout] - method stdout = stdout -end + object + inherit common timeout proc [cast_chan stdout] + method stdout = stdout + end class process_out ?timeout ?env ?stdout ?stderr cmd = let stdin_r, stdin_w = Unix.pipe () in let proc = spawn cmd env ~stdin:(`FD_move stdin_r) ?stdout ?stderr [stdin_w] in let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w in -object - inherit common timeout proc [cast_chan stdin] - method stdin = stdin -end + object + inherit common timeout proc [cast_chan stdin] + method stdin = stdin + end class process ?timeout ?env ?stderr cmd = let stdin_r, stdin_w = Unix.pipe () @@ -281,11 +281,11 @@ class process ?timeout ?env ?stderr cmd = let proc = spawn cmd env ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ?stderr [stdin_w; stdout_r] in let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r in -object - inherit common timeout proc [cast_chan stdin; cast_chan stdout] - method stdin = stdin - method stdout = stdout -end + object + inherit common timeout proc [cast_chan stdin; cast_chan stdout] + method stdin = stdin + method stdout = stdout + end class process_full ?timeout ?env cmd = let stdin_r, stdin_w = Unix.pipe () @@ -295,12 +295,12 @@ class process_full ?timeout ?env cmd = let stdin = Lwt_io.of_unix_fd ~mode:Lwt_io.output stdin_w and stdout = Lwt_io.of_unix_fd ~mode:Lwt_io.input stdout_r and stderr = Lwt_io.of_unix_fd ~mode:Lwt_io.input stderr_r in -object - inherit common timeout proc [cast_chan stdin; cast_chan stdout; cast_chan stderr] - method stdin = stdin - method stdout = stdout - method stderr = stderr -end + object + inherit common timeout proc [cast_chan stdin; cast_chan stdout; cast_chan stderr] + method stdin = stdin + method stdout = stdout + method stderr = stderr + end let open_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd = new process_none ?timeout ?env ?stdin ?stdout ?stderr cmd let open_process_in ?timeout ?env ?stdin ?stderr cmd = new process_in ?timeout ?env ?stdin ?stderr cmd @@ -313,8 +313,8 @@ let make_with backend ?timeout ?env cmd f = Lwt.finalize (fun () -> f process) (fun () -> - process#close >>= fun _ -> - Lwt.return_unit) + process#close >>= fun _ -> + Lwt.return_unit) let with_process_none ?timeout ?env ?stdin ?stdout ?stderr cmd f = make_with (open_process_none ?stdin ?stdout ?stderr) ?timeout ?env cmd f let with_process_in ?timeout ?env ?stdin ?stderr cmd f = make_with (open_process_in ?stdin ?stderr) ?timeout ?env cmd f @@ -335,31 +335,31 @@ let read_opt read ic = Lwt.catch (fun () -> read ic >|= fun x -> Some x) (function - | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> + | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) [@ocaml.warning "-4"] + | exn -> Lwt.fail exn) [@ocaml.warning "-4"] let recv_chars pr = let ic = pr#stdout in Gc.finalise ignore_close ic; Lwt_stream.from (fun _ -> - read_opt Lwt_io.read_char ic >>= fun x -> - if x = None then begin - Lwt_io.close ic >>= fun () -> - Lwt.return x - end else - Lwt.return x) + read_opt Lwt_io.read_char ic >>= fun x -> + if x = None then begin + Lwt_io.close ic >>= fun () -> + Lwt.return x + end else + Lwt.return x) let recv_lines pr = let ic = pr#stdout in Gc.finalise ignore_close ic; Lwt_stream.from (fun _ -> - read_opt Lwt_io.read_line ic >>= fun x -> - if x = None then begin - Lwt_io.close ic >>= fun () -> - Lwt.return x - end else - Lwt.return x) + read_opt Lwt_io.read_line ic >>= fun x -> + if x = None then begin + Lwt_io.close ic >>= fun () -> + Lwt.return x + end else + Lwt.return x) let recv pr = let ic = pr#stdout in @@ -422,31 +422,31 @@ let monitor sender st = Lwt_stream.from (fun () -> match !state with - | Init -> - let getter = Lwt.apply Lwt_stream.get st in - let result _ = - match Lwt.state sender with - | Lwt.Sleep -> - (* The sender is still sleeping, behave as the - getter. *) - getter - | Lwt.Return _ -> - (* The sender terminated successfully, we are - done monitoring it. *) - state := Done; - getter - | Lwt.Fail _ -> - (* The sender failed, behave as the sender for - this element and save current getter. *) - state := Save getter; - sender - in - Lwt.try_bind (fun () -> Lwt.choose [sender; getter]) result result - | Save t -> + | Init -> + let getter = Lwt.apply Lwt_stream.get st in + let result _ = + match Lwt.state sender with + | Lwt.Sleep -> + (* The sender is still sleeping, behave as the + getter. *) + getter + | Lwt.Return _ -> + (* The sender terminated successfully, we are + done monitoring it. *) state := Done; - t - | Done -> - Lwt_stream.get st) + getter + | Lwt.Fail _ -> + (* The sender failed, behave as the sender for + this element and save current getter. *) + state := Save getter; + sender + in + Lwt.try_bind (fun () -> Lwt.choose [sender; getter]) result result + | Save t -> + state := Done; + t + | Done -> + Lwt_stream.get st) let pmap ?timeout ?env ?stderr cmd text = let pr = open_process ?timeout ?env ?stderr cmd in @@ -455,15 +455,15 @@ let pmap ?timeout ?env ?stderr cmd text = let getter = recv pr in Lwt.catch (fun () -> - (* Wait for both to terminate, returning the result of the - getter. *) - sender >>= fun () -> getter) + (* Wait for both to terminate, returning the result of the + getter. *) + sender >>= fun () -> getter) (function - | Lwt.Canceled as exn -> + | Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; Lwt.fail exn - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) let pmap_chars ?timeout ?env ?stderr cmd chars = let pr = open_process ?timeout ?env ?stderr cmd in @@ -477,15 +477,15 @@ let pmap_line ?timeout ?env ?stderr cmd line = let getter = recv_line pr in Lwt.catch (fun () -> - (* Wait for both to terminate, returning the result of the - getter. *) - sender >>= fun () -> getter) + (* Wait for both to terminate, returning the result of the + getter. *) + sender >>= fun () -> getter) (function - | Lwt.Canceled as exn -> + | Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; Lwt.fail exn - | exn -> Lwt.fail exn) + | exn -> Lwt.fail exn) let pmap_lines ?timeout ?env ?stderr cmd lines = let pr = open_process ?timeout ?env ?stderr cmd in diff --git a/src/unix/lwt_sys.ml b/src/unix/lwt_sys.ml index b17fd1c27b..8c4d324c06 100644 --- a/src/unix/lwt_sys.ml +++ b/src/unix/lwt_sys.ml @@ -26,18 +26,18 @@ let () = Callback.register_exception "lwt:not-available" (Not_available "") let windows = Sys.win32 type feature = - [ `wait4 - | `get_cpu - | `get_affinity - | `set_affinity - | `recv_msg - | `send_msg - | `fd_passing - | `get_credentials - | `mincore - | `madvise - | `fdatasync - | `libev ] + [ `wait4 + | `get_cpu + | `get_affinity + | `set_affinity + | `recv_msg + | `send_msg + | `fd_passing + | `get_credentials + | `mincore + | `madvise + | `fdatasync + | `libev ] let have = function | `wait4 diff --git a/src/unix/lwt_throttle.ml b/src/unix/lwt_throttle.ml index f27aaa636c..221e9acbaf 100644 --- a/src/unix/lwt_throttle.ml +++ b/src/unix/lwt_throttle.ml @@ -68,7 +68,7 @@ module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct let to_run = (Queue.take elt.queue)::to_run in update to_run (i-1) with - | Queue.Empty -> i, 0, to_run + | Queue.Empty -> i, 0, to_run in let not_consumed, waiting, to_run = update to_run t.rate in let consumed = t.rate - not_consumed in @@ -95,10 +95,10 @@ module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct Lwt_unix.sleep 1. >>= fun () -> Lwt.catch (fun () -> - clean_table t; - Lwt.return_unit) + clean_table t; + Lwt.return_unit) (fun exn -> - Lwt_log.fatal ~exn ~section "internal error") + Lwt_log.fatal ~exn ~section "internal error") in Some t @@ -119,15 +119,15 @@ module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct else (elt.consumed <- succ elt.consumed; Lwt.return_true) with - | Not_found -> - let elt = { consumed = 1; - queue = Queue.create () } in - MH.add t.table key elt; - Lwt.return_true + | Not_found -> + let elt = { consumed = 1; + queue = Queue.create () } in + MH.add t.table key elt; + Lwt.return_true in (match t.cleaning with - | None -> launch_cleaning t - | Some _ -> ()); + | None -> launch_cleaning t + | Some _ -> ()); res end diff --git a/src/unix/lwt_timeout.ml b/src/unix/lwt_timeout.ml index 7373c0eeec..3e72fa706f 100644 --- a/src/unix/lwt_timeout.ml +++ b/src/unix/lwt_timeout.ml @@ -85,17 +85,17 @@ let set_exn_handler f = handle_exn := f let rec loop () = stopped := false; Lwt.bind (Lwt_unix.sleep 1.) (fun () -> - let s = !buckets.(!curr) in - while not (lst_is_empty s) do - let x = lst_peek s in - decr count; -(*XXX Should probably report any exception *) - try - x.action () - with e -> !handle_exn e - done; - curr := (!curr + 1) mod (Array.length !buckets); - if !count > 0 then loop () else begin stopped := true; Lwt.return_unit end) + let s = !buckets.(!curr) in + while not (lst_is_empty s) do + let x = lst_peek s in + decr count; + (*XXX Should probably report any exception *) + try + x.action () + with e -> !handle_exn e + done; + curr := (!curr + 1) mod (Array.length !buckets); + if !count > 0 then loop () else begin stopped := true; Lwt.return_unit end) let start x = let in_list = lst_in_list x in diff --git a/src/unix/lwt_unix.cppo.ml b/src/unix/lwt_unix.cppo.ml index b701815118..6e28451db6 100644 --- a/src/unix/lwt_unix.cppo.ml +++ b/src/unix/lwt_unix.cppo.ml @@ -37,16 +37,16 @@ let default_async_method_var = ref Async_detach let () = try match Sys.getenv "LWT_ASYNC_METHOD" with - | "none" -> - default_async_method_var := Async_none - | "detach" -> - default_async_method_var := Async_detach - | "switch" -> - default_async_method_var := Async_switch - | str -> - Printf.eprintf - "%s: invalid lwt async method: '%s', must be 'none', 'detach' or 'switch'\n%!" - (Filename.basename Sys.executable_name) str + | "none" -> + default_async_method_var := Async_none + | "detach" -> + default_async_method_var := Async_detach + | "switch" -> + default_async_method_var := Async_switch + | str -> + Printf.eprintf + "%s: invalid lwt async method: '%s', must be 'none', 'detach' or 'switch'\n%!" + (Filename.basename Sys.executable_name) str with Not_found -> () @@ -57,8 +57,8 @@ let async_method_key = Lwt.new_key () let async_method () = match Lwt.get async_method_key with - | Some am -> am - | None -> !default_async_method_var + | Some am -> am + | None -> !default_async_method_var let with_async_none f = Lwt.with_value async_method_key (Some Async_none) f @@ -84,10 +84,10 @@ type notifier = { } module Notifiers = Hashtbl.Make(struct - type t = int - let equal (x : int) (y : int) = x = y - let hash (x : int) = x - end) + type t = int + let equal (x : int) (y : int) = x = y + let hash (x : int) = x + end) let notifiers = Notifiers.create 1024 @@ -116,12 +116,12 @@ let set_notification id f = let call_notification id = match try Some(Notifiers.find notifiers id) with Not_found -> None with - | Some notifier -> - if notifier.notify_once then - stop_notification id; - notifier.notify_handler () - | None -> - () + | Some notifier -> + if notifier.notify_once then + stop_notification id; + notifier.notify_handler () + | None -> + () (* +-----------------------------------------------------------------+ | Sleepers | @@ -158,14 +158,14 @@ let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()] type 'a job external start_job : 'a job -> async_method -> bool = "lwt_unix_start_job" - (* Starts the given job with given parameters. It returns [true] - if the job is already terminated. *) +(* Starts the given job with given parameters. It returns [true] + if the job is already terminated. *) [@@@ocaml.warning "-3"] external check_job : 'a job -> int -> bool = "lwt_unix_check_job" "noalloc" - (* Check whether that a job has terminated or not. If it has not - yet terminated, it is marked so it will send a notification - when it finishes. *) +(* Check whether that a job has terminated or not. If it has not + yet terminated, it is marked so it will send a notification + when it finishes. *) [@@@ocaml.warning "+3"] (* For all running job, a waiter and a function to abort it. *) @@ -173,8 +173,8 @@ let jobs = Lwt_sequence.create () let rec abort_jobs exn = match Lwt_sequence.take_opt_l jobs with - | Some (_, f) -> f exn; abort_jobs exn - | None -> () + | Some (_, f) -> f exn; abort_jobs exn + | None -> () let cancel_jobs () = abort_jobs Lwt.Canceled @@ -198,9 +198,9 @@ let run_job_aux async_method job result = let waiter, wakener = Lwt.wait () in (* Add the job to the sequence of all jobs. *) let node = Lwt_sequence.add_l ( - (waiter >>= fun _ -> Lwt.return_unit), - (fun exn -> if Lwt.state waiter = Lwt.Sleep then Lwt.wakeup_exn wakener exn)) - jobs in + (waiter >>= fun _ -> Lwt.return_unit), + (fun exn -> if Lwt.state waiter = Lwt.Sleep then Lwt.wakeup_exn wakener exn)) + jobs in ignore begin (* Create the notification for asynchronous wakeup. *) let id = @@ -222,22 +222,22 @@ let run_job_aux async_method job result = let choose_async_method = function | Some async_method -> - async_method + async_method | None -> - match Lwt.get async_method_key with - | Some am -> am - | None -> !default_async_method_var + match Lwt.get async_method_key with + | Some am -> am + | None -> !default_async_method_var let execute_job ?async_method ~job ~result ~free = let async_method = choose_async_method async_method in run_job_aux async_method job (fun job -> let x = wrap_result result job in free job; x) external self_result : 'a job -> 'a = "lwt_unix_self_result" - (* returns the result of a job using the [result] field of the C - job structure. *) +(* returns the result of a job using the [result] field of the C + job structure. *) external run_job_sync : 'a job -> 'a = "lwt_unix_run_job_sync" - (* Exeuctes a job synchronously and returns its result. *) +(* Exeuctes a job synchronously and returns its result. *) let self_result job = try @@ -300,45 +300,45 @@ let is_blocking ?blocking ?(set_flags=true) fd = if Sys.win32 then begin if is_socket fd then match blocking, set_flags with - | Some state, false -> - lazy(Lwt.return state) - | Some true, true -> - lazy(Unix.clear_nonblock fd; - Lwt.return_true) - | Some false, true -> - lazy(Unix.set_nonblock fd; - Lwt.return_false) - | None, false -> - lazy(Lwt.return_false) - | None, true -> - lazy(Unix.set_nonblock fd; - Lwt.return_false) - else - match blocking with - | Some state -> - lazy(Lwt.return state) - | None -> - lazy(Lwt.return_true) - end else begin - match blocking, set_flags with | Some state, false -> - lazy(Lwt.return state) + lazy(Lwt.return state) | Some true, true -> - lazy(Unix.clear_nonblock fd; - Lwt.return_true) + lazy(Unix.clear_nonblock fd; + Lwt.return_true) | Some false, true -> - lazy(Unix.set_nonblock fd; - Lwt.return_false) + lazy(Unix.set_nonblock fd; + Lwt.return_false) | None, false -> - lazy(guess_blocking fd) + lazy(Lwt.return_false) | None, true -> - lazy(guess_blocking fd >>= function - | true -> - Unix.clear_nonblock fd; - Lwt.return_true - | false -> - Unix.set_nonblock fd; - Lwt.return_false) + lazy(Unix.set_nonblock fd; + Lwt.return_false) + else + match blocking with + | Some state -> + lazy(Lwt.return state) + | None -> + lazy(Lwt.return_true) + end else begin + match blocking, set_flags with + | Some state, false -> + lazy(Lwt.return state) + | Some true, true -> + lazy(Unix.clear_nonblock fd; + Lwt.return_true) + | Some false, true -> + lazy(Unix.set_nonblock fd; + Lwt.return_false) + | None, false -> + lazy(guess_blocking fd) + | None, true -> + lazy(guess_blocking fd >>= function + | true -> + Unix.clear_nonblock fd; + Lwt.return_true + | false -> + Unix.set_nonblock fd; + Lwt.return_false) end let mk_ch ?blocking ?(set_flags=true) fd = { @@ -354,12 +354,12 @@ let mk_ch ?blocking ?(set_flags=true) fd = { let check_descriptor ch = match ch.state with - | Opened -> - () - | Aborted e -> - raise e - | Closed -> - raise (Unix.Unix_error (Unix.EBADF, "check_descriptor", "")) + | Opened -> + () + | Aborted e -> + raise e + | Closed -> + raise (Unix.Unix_error (Unix.EBADF, "check_descriptor", "")) let state ch = ch.state @@ -409,19 +409,19 @@ let clear_events ch = Lwt_sequence.iter_node_l (fun node -> Lwt_sequence.remove node; Lwt_sequence.get node ()) ch.hooks_writable; begin match ch.event_readable with - | Some ev -> - ch.event_readable <- None; - Lwt_engine.stop_event ev - | None -> - () + | Some ev -> + ch.event_readable <- None; + Lwt_engine.stop_event ev + | None -> + () end; begin match ch.event_writable with - | Some ev -> - ch.event_writable <- None; - Lwt_engine.stop_event ev - | None -> - () + | Some ev -> + ch.event_writable <- None; + Lwt_engine.stop_event ev + | None -> + () end let abort ch e = @@ -460,19 +460,19 @@ let stop_events ch = (fun () -> if Lwt_sequence.is_empty ch.hooks_readable then begin match ch.event_readable with - | Some ev -> - ch.event_readable <- None; - Lwt_engine.stop_event ev - | None -> - () + | Some ev -> + ch.event_readable <- None; + Lwt_engine.stop_event ev + | None -> + () end; if Lwt_sequence.is_empty ch.hooks_writable then begin match ch.event_writable with - | Some ev -> - ch.event_writable <- None; - Lwt_engine.stop_event ev - | None -> - () + | Some ev -> + ch.event_writable <- None; + Lwt_engine.stop_event ev + | None -> + () end) let register_readable ch = @@ -491,59 +491,59 @@ let rec retry_syscall node event ch wakener action = check_descriptor ch; Success(action ()) with - | Retry - | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) - | Sys_blocked_io -> - (* EINTR because we are catching SIG_CHLD hence the system - call might be interrupted to handle the signal; this lets - us restart the system call eventually. *) - Requeued event - | Retry_read -> - Requeued Read - | Retry_write -> - Requeued Write - | e -> - Exn e + | Retry + | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) + | Sys_blocked_io -> + (* EINTR because we are catching SIG_CHLD hence the system + call might be interrupted to handle the signal; this lets + us restart the system call eventually. *) + Requeued event + | Retry_read -> + Requeued Read + | Retry_write -> + Requeued Write + | e -> + Exn e in match res with - | Success v -> - Lwt_sequence.remove !node; - stop_events ch; - Lwt.wakeup wakener v - | Exn e -> - Lwt_sequence.remove !node; - stop_events ch; - Lwt.wakeup_exn wakener e - | Requeued event' -> - if event <> event' then begin - Lwt_sequence.remove !node; - stop_events ch; - match event' with - | Read -> - node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable ; - register_readable ch - | Write -> - node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; - register_writable ch - end + | Success v -> + Lwt_sequence.remove !node; + stop_events ch; + Lwt.wakeup wakener v + | Exn e -> + Lwt_sequence.remove !node; + stop_events ch; + Lwt.wakeup_exn wakener e + | Requeued event' -> + if event <> event' then begin + Lwt_sequence.remove !node; + stop_events ch; + match event' with + | Read -> + node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable ; + register_readable ch + | Write -> + node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; + register_writable ch + end let dummy = Lwt_sequence.add_r ignore (Lwt_sequence.create ()) let register_action event ch action = let waiter, wakener = Lwt.task () in match event with - | Read -> - let node = ref dummy in - node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable; - Lwt.on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); - register_readable ch; - waiter - | Write -> - let node = ref dummy in - node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; - Lwt.on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); - register_writable ch; - waiter + | Read -> + let node = ref dummy in + node := Lwt_sequence.add_r (fun () -> retry_syscall node Read ch wakener action) ch.hooks_readable; + Lwt.on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); + register_readable ch; + waiter + | Write -> + let node = ref dummy in + node := Lwt_sequence.add_r (fun () -> retry_syscall node Write ch wakener action) ch.hooks_writable; + Lwt.on_cancel waiter (fun () -> Lwt_sequence.remove !node; stop_events ch); + register_writable ch; + waiter (* Wraps a system call *) let wrap_syscall event ch action = @@ -555,17 +555,17 @@ let wrap_syscall event ch action = else register_action event ch action with - | Retry - | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) - | Sys_blocked_io -> - (* The action could not be completed immediately, register it: *) - register_action event ch action - | Retry_read -> - register_action Read ch action - | Retry_write -> - register_action Write ch action - | e -> - Lwt.fail e + | Retry + | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) + | Sys_blocked_io -> + (* The action could not be completed immediately, register it: *) + register_action event ch action + | Retry_read -> + register_action Read ch action + | Retry_write -> + register_action Write ch action + | e -> + Lwt.fail e (* +-----------------------------------------------------------------+ | Generated jobs | @@ -578,7 +578,7 @@ module Jobs = Lwt_unix_jobs_generated.Make(struct type 'a t = 'a job end) +-----------------------------------------------------------------+ *) type open_flag = - Unix.open_flag = + Unix.open_flag = | O_RDONLY | O_WRONLY | O_RDWR @@ -618,10 +618,10 @@ let close ch = let wait_read ch = Lwt.catch (fun () -> - if readable ch then - Lwt.return_unit - else - register_action Read ch ignore) + if readable ch then + Lwt.return_unit + else + register_action Read ch ignore) Lwt.fail external stub_read : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_read" @@ -632,19 +632,19 @@ let read ch buf pos len = invalid_arg "Lwt_unix.read" else Lazy.force ch.blocking >>= function - | true -> - wait_read ch >>= fun () -> - run_job (read_job ch.fd buf pos len) - | false -> - wrap_syscall Read ch (fun () -> stub_read ch.fd buf pos len) + | true -> + wait_read ch >>= fun () -> + run_job (read_job ch.fd buf pos len) + | false -> + wrap_syscall Read ch (fun () -> stub_read ch.fd buf pos len) let wait_write ch = Lwt.catch (fun () -> - if writable ch then - Lwt.return_unit - else - register_action Write ch ignore) + if writable ch then + Lwt.return_unit + else + register_action Write ch ignore) Lwt.fail external stub_write : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_write" @@ -655,11 +655,11 @@ let write ch buf pos len = invalid_arg "Lwt_unix.write" else Lazy.force ch.blocking >>= function - | true -> - wait_write ch >>= fun () -> - run_job (write_job ch.fd buf pos len) - | false -> - wrap_syscall Write ch (fun () -> stub_write ch.fd buf pos len) + | true -> + wait_write ch >>= fun () -> + run_job (write_job ch.fd buf pos len) + | false -> + wrap_syscall Write ch (fun () -> stub_write ch.fd buf pos len) let write_string ch buf pos len = let buf = Bytes.unsafe_of_string buf in @@ -776,12 +776,12 @@ let readv fd io_vectors = let count = check_io_vectors "Lwt_unix.readv" io_vectors in Lazy.force fd.blocking >>= function - | true -> - wait_read fd >>= fun () -> - run_job (readv_job fd.fd io_vectors.IO_vectors.prefix count) - | false -> - wrap_syscall Read fd (fun () -> - stub_readv fd.fd io_vectors.IO_vectors.prefix count) + | true -> + wait_read fd >>= fun () -> + run_job (readv_job fd.fd io_vectors.IO_vectors.prefix count) + | false -> + wrap_syscall Read fd (fun () -> + stub_readv fd.fd io_vectors.IO_vectors.prefix count) external stub_writev : Unix.file_descr -> IO_vectors.io_vector list -> int -> int = @@ -795,19 +795,19 @@ let writev fd io_vectors = let count = check_io_vectors "Lwt_unix.writev" io_vectors in Lazy.force fd.blocking >>= function - | true -> - wait_write fd >>= fun () -> - run_job (writev_job fd.fd io_vectors.IO_vectors.prefix count) - | false -> - wrap_syscall Write fd (fun () -> - stub_writev fd.fd io_vectors.IO_vectors.prefix count) + | true -> + wait_write fd >>= fun () -> + run_job (writev_job fd.fd io_vectors.IO_vectors.prefix count) + | false -> + wrap_syscall Write fd (fun () -> + stub_writev fd.fd io_vectors.IO_vectors.prefix count) (* +-----------------------------------------------------------------+ | Seeking and truncating | +-----------------------------------------------------------------+ *) type seek_command = - Unix.seek_command = + Unix.seek_command = | SEEK_SET | SEEK_CUR | SEEK_END @@ -851,7 +851,7 @@ let fsync ch = type file_perm = Unix.file_perm type file_kind = - Unix.file_kind = + Unix.file_kind = | S_REG | S_DIR | S_CHR @@ -861,21 +861,21 @@ type file_kind = | S_SOCK type stats = - Unix.stats = - { - st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int; - st_atime : float; - st_mtime : float; - st_ctime : float; - } + Unix.stats = + { + st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int; + st_atime : float; + st_mtime : float; + st_ctime : float; + } external stat_job : string -> Unix.stats job = "lwt_unix_stat_job" @@ -937,21 +937,21 @@ module LargeFile = struct type stats = - Unix.LargeFile.stats = - { - st_dev : int; - st_ino : int; - st_kind : file_kind; - st_perm : file_perm; - st_nlink : int; - st_uid : int; - st_gid : int; - st_rdev : int; - st_size : int64; - st_atime : float; - st_mtime : float; - st_ctime : float; - } + Unix.LargeFile.stats = + { + st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int64; + st_atime : float; + st_mtime : float; + st_ctime : float; + } let lseek ch offset whence = check_descriptor ch; @@ -1062,7 +1062,7 @@ let fchown ch uid gid = run_job (Jobs.fchown_job ch.fd uid gid) type access_permission = - Unix.access_permission = + Unix.access_permission = | R_OK | W_OK | X_OK @@ -1088,12 +1088,12 @@ let dup ch = blocking = if ch.set_flags then lazy(Lazy.force ch.blocking >>= function - | true -> - Unix.clear_nonblock fd; - Lwt.return_true - | false -> - Unix.set_nonblock fd; - Lwt.return_false) + | true -> + Unix.clear_nonblock fd; + Lwt.return_true + | false -> + Unix.set_nonblock fd; + Lwt.return_false) else ch.blocking; event_readable = None; @@ -1109,12 +1109,12 @@ let dup2 ch1 ch2 = ch2.blocking <- ( if ch2.set_flags then lazy(Lazy.force ch1.blocking >>= function - | true -> - Unix.clear_nonblock ch2.fd; - Lwt.return_true - | false -> - Unix.set_nonblock ch2.fd; - Lwt.return_false) + | true -> + Unix.clear_nonblock ch2.fd; + Lwt.return_true + | false -> + Unix.set_nonblock ch2.fd; + Lwt.return_false) else ch1.blocking ) @@ -1180,10 +1180,10 @@ let readdir handle = if Sys.win32 then Lwt.return (Unix.readdir handle) else - if valid_dir handle then - run_job (readdir_job handle) - else - Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.readdir", ""))) + if valid_dir handle then + run_job (readdir_job handle) + else + Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.readdir", ""))) external readdir_n_job : Unix.dir_handle -> int -> string array job = "lwt_unix_readdir_n_job" @@ -1197,17 +1197,17 @@ let readdir_n handle count = Lwt.return array else match try array.(i) <- Unix.readdir handle; true with End_of_file -> false with - | true -> - fill (i + 1) - | false -> - Lwt.return (Array.sub array 0 i) + | true -> + fill (i + 1) + | false -> + Lwt.return (Array.sub array 0 i) in fill 0 else - if valid_dir handle then - run_job (readdir_n_job handle count) - else - Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.readdir_n", ""))) + if valid_dir handle then + run_job (readdir_n_job handle count) + else + Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.readdir_n", ""))) external rewinddir_job : Unix.dir_handle -> unit job = "lwt_unix_rewinddir_job" @@ -1215,10 +1215,10 @@ let rewinddir handle = if Sys.win32 then Lwt.return (Unix.rewinddir handle) else - if valid_dir handle then - run_job (rewinddir_job handle) - else - Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.rewinddir", ""))) + if valid_dir handle then + run_job (rewinddir_job handle) + else + Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.rewinddir", ""))) external closedir_job : Unix.dir_handle -> unit job = "lwt_unix_closedir_job" external invalidate_dir : Unix.dir_handle -> unit = "lwt_unix_invalidate_dir" @@ -1227,12 +1227,12 @@ let closedir handle = if Sys.win32 then Lwt.return (Unix.closedir handle) else - if valid_dir handle then - run_job (closedir_job handle) >>= fun () -> - invalidate_dir handle; - Lwt.return_unit - else - Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.closedir", ""))) + if valid_dir handle then + run_job (closedir_job handle) >>= fun () -> + invalidate_dir handle; + Lwt.return_unit + else + Lwt.fail (Unix.(Unix_error (EBADF, "Lwt_unix.closedir", ""))) type list_directory_state = | LDS_not_started @@ -1241,10 +1241,10 @@ type list_directory_state = let cleanup_dir_handle state = match !state with - | LDS_listing handle -> - ignore (closedir handle) - | LDS_not_started | LDS_done -> - () + | LDS_listing handle -> + ignore (closedir handle) + | LDS_not_started | LDS_done -> + () let files_of_directory path = let chunk_size = 1024 in @@ -1253,36 +1253,36 @@ let files_of_directory path = (Lwt_stream.from (fun () -> match !state with - | LDS_not_started -> - opendir path >>= fun handle -> - Lwt.catch - (fun () -> readdir_n handle chunk_size) - (fun exn -> - closedir handle >>= fun () -> - Lwt.fail exn) >>= fun entries -> - if Array.length entries < chunk_size then begin - state := LDS_done; - closedir handle >>= fun () -> - Lwt.return (Some(Lwt_stream.of_array entries)) - end else begin - state := LDS_listing handle; - Gc.finalise cleanup_dir_handle state; - Lwt.return (Some(Lwt_stream.of_array entries)) - end - | LDS_listing handle -> - Lwt.catch - (fun () -> readdir_n handle chunk_size) - (fun exn -> - closedir handle >>= fun () -> - Lwt.fail exn) >>= fun entries -> - if Array.length entries < chunk_size then begin - state := LDS_done; - closedir handle >>= fun () -> - Lwt.return (Some(Lwt_stream.of_array entries)) - end else - Lwt.return (Some(Lwt_stream.of_array entries)) - | LDS_done -> - Lwt.return_none)) + | LDS_not_started -> + opendir path >>= fun handle -> + Lwt.catch + (fun () -> readdir_n handle chunk_size) + (fun exn -> + closedir handle >>= fun () -> + Lwt.fail exn) >>= fun entries -> + if Array.length entries < chunk_size then begin + state := LDS_done; + closedir handle >>= fun () -> + Lwt.return (Some(Lwt_stream.of_array entries)) + end else begin + state := LDS_listing handle; + Gc.finalise cleanup_dir_handle state; + Lwt.return (Some(Lwt_stream.of_array entries)) + end + | LDS_listing handle -> + Lwt.catch + (fun () -> readdir_n handle chunk_size) + (fun exn -> + closedir handle >>= fun () -> + Lwt.fail exn) >>= fun entries -> + if Array.length entries < chunk_size then begin + state := LDS_done; + closedir handle >>= fun () -> + Lwt.return (Some(Lwt_stream.of_array entries)) + end else + Lwt.return (Some(Lwt_stream.of_array entries)) + | LDS_done -> + Lwt.return_none)) (* +-----------------------------------------------------------------+ | Pipes and redirections | @@ -1329,7 +1329,7 @@ let readlink name = +-----------------------------------------------------------------+ *) type lock_command = - Unix.lock_command = + Unix.lock_command = | F_ULOCK | F_LOCK | F_TLOCK @@ -1351,7 +1351,7 @@ let lockf ch cmd size = +-----------------------------------------------------------------+ *) type passwd_entry = - Unix.passwd_entry = + Unix.passwd_entry = { pw_name : string; pw_passwd : string; @@ -1363,7 +1363,7 @@ type passwd_entry = } type group_entry = - Unix.group_entry = + Unix.group_entry = { gr_name : string; gr_passwd : string; @@ -1416,7 +1416,7 @@ let getgrgid gid = +-----------------------------------------------------------------+ *) type msg_flag = - Unix.msg_flag = + Unix.msg_flag = | MSG_OOB | MSG_DONTROUTE | MSG_PEEK @@ -1471,10 +1471,10 @@ let io_vector ~buffer ~offset ~length = { let check_io_vectors func_name iovs = List.iter (fun iov -> - if iov.iov_offset < 0 - || iov.iov_length < 0 - || iov.iov_offset > String.length iov.iov_buffer - iov.iov_length then - invalid_arg func_name) iovs + if iov.iov_offset < 0 + || iov.iov_length < 0 + || iov.iov_offset > String.length iov.iov_buffer - iov.iov_length then + invalid_arg func_name) iovs external stub_recv_msg : Unix.file_descr -> int -> io_vector list -> int * Unix.file_descr list = "lwt_unix_recv_msg" @@ -1495,13 +1495,13 @@ let send_msg ~socket ~io_vectors ~fds = type inet_addr = Unix.inet_addr type socket_domain = - Unix.socket_domain = + Unix.socket_domain = | PF_UNIX | PF_INET | PF_INET6 type socket_type = - Unix.socket_type = + Unix.socket_type = | SOCK_STREAM | SOCK_DGRAM | SOCK_RAW @@ -1514,7 +1514,7 @@ let socket dom typ proto = mk_ch ~blocking:false s type shutdown_command = - Unix.shutdown_command = + Unix.shutdown_command = | SHUTDOWN_RECEIVE | SHUTDOWN_SEND | SHUTDOWN_ALL @@ -1544,21 +1544,21 @@ let accept_n ch n = Lazy.force ch.blocking >>= fun blocking -> Lwt.catch (fun () -> - wrap_syscall Read ch begin fun () -> - begin - try - for _i = 1 to n do - if blocking && not (unix_readable ch.fd) then raise Retry; - let fd, addr = Unix.accept ch.fd in - l := (mk_ch ~blocking:false fd, addr) :: !l - done - with - | (Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Retry) when !l <> [] -> - (* Ignore blocking errors if we have at least one file-descriptor: *) - () - end; - (List.rev !l, None) - end) + wrap_syscall Read ch begin fun () -> + begin + try + for _i = 1 to n do + if blocking && not (unix_readable ch.fd) then raise Retry; + let fd, addr = Unix.accept ch.fd in + l := (mk_ch ~blocking:false fd, addr) :: !l + done + with + | (Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.EINTR), _, _) | Retry) when !l <> [] -> + (* Ignore blocking errors if we have at least one file-descriptor: *) + () + end; + (List.rev !l, None) + end) (fun exn -> Lwt.return (List.rev !l, Some exn)) let connect ch addr = @@ -1573,19 +1573,19 @@ let connect ch addr = try Unix.connect ch.fd addr with - | Unix.Unix_error (Unix.EISCONN, _, _) -> - (* This is the windows way of telling that the connection - has completed. *) - () + | Unix.Unix_error (Unix.EISCONN, _, _) -> + (* This is the windows way of telling that the connection + has completed. *) + () else raise Retry else try Unix.connect ch.fd addr with - | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> - in_progress := true; - raise Retry + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> + in_progress := true; + raise Retry end else (* [in_progress] tell wether connection has started but not @@ -1596,21 +1596,21 @@ let connect ch addr = (* If the connection is in progress, [getsockopt_error] tells wether it succceed: *) match Unix.getsockopt_error ch.fd with - | None -> - (* The socket is connected *) - () - | Some err -> - (* An error happened: *) - raise (Unix.Unix_error(err, "connect", "")) + | None -> + (* The socket is connected *) + () + | Some err -> + (* An error happened: *) + raise (Unix.Unix_error(err, "connect", "")) else try (* We should pass only one time here, unless the system call is interrupted by a signal: *) Unix.connect ch.fd addr with - | Unix.Unix_error (Unix.EINPROGRESS, _, _) -> - in_progress := true; - raise Retry + | Unix.Unix_error (Unix.EINPROGRESS, _, _) -> + in_progress := true; + raise Retry end external bind_job : Unix.file_descr -> Unix.sockaddr -> unit job = @@ -1651,7 +1651,7 @@ let get_credentials ch = +-----------------------------------------------------------------+ *) type socket_bool_option = - Unix.socket_bool_option = + Unix.socket_bool_option = | SO_DEBUG | SO_BROADCAST | SO_REUSEADDR @@ -1663,7 +1663,7 @@ type socket_bool_option = | IPV6_ONLY type socket_int_option = - Unix.socket_int_option = + Unix.socket_int_option = | SO_SNDBUF | SO_RCVBUF | SO_ERROR @@ -1674,7 +1674,7 @@ type socket_int_option = type socket_optint_option = Unix.socket_optint_option = SO_LINGER type socket_float_option = - Unix.socket_float_option = + Unix.socket_float_option = | SO_RCVTIMEO | SO_SNDTIMEO @@ -1749,30 +1749,30 @@ let mcast_drop_membership ch ?(ifname = Unix.inet_addr_any) addr = +-----------------------------------------------------------------+ *) type host_entry = - Unix.host_entry = - { - h_name : string; - h_aliases : string array; - h_addrtype : socket_domain; - h_addr_list : inet_addr array - } + Unix.host_entry = + { + h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array + } type protocol_entry = - Unix.protocol_entry = - { - p_name : string; - p_aliases : string array; - p_proto : int - } + Unix.protocol_entry = + { + p_name : string; + p_aliases : string array; + p_proto : int + } type service_entry = - Unix.service_entry = - { - s_name : string; - s_aliases : string array; - s_port : int; - s_proto : string - } + Unix.service_entry = + { + s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string + } external gethostname_job : unit -> string job = "lwt_unix_gethostname_job" @@ -1793,7 +1793,7 @@ let gethostbyname name = run_job (gethostbyname_job name) else Lwt_mutex.with_lock hostent_mutex ( fun () -> - run_job (gethostbyname_job name) ) + run_job (gethostbyname_job name) ) external gethostbyaddr_job : Unix.inet_addr -> Unix.host_entry job = "lwt_unix_gethostbyaddr_job" @@ -1804,7 +1804,7 @@ let gethostbyaddr addr = run_job (gethostbyaddr_job addr) else Lwt_mutex.with_lock hostent_mutex ( fun () -> - run_job (gethostbyaddr_job addr) ) + run_job (gethostbyaddr_job addr) ) let protoent_mutex = if Sys.win32 || Lwt_config._HAVE_NETDB_REENTRANT then @@ -1821,7 +1821,7 @@ let getprotobyname name = run_job (getprotobyname_job name) else Lwt_mutex.with_lock protoent_mutex ( fun () -> - run_job (getprotobyname_job name)) + run_job (getprotobyname_job name)) external getprotobynumber_job : int -> Unix.protocol_entry job = "lwt_unix_getprotobynumber_job" @@ -1832,7 +1832,7 @@ let getprotobynumber number = run_job (getprotobynumber_job number) else Lwt_mutex.with_lock protoent_mutex ( fun () -> - run_job (getprotobynumber_job number)) + run_job (getprotobynumber_job number)) (* TODO: Not used anywhere, and that might be a bug. *) let _servent_mutex = @@ -1850,7 +1850,7 @@ let getservbyname name x = run_job (getservbyname_job name x) else Lwt_mutex.with_lock protoent_mutex ( fun () -> - run_job (getservbyname_job name x) ) + run_job (getservbyname_job name x) ) external getservbyport_job : int -> string -> Unix.service_entry job = "lwt_unix_getservbyport_job" @@ -1861,20 +1861,20 @@ let getservbyport port x = run_job (getservbyport_job port x) else Lwt_mutex.with_lock protoent_mutex ( fun () -> - run_job (getservbyport_job port x) ) + run_job (getservbyport_job port x) ) type addr_info = - Unix.addr_info = - { - ai_family : socket_domain; - ai_socktype : socket_type; - ai_protocol : int; - ai_addr : sockaddr; - ai_canonname : string; - } + Unix.addr_info = + { + ai_family : socket_domain; + ai_socktype : socket_type; + ai_protocol : int; + ai_addr : sockaddr; + ai_canonname : string; + } type getaddrinfo_option = - Unix.getaddrinfo_option = + Unix.getaddrinfo_option = | AI_FAMILY of socket_domain | AI_SOCKTYPE of socket_type | AI_PROTOCOL of int @@ -1892,14 +1892,14 @@ let getaddrinfo host service opts = Lwt.return (List.rev l) type name_info = - Unix.name_info = - { - ni_hostname : string; - ni_service : string; - } + Unix.name_info = + { + ni_hostname : string; + ni_service : string; + } type getnameinfo_option = - Unix.getnameinfo_option = + Unix.getnameinfo_option = | NI_NOFQDN | NI_NUMERICHOST | NI_NAMEREQD @@ -1919,62 +1919,62 @@ let getnameinfo addr opts = +-----------------------------------------------------------------+ *) type terminal_io = - Unix.terminal_io = - { - mutable c_ignbrk : bool; - mutable c_brkint : bool; - mutable c_ignpar : bool; - mutable c_parmrk : bool; - mutable c_inpck : bool; - mutable c_istrip : bool; - mutable c_inlcr : bool; - mutable c_igncr : bool; - mutable c_icrnl : bool; - mutable c_ixon : bool; - mutable c_ixoff : bool; - mutable c_opost : bool; - mutable c_obaud : int; - mutable c_ibaud : int; - mutable c_csize : int; - mutable c_cstopb : int; - mutable c_cread : bool; - mutable c_parenb : bool; - mutable c_parodd : bool; - mutable c_hupcl : bool; - mutable c_clocal : bool; - mutable c_isig : bool; - mutable c_icanon : bool; - mutable c_noflsh : bool; - mutable c_echo : bool; - mutable c_echoe : bool; - mutable c_echok : bool; - mutable c_echonl : bool; - mutable c_vintr : char; - mutable c_vquit : char; - mutable c_verase : char; - mutable c_vkill : char; - mutable c_veof : char; - mutable c_veol : char; - mutable c_vmin : int; - mutable c_vtime : int; - mutable c_vstart : char; - mutable c_vstop : char; - } + Unix.terminal_io = + { + mutable c_ignbrk : bool; + mutable c_brkint : bool; + mutable c_ignpar : bool; + mutable c_parmrk : bool; + mutable c_inpck : bool; + mutable c_istrip : bool; + mutable c_inlcr : bool; + mutable c_igncr : bool; + mutable c_icrnl : bool; + mutable c_ixon : bool; + mutable c_ixoff : bool; + mutable c_opost : bool; + mutable c_obaud : int; + mutable c_ibaud : int; + mutable c_csize : int; + mutable c_cstopb : int; + mutable c_cread : bool; + mutable c_parenb : bool; + mutable c_parodd : bool; + mutable c_hupcl : bool; + mutable c_clocal : bool; + mutable c_isig : bool; + mutable c_icanon : bool; + mutable c_noflsh : bool; + mutable c_echo : bool; + mutable c_echoe : bool; + mutable c_echok : bool; + mutable c_echonl : bool; + mutable c_vintr : char; + mutable c_vquit : char; + mutable c_verase : char; + mutable c_vkill : char; + mutable c_veof : char; + mutable c_veol : char; + mutable c_vmin : int; + mutable c_vtime : int; + mutable c_vstart : char; + mutable c_vstop : char; + } type setattr_when = - Unix.setattr_when = + Unix.setattr_when = | TCSANOW | TCSADRAIN | TCSAFLUSH type flush_queue = - Unix.flush_queue = + Unix.flush_queue = | TCIFLUSH | TCOFLUSH | TCIOFLUSH type flow_action = - Unix.flow_action = + Unix.flow_action = | TCOOFF | TCOON | TCIOFF @@ -2076,9 +2076,9 @@ let on_signal_full signum handler = let notification = make_notification (fun () -> - Lwt_sequence.iter_l - (fun f -> f id signum) - actions) + Lwt_sequence.iter_l + (fun f -> f id signum) + actions) in (try set_signal signum notification @@ -2110,10 +2110,10 @@ let disable_signal_handler id = let reinstall_signal_handler signum = match try Some (Signal_map.find signum !signals) with Not_found -> None with - | Some (notification, _) -> - set_signal signum notification - | None -> - () + | Some (notification, _) -> + set_signal signum notification + | None -> + () (* +-----------------------------------------------------------------+ | Processes | @@ -2123,32 +2123,32 @@ external reset_after_fork : unit -> unit = "lwt_unix_reset_after_fork" let fork () = match Unix.fork () with - | 0 -> - (* Reset threading. *) - reset_after_fork (); - (* Stop the old event for notifications. *) - Lwt_engine.stop_event !event_notifications; - (* Reinitialise the notification system. *) - event_notifications := Lwt_engine.on_readable (init_notification ()) handle_notifications; - (* Collect all pending jobs. *) - let l = Lwt_sequence.fold_l (fun (_, f) l -> f :: l) jobs [] in - (* Remove them all. *) - Lwt_sequence.iter_node_l Lwt_sequence.remove jobs; - (* And cancel them all. We yield first so that if the program - do an exec just after, it won't be executed. *) - Lwt.on_termination (Lwt_main.yield ()) (fun () -> List.iter (fun f -> f Lwt.Canceled) l); - 0 - | pid -> - pid + | 0 -> + (* Reset threading. *) + reset_after_fork (); + (* Stop the old event for notifications. *) + Lwt_engine.stop_event !event_notifications; + (* Reinitialise the notification system. *) + event_notifications := Lwt_engine.on_readable (init_notification ()) handle_notifications; + (* Collect all pending jobs. *) + let l = Lwt_sequence.fold_l (fun (_, f) l -> f :: l) jobs [] in + (* Remove them all. *) + Lwt_sequence.iter_node_l Lwt_sequence.remove jobs; + (* And cancel them all. We yield first so that if the program + do an exec just after, it won't be executed. *) + Lwt.on_termination (Lwt_main.yield ()) (fun () -> List.iter (fun f -> f Lwt.Canceled) l); + 0 + | pid -> + pid type process_status = - Unix.process_status = + Unix.process_status = | WEXITED of int | WSIGNALED of int | WSTOPPED of int type wait_flag = - Unix.wait_flag = + Unix.wait_flag = | WNOHANG | WUNTRACED @@ -2217,19 +2217,19 @@ let wait4 flags pid = if Sys.win32 then Lwt.return (do_wait4 flags pid) else - if List.mem Unix.WNOHANG flags then - Lwt.return (do_wait4 flags pid) - else - let flags = Unix.WNOHANG :: flags in - let (pid', _, _) as res = do_wait4 flags pid in - if pid' <> 0 then - Lwt.return res - else begin - let (res, w) = Lwt.task () in - let node = Lwt_sequence.add_l (w, flags, pid) wait_children in - Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); - res - end + if List.mem Unix.WNOHANG flags then + Lwt.return (do_wait4 flags pid) + else + let flags = Unix.WNOHANG :: flags in + let (pid', _, _) as res = do_wait4 flags pid in + if pid' <> 0 then + Lwt.return res + else begin + let (res, w) = Lwt.task () in + let node = Lwt_sequence.add_l (w, flags, pid) wait_children in + Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node); + res + end let wait () = waitpid [] (-1) @@ -2243,15 +2243,15 @@ let system cmd = Lwt.return (Unix.WEXITED code) else match fork () with - | 0 -> - begin try - Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] - with _ -> - (* Do not run at_exit hooks *) - sys_exit 127 - end - | id -> - waitpid [] id >|= snd + | 0 -> + begin try + Unix.execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] + with _ -> + (* Do not run at_exit hooks *) + sys_exit 127 + end + | id -> + waitpid [] id >|= snd (* +-----------------------------------------------------------------+ | Misc | @@ -2263,7 +2263,7 @@ let handle_unix_error f x = Lwt.catch (fun () -> f x) (fun exn -> - Unix.handle_unix_error (fun () -> raise exn) ()) + Unix.handle_unix_error (fun () -> raise exn) ()) (* +-----------------------------------------------------------------+ | System thread pool | @@ -2295,82 +2295,82 @@ let set_affinity ?(pid=0) l = stub_set_affinity pid l let () = Printexc.register_printer (function - | Unix.Unix_error(error, func, arg) -> - let error = - match error with - | Unix.E2BIG -> "E2BIG" - | Unix.EACCES -> "EACCES" - | Unix.EAGAIN -> "EAGAIN" - | Unix.EBADF -> "EBADF" - | Unix.EBUSY -> "EBUSY" - | Unix.ECHILD -> "ECHILD" - | Unix.EDEADLK -> "EDEADLK" - | Unix.EDOM -> "EDOM" - | Unix.EEXIST -> "EEXIST" - | Unix.EFAULT -> "EFAULT" - | Unix.EFBIG -> "EFBIG" - | Unix.EINTR -> "EINTR" - | Unix.EINVAL -> "EINVAL" - | Unix.EIO -> "EIO" - | Unix.EISDIR -> "EISDIR" - | Unix.EMFILE -> "EMFILE" - | Unix.EMLINK -> "EMLINK" - | Unix.ENAMETOOLONG -> "ENAMETOOLONG" - | Unix.ENFILE -> "ENFILE" - | Unix.ENODEV -> "ENODEV" - | Unix.ENOENT -> "ENOENT" - | Unix.ENOEXEC -> "ENOEXEC" - | Unix.ENOLCK -> "ENOLCK" - | Unix.ENOMEM -> "ENOMEM" - | Unix.ENOSPC -> "ENOSPC" - | Unix.ENOSYS -> "ENOSYS" - | Unix.ENOTDIR -> "ENOTDIR" - | Unix.ENOTEMPTY -> "ENOTEMPTY" - | Unix.ENOTTY -> "ENOTTY" - | Unix.ENXIO -> "ENXIO" - | Unix.EPERM -> "EPERM" - | Unix.EPIPE -> "EPIPE" - | Unix.ERANGE -> "ERANGE" - | Unix.EROFS -> "EROFS" - | Unix.ESPIPE -> "ESPIPE" - | Unix.ESRCH -> "ESRCH" - | Unix.EXDEV -> "EXDEV" - | Unix.EWOULDBLOCK -> "EWOULDBLOCK" - | Unix.EINPROGRESS -> "EINPROGRESS" - | Unix.EALREADY -> "EALREADY" - | Unix.ENOTSOCK -> "ENOTSOCK" - | Unix.EDESTADDRREQ -> "EDESTADDRREQ" - | Unix.EMSGSIZE -> "EMSGSIZE" - | Unix.EPROTOTYPE -> "EPROTOTYPE" - | Unix.ENOPROTOOPT -> "ENOPROTOOPT" - | Unix.EPROTONOSUPPORT -> "EPROTONOSUPPORT" - | Unix.ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT" - | Unix.EOPNOTSUPP -> "EOPNOTSUPP" - | Unix.EPFNOSUPPORT -> "EPFNOSUPPORT" - | Unix.EAFNOSUPPORT -> "EAFNOSUPPORT" - | Unix.EADDRINUSE -> "EADDRINUSE" - | Unix.EADDRNOTAVAIL -> "EADDRNOTAVAIL" - | Unix.ENETDOWN -> "ENETDOWN" - | Unix.ENETUNREACH -> "ENETUNREACH" - | Unix.ENETRESET -> "ENETRESET" - | Unix.ECONNABORTED -> "ECONNABORTED" - | Unix.ECONNRESET -> "ECONNRESET" - | Unix.ENOBUFS -> "ENOBUFS" - | Unix.EISCONN -> "EISCONN" - | Unix.ENOTCONN -> "ENOTCONN" - | Unix.ESHUTDOWN -> "ESHUTDOWN" - | Unix.ETOOMANYREFS -> "ETOOMANYREFS" - | Unix.ETIMEDOUT -> "ETIMEDOUT" - | Unix.ECONNREFUSED -> "ECONNREFUSED" - | Unix.EHOSTDOWN -> "EHOSTDOWN" - | Unix.EHOSTUNREACH -> "EHOSTUNREACH" - | Unix.ELOOP -> "ELOOP" - | Unix.EOVERFLOW -> "EOVERFLOW" - | Unix.EUNKNOWNERR n -> Printf.sprintf "EUNKNOWNERR %d" n - in - Some(Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" error func arg) - | _ -> - None) + | Unix.Unix_error(error, func, arg) -> + let error = + match error with + | Unix.E2BIG -> "E2BIG" + | Unix.EACCES -> "EACCES" + | Unix.EAGAIN -> "EAGAIN" + | Unix.EBADF -> "EBADF" + | Unix.EBUSY -> "EBUSY" + | Unix.ECHILD -> "ECHILD" + | Unix.EDEADLK -> "EDEADLK" + | Unix.EDOM -> "EDOM" + | Unix.EEXIST -> "EEXIST" + | Unix.EFAULT -> "EFAULT" + | Unix.EFBIG -> "EFBIG" + | Unix.EINTR -> "EINTR" + | Unix.EINVAL -> "EINVAL" + | Unix.EIO -> "EIO" + | Unix.EISDIR -> "EISDIR" + | Unix.EMFILE -> "EMFILE" + | Unix.EMLINK -> "EMLINK" + | Unix.ENAMETOOLONG -> "ENAMETOOLONG" + | Unix.ENFILE -> "ENFILE" + | Unix.ENODEV -> "ENODEV" + | Unix.ENOENT -> "ENOENT" + | Unix.ENOEXEC -> "ENOEXEC" + | Unix.ENOLCK -> "ENOLCK" + | Unix.ENOMEM -> "ENOMEM" + | Unix.ENOSPC -> "ENOSPC" + | Unix.ENOSYS -> "ENOSYS" + | Unix.ENOTDIR -> "ENOTDIR" + | Unix.ENOTEMPTY -> "ENOTEMPTY" + | Unix.ENOTTY -> "ENOTTY" + | Unix.ENXIO -> "ENXIO" + | Unix.EPERM -> "EPERM" + | Unix.EPIPE -> "EPIPE" + | Unix.ERANGE -> "ERANGE" + | Unix.EROFS -> "EROFS" + | Unix.ESPIPE -> "ESPIPE" + | Unix.ESRCH -> "ESRCH" + | Unix.EXDEV -> "EXDEV" + | Unix.EWOULDBLOCK -> "EWOULDBLOCK" + | Unix.EINPROGRESS -> "EINPROGRESS" + | Unix.EALREADY -> "EALREADY" + | Unix.ENOTSOCK -> "ENOTSOCK" + | Unix.EDESTADDRREQ -> "EDESTADDRREQ" + | Unix.EMSGSIZE -> "EMSGSIZE" + | Unix.EPROTOTYPE -> "EPROTOTYPE" + | Unix.ENOPROTOOPT -> "ENOPROTOOPT" + | Unix.EPROTONOSUPPORT -> "EPROTONOSUPPORT" + | Unix.ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT" + | Unix.EOPNOTSUPP -> "EOPNOTSUPP" + | Unix.EPFNOSUPPORT -> "EPFNOSUPPORT" + | Unix.EAFNOSUPPORT -> "EAFNOSUPPORT" + | Unix.EADDRINUSE -> "EADDRINUSE" + | Unix.EADDRNOTAVAIL -> "EADDRNOTAVAIL" + | Unix.ENETDOWN -> "ENETDOWN" + | Unix.ENETUNREACH -> "ENETUNREACH" + | Unix.ENETRESET -> "ENETRESET" + | Unix.ECONNABORTED -> "ECONNABORTED" + | Unix.ECONNRESET -> "ECONNRESET" + | Unix.ENOBUFS -> "ENOBUFS" + | Unix.EISCONN -> "EISCONN" + | Unix.ENOTCONN -> "ENOTCONN" + | Unix.ESHUTDOWN -> "ESHUTDOWN" + | Unix.ETOOMANYREFS -> "ETOOMANYREFS" + | Unix.ETIMEDOUT -> "ETIMEDOUT" + | Unix.ECONNREFUSED -> "ECONNREFUSED" + | Unix.EHOSTDOWN -> "EHOSTDOWN" + | Unix.EHOSTUNREACH -> "EHOSTUNREACH" + | Unix.ELOOP -> "ELOOP" + | Unix.EOVERFLOW -> "EOVERFLOW" + | Unix.EUNKNOWNERR n -> Printf.sprintf "EUNKNOWNERR %d" n + in + Some(Printf.sprintf "Unix.Unix_error(Unix.%s, %S, %S)" error func arg) + | _ -> + None) module Versioned = struct diff --git a/src/util/configure.ml b/src/util/configure.ml index 8da874accf..cce51f0ff6 100644 --- a/src/util/configure.ml +++ b/src/util/configure.ml @@ -9,9 +9,9 @@ let use_camlp4 = ref None let arg_bool r = Arg.Symbol (["true"; "false"], function - | "true" -> r := Some true - | "false" -> r := Some false - | _ -> assert false) + | "true" -> r := Some true + | "false" -> r := Some false + | _ -> assert false) let args = [ "-use-libev", arg_bool use_libev, " whether to check for libev"; "-use-pthread", arg_bool use_pthread, " whether to use pthread";