From ae202d91e002e571b91df0a5a83e5379235e032d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 7 Feb 2024 11:22:41 +0100 Subject: [PATCH 1/3] Use raise and reraise instead of fail in more places in core --- src/core/lwt_pool.ml | 2 +- src/core/lwt_seq.ml | 6 +++--- src/core/lwt_stream.ml | 23 +++++++++++++-------- test/core/test_lwt.ml | 39 ++++++++++++++++++++++-------------- test/core/test_lwt_pool.ml | 14 ++++++------- test/core/test_lwt_result.ml | 2 +- test/core/test_lwt_stream.ml | 10 ++++----- 7 files changed, 56 insertions(+), 40 deletions(-) diff --git a/src/core/lwt_pool.ml b/src/core/lwt_pool.ml index 1605bc89fa..bf06787ab7 100644 --- a/src/core/lwt_pool.ml +++ b/src/core/lwt_pool.ml @@ -108,7 +108,7 @@ let validate_and_return p c = resolver is waiting. *) dispose p c >>= fun () -> replace_disposed p; - Lwt.fail e) + Lwt.reraise e) (* Acquire a pool member. *) let acquire p = diff --git a/src/core/lwt_seq.ml b/src/core/lwt_seq.ml index fe40eadfbd..dd3f0396f2 100644 --- a/src/core/lwt_seq.ml +++ b/src/core/lwt_seq.ml @@ -270,7 +270,7 @@ let rec unfold f u () = match f u with | None -> return_nil | Some (x, u') -> Lwt.return (Cons (x, unfold f u')) - | exception exc when Lwt.Exception_filter.run exc -> Lwt.fail exc + | exception exc when Lwt.Exception_filter.run exc -> Lwt.reraise exc let rec unfold_lwt f u () = let* x = f u in @@ -299,7 +299,7 @@ let rec of_seq seq () = | Seq.Nil -> return_nil | Seq.Cons (x, next) -> Lwt.return (Cons (x, (of_seq next))) - | exception exn when Lwt.Exception_filter.run exn -> Lwt.fail exn + | exception exn when Lwt.Exception_filter.run exn -> Lwt.reraise exn let rec of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () -> match seq () with @@ -315,4 +315,4 @@ let of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () -> let+ x = x in let next = of_seq_lwt next in Cons (x, next) - | exception exc when Lwt.Exception_filter.run exc -> Lwt.fail exc + | exception exc when Lwt.Exception_filter.run exc -> Lwt.reraise exc diff --git a/src/core/lwt_stream.ml b/src/core/lwt_stream.ml index 88e83f449d..cb75394058 100644 --- a/src/core/lwt_stream.ml +++ b/src/core/lwt_stream.ml @@ -279,9 +279,9 @@ class ['a] bounded_push_impl (info : 'a push_bounded) wakener_cell last close = let waiter, wakener = Lwt.task () in info.pushb_push_waiter <- waiter; info.pushb_push_wakener <- wakener; - Lwt.fail exn + Lwt.reraise exn | _ -> - Lwt.fail exn) + Lwt.reraise exn) end else begin (* Push the element at the end of the queue. *) enqueue' (Some x) last; @@ -367,11 +367,18 @@ let feed s = else begin (* Otherwise request a new element. *) let thread = - from.from_create () >>= fun x -> - (* Push the element to the end of the queue. *) - enqueue x s; - if x = None then Lwt.wakeup s.close (); - Lwt.return_unit + (* The function [from_create] can raise an exception (with + [raise], rather than returning a failed promise with + [Lwt.fail]). In this case, we have to catch the exception + and turn it into a safe failed promise. *) + Lwt.catch + (fun () -> + from.from_create () >>= fun x -> + (* Push the element to the end of the queue. *) + enqueue x s; + if x = None then Lwt.wakeup s.close (); + Lwt.return_unit) + Lwt.reraise in (* Allow other threads to access this thread. *) from.from_thread <- thread; @@ -1070,7 +1077,7 @@ let parse s f = (fun () -> f s) (fun exn -> s.node <- node; - Lwt.fail exn) + Lwt.reraise exn) let hexdump stream = let buf = Buffer.create 80 and num = ref 0 in diff --git a/test/core/test_lwt.ml b/test/core/test_lwt.ml index 3a08fdc324..2ba5ab5641 100644 --- a/test/core/test_lwt.ml +++ b/test/core/test_lwt.ml @@ -549,6 +549,15 @@ let catch_tests = suite "catch" [ state_is (Lwt.Return Exception) p end; + test "rejected (raise)" begin fun () -> + let p = + Lwt.catch + (fun () -> raise Exception) + (fun exn -> Lwt.return exn) + in + state_is (Lwt.Return Exception) p + end; + (* This is an analog of the "bind quirk," see https://github.com/ocsigen/lwt/issues/329 *) @@ -696,7 +705,7 @@ let backtrace_catch_tests = suite "backtrace_catch" [ test "rejected" begin fun () -> let p = Lwt.backtrace_catch add_loc - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) (fun exn -> Lwt.return exn) in state_is (Lwt.Return Exception) p @@ -789,7 +798,7 @@ let try_bind_tests = suite "try_bind" [ test "rejected" begin fun () -> let p = Lwt.try_bind - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) (fun _ -> Lwt.return Exit) (fun exn -> Lwt.return exn) in @@ -810,7 +819,7 @@ let try_bind_tests = suite "try_bind" [ test "rejected, h raises" begin fun () -> try ignore @@ Lwt.try_bind - (fun () -> Lwt.fail Exit) + (fun () -> raise Exit) (fun _ -> Lwt.return_unit) (fun _ -> raise Exception); Lwt.return_false @@ -961,7 +970,7 @@ let backtrace_try_bind_tests = suite "backtrace_try_bind" [ test "rejected" begin fun () -> let p = Lwt.backtrace_try_bind add_loc - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) (fun _ -> Lwt.return Exit) (fun exn -> Lwt.return exn) in @@ -1132,7 +1141,7 @@ let finalize_tests = suite "finalize" [ test "rejected, f' raises" begin fun () -> try ignore @@ Lwt.finalize - (fun () -> Lwt.fail Exit) + (fun () -> raise Exit) (fun () -> raise Exception); Lwt.return_false with Exception -> @@ -1169,7 +1178,7 @@ let finalize_tests = suite "finalize" [ let p = Lwt.finalize (fun () -> p) - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p @@ -1232,7 +1241,7 @@ let finalize_tests = suite "finalize" [ let p = Lwt.finalize (fun () -> p) - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p @@ -1347,7 +1356,7 @@ let backtrace_finalize_tests = suite "backtrace_finalize" [ let f'_ran = ref false in let p = Lwt.backtrace_finalize add_loc - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) (fun () -> f'_ran := true; Lwt.return_unit) in Lwt.bind (state_is (Lwt.Fail Exception) p) (fun correct -> @@ -1367,7 +1376,7 @@ let backtrace_finalize_tests = suite "backtrace_finalize" [ test "rejected, f' raises" begin fun () -> try ignore @@ Lwt.backtrace_finalize add_loc - (fun () -> Lwt.fail Exit) + (fun () -> raise Exit) (fun () -> raise Exception); Lwt.return_false with Exception -> @@ -1404,7 +1413,7 @@ let backtrace_finalize_tests = suite "backtrace_finalize" [ let p = Lwt.backtrace_finalize add_loc (fun () -> p) - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) in Lwt.wakeup r (); state_is (Lwt.Fail Exception) p @@ -1439,7 +1448,7 @@ let backtrace_finalize_tests = suite "backtrace_finalize" [ let p = Lwt.backtrace_finalize add_loc (fun () -> p) - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) in Lwt.wakeup_exn r Exit; state_is (Lwt.Fail Exception) p @@ -1803,7 +1812,7 @@ let async_tests = suite "async" [ let saw = ref None in let restore = set_async_exception_hook (fun exn -> saw := Some exn) in - Lwt.async (fun () -> Lwt.fail Exception); + Lwt.async (fun () -> raise Exception); later (fun () -> restore (); !saw = Some Exception) @@ -1852,7 +1861,7 @@ let dont_wait_tests = suite "dont_wait" [ test "rejected" begin fun () -> let saw = ref None in Lwt.dont_wait - (fun () -> Lwt.fail Exception) + (fun () -> raise Exception) (fun exn -> saw := Some exn); later (fun () -> !saw = Some Exception) end; @@ -3371,7 +3380,7 @@ let cancel_catch_tests = suite "cancel catch" [ test "task, pending, canceled, on_cancel, forwarded" begin fun () -> let on_cancel_2_ran = ref false in let p, _ = Lwt.task () in - let p' = Lwt.catch (fun () -> p) Lwt.fail in + let p' = Lwt.catch (fun () -> p) Lwt.reraise in Lwt.on_cancel p' (fun () -> on_cancel_2_ran := true); Lwt.cancel p'; Lwt.return @@ -3895,7 +3904,7 @@ let storage_tests = suite "storage" [ Lwt.with_value key (Some 42) (fun () -> let p' = Lwt.with_value key (Some 1337) (fun () -> - Lwt.try_bind (fun () -> p) f Lwt.fail) + Lwt.try_bind (fun () -> p) f Lwt.reraise) in Lwt.wakeup r (); Lwt.return diff --git a/test/core/test_lwt_pool.ml b/test/core/test_lwt_pool.ml index cd7bf27065..942ca0d7e8 100644 --- a/test/core/test_lwt_pool.ml +++ b/test/core/test_lwt_pool.ml @@ -16,7 +16,7 @@ let suite = suite "lwt_pool" [ end; test "creator exception" begin fun () -> - let gen = fun () -> Lwt.fail Dummy_error in + let gen = fun () -> raise Dummy_error in let p = Lwt_pool.create 1 gen in let u = Lwt_pool.use p (fun _ -> Lwt.return 0) in Lwt.return (Lwt.state u = Lwt.Fail Dummy_error) @@ -42,7 +42,7 @@ let suite = suite "lwt_pool" [ test "validation exceptions are propagated to users" begin fun () -> let c = Lwt_condition.create () in let gen = (fun () -> let l = ref 0 in Lwt.return l) in - let v l = if !l = 0 then Lwt.return_true else Lwt.fail Dummy_error in + let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in let p = Lwt_pool.create 1 ~validate:v gen in let u1 = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait c) in let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in @@ -106,7 +106,7 @@ let suite = suite "lwt_pool" [ test "waiter are notified on replacement" begin fun () -> let c = Lwt_condition.create () in let gen = (fun () -> let l = ref 0 in Lwt.return l) in - let v l = if !l = 0 then Lwt.return_true else Lwt.fail Dummy_error in + let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in let p = Lwt_pool.create 1 ~validate:v gen in let u1 = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait c) in let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in @@ -128,9 +128,9 @@ let suite = suite "lwt_pool" [ if !k then let l = ref 0 in Lwt.return l else - Lwt.fail Dummy_error + raise Dummy_error in - let v l = if !l = 0 then Lwt.return_true else Lwt.fail Dummy_error in + let v l = if !l = 0 then Lwt.return_true else raise Dummy_error in let p = Lwt_pool.create 1 ~validate:v gen in let u1 = Lwt_pool.use p (fun l -> l := 1; k:= false; Lwt_condition.wait c) in let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in @@ -156,7 +156,7 @@ let suite = suite "lwt_pool" [ let cond = Lwt_condition.create() in let p = Lwt_pool.create 1 ~validate:v ~check:c gen in let _ = Lwt_pool.use p (fun l -> l := 1; Lwt_condition.wait cond) in - let _ = Lwt_pool.use p (fun l -> l := 2; Lwt.fail Dummy_error) in + let _ = Lwt_pool.use p (fun l -> l := 2; raise Dummy_error) in let u3 = Lwt_pool.use p (fun l -> Lwt.return !l) in let () = Lwt_condition.signal cond "done" in Lwt.bind u3 (fun v -> @@ -169,7 +169,7 @@ let suite = suite "lwt_pool" [ let p = Lwt_pool.create 1 gen in let _ = Lwt_pool.use p (fun l -> Lwt.bind (Lwt_condition.wait cond) - (fun _ -> l:= 1; Lwt.fail Dummy_error)) in + (fun _ -> l:= 1; raise Dummy_error)) in let u2 = Lwt_pool.use p (fun l -> Lwt.return !l) in let () = Lwt_condition.signal cond "done" in Lwt.bind u2 (fun v -> diff --git a/test/core/test_lwt_result.ml b/test/core/test_lwt_result.ml index 8e354b6308..2f91ef5e62 100644 --- a/test/core/test_lwt_result.ml +++ b/test/core/test_lwt_result.ml @@ -93,7 +93,7 @@ let suite = test "catch, error case" (fun () -> - let x () = Lwt.fail Dummy_error in + let x () = raise Dummy_error in Lwt.return (Lwt_result.catch x = Lwt_result.fail Dummy_error) ); diff --git a/test/core/test_lwt_stream.ml b/test/core/test_lwt_stream.ml index a19f0b3df5..3e5193dc85 100644 --- a/test/core/test_lwt_stream.ml +++ b/test/core/test_lwt_stream.ml @@ -11,7 +11,7 @@ let expect_exit f = Lwt.return_false) (function | Exit -> Lwt.return_true - | e -> Lwt.fail e) + | e -> Lwt.reraise e) let suite = suite "lwt_stream" [ test "from" @@ -351,7 +351,7 @@ let suite = suite "lwt_stream" [ return (Some x) | (Result.Error e)::l -> q := l; - Lwt.fail e) + raise e) in Lwt_stream.to_list (Lwt_stream.wrap_exn stream) >>= fun l' -> return (l = l')); @@ -418,7 +418,7 @@ let suite = suite "lwt_stream" [ test "exception passing: basic, from" (fun () -> - let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in + let stream = Lwt_stream.from (fun () -> raise Exit) in expect_exit (fun () -> Lwt_stream.get stream)); test "exception passing: basic, from_direct" @@ -428,12 +428,12 @@ let suite = suite "lwt_stream" [ test "exception passing: to_list" (fun () -> - let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in + let stream = Lwt_stream.from (fun () -> raise Exit) in expect_exit (fun () -> Lwt_stream.to_list stream)); test "exception passing: mapped" (fun () -> - let stream = Lwt_stream.from (fun () -> Lwt.fail Exit) in + let stream = Lwt_stream.from (fun () -> raise Exit) in let stream = Lwt_stream.map (fun v -> v) stream in expect_exit (fun () -> Lwt_stream.get stream)); From 3bfbb5c23466269f4a6451922006896190c24e8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 7 Feb 2024 11:23:36 +0100 Subject: [PATCH 2/3] Use raise and reraise instead of fail in more places in unix --- src/unix/lwt_io.ml | 34 ++++++++++++++--------------- src/unix/lwt_process.cppo.ml | 10 ++++----- src/unix/lwt_unix.cppo.ml | 18 +++++++-------- test/unix/test_lwt_bytes.ml | 6 ++--- test/unix/test_lwt_engine.ml | 2 +- test/unix/test_lwt_io.ml | 6 ++--- test/unix/test_lwt_unix.ml | 18 +++++++-------- test/unix/test_mcast.ml | 6 ++--- test/unix/test_sleep_and_timeout.ml | 4 ++-- 9 files changed, 52 insertions(+), 52 deletions(-) diff --git a/src/unix/lwt_io.ml b/src/unix/lwt_io.ml index cf0b18bf05..8b3033faec 100644 --- a/src/unix/lwt_io.ml +++ b/src/unix/lwt_io.ml @@ -231,7 +231,7 @@ let perform_io : type mode. mode _channel -> int Lwt.t = fun ch -> (function | Unix.Unix_error (Unix.EPIPE, _, _) -> Lwt.return 0 - | exn -> Lwt.fail exn) [@ocaml.warning "-4"] + | exn -> Lwt.reraise exn) [@ocaml.warning "-4"] else perform ch.buffer ptr len in @@ -525,7 +525,7 @@ let make : max = (match mode with | Input -> 0 | Output -> size); - close = lazy(Lwt.catch close Lwt.fail); + close = lazy(Lwt.catch close Lwt.reraise); abort_waiter = abort_waiter; abort_wakener = abort_wakener; main = wrapper; @@ -537,7 +537,7 @@ let make : perform_io, fun pos cmd -> try seek pos cmd - with e when Lwt.Exception_filter.run e -> Lwt.fail e + with e when Lwt.Exception_filter.run e -> Lwt.reraise e ); } and wrapper = { state = Idle; @@ -678,7 +678,7 @@ struct let ptr = ic.ptr in if ptr = ic.max then refill ic >>= function - | 0 -> Lwt.fail End_of_file + | 0 -> raise End_of_file | _ -> read_char ic else begin ic.ptr <- ptr + 1; @@ -690,7 +690,7 @@ struct (fun () -> read_char ic >|= fun ch -> Some ch) (function | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) + | exn -> Lwt.reraise exn) let read_line ic = let buf = Buffer.create 128 in @@ -711,7 +711,7 @@ struct if cr_read then Buffer.add_char buf '\r'; Lwt.return(Buffer.contents buf) | exn -> - Lwt.fail exn) + Lwt.reraise exn) in read_char ic >>= function | '\r' -> loop true @@ -723,7 +723,7 @@ struct (fun () -> read_line ic >|= fun ch -> Some ch) (function | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) + | exn -> Lwt.reraise exn) let unsafe_read_into' ic blit buf ofs len = let avail = ic.max - ic.ptr in @@ -771,7 +771,7 @@ struct let rec loop ic buf ofs len = read_into ic buf ofs len >>= function | 0 -> - Lwt.fail End_of_file + raise End_of_file | n -> let len = len - n in if len = 0 then @@ -985,7 +985,7 @@ struct if ic.max - ic.ptr < size then refill ic >>= function | 0 -> - Lwt.fail End_of_file + raise End_of_file | _ -> read_block_unsafe ic size f else begin @@ -1440,7 +1440,7 @@ let open_temp_file ?buffer ?flags ?perm ?temp_dir ?prefix ?(suffix = "") () = Lwt.return (fname, chan)) (function | Unix.Unix_error _ when n < 1000 -> attempt (n + 1) - | exn -> Lwt.fail exn) + | exn -> Lwt.reraise exn) in attempt 0 @@ -1468,7 +1468,7 @@ let create_temp_dir Lwt.return name) (function | Unix.Unix_error (Unix.EEXIST, _, _) when n < 1000 -> attempt (n + 1) - | exn -> Lwt.fail exn) + | exn -> Lwt.reraise exn) in attempt 0 @@ -1489,10 +1489,10 @@ let win32_unlink fn = (* If everything succeeded but the final removal still failed, restore original permissions *) Lwt_unix.chmod fn st_perm >>= fun () -> - Lwt.fail exn) + Lwt.reraise exn) ) - (fun _ -> Lwt.fail exn) - | exn -> Lwt.fail exn) + (fun _ -> Lwt.reraise exn) + | exn -> Lwt.reraise exn) let unlink = if Sys.win32 then @@ -1549,7 +1549,7 @@ let close_socket fd = (function (* Occurs if the peer closes the connection first. *) | Unix.Unix_error (Unix.ENOTCONN, _, _) -> Lwt.return_unit - | exn -> Lwt.fail exn) [@ocaml.warning "-4"]) + | exn -> Lwt.reraise exn) [@ocaml.warning "-4"]) (fun () -> Lwt_unix.close fd) @@ -1574,7 +1574,7 @@ let open_connection ?fd ?in_buffer ?out_buffer sockaddr = ~mode:output (Lwt_bytes.write fd))) (fun exn -> Lwt_unix.close fd >>= fun () -> - Lwt.fail exn) + Lwt.reraise exn) let with_close_connection f (ic, oc) = (* If the user already tried to close the socket and got an exception, we @@ -1639,7 +1639,7 @@ let establish_server_generic (function | Unix.Unix_error (Unix.ECONNABORTED, _, _) -> Lwt.return `Try_again - | e -> Lwt.fail e) + | e -> Lwt.reraise e) in Lwt.pick [try_to_accept; should_stop] >>= function diff --git a/src/unix/lwt_process.cppo.ml b/src/unix/lwt_process.cppo.ml index 791e38ba71..ceb86be232 100644 --- a/src/unix/lwt_process.cppo.ml +++ b/src/unix/lwt_process.cppo.ml @@ -378,7 +378,7 @@ let read_opt read ic = (function | Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) [@ocaml.warning "-4"] + | exn -> Lwt.reraise exn) [@ocaml.warning "-4"] let recv_chars pr = let ic = pr#stdout in @@ -512,8 +512,8 @@ let pmap ?timeout ?env ?cwd ?stderr cmd text = | Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; - Lwt.fail exn - | exn -> Lwt.fail exn) + Lwt.reraise exn + | exn -> Lwt.reraise exn) let pmap_chars ?timeout ?env ?cwd ?stderr cmd chars = let pr = open_process ?timeout ?env ?cwd ?stderr cmd in @@ -534,8 +534,8 @@ let pmap_line ?timeout ?env ?cwd ?stderr cmd line = | Lwt.Canceled as exn -> (* Cancel the getter if the sender was canceled. *) Lwt.cancel getter; - Lwt.fail exn - | exn -> Lwt.fail exn) + Lwt.reraise exn + | exn -> Lwt.reraise exn) let pmap_lines ?timeout ?env ?cwd ?stderr cmd lines = let pr = open_process ?timeout ?env ?cwd ?stderr cmd in diff --git a/src/unix/lwt_unix.cppo.ml b/src/unix/lwt_unix.cppo.ml index 20f73378e1..5edb4b83d0 100644 --- a/src/unix/lwt_unix.cppo.ml +++ b/src/unix/lwt_unix.cppo.ml @@ -147,7 +147,7 @@ let auto_pause timeout = exception Timeout -let timeout d = sleep d >>= fun () -> Lwt.fail Timeout +let timeout d = sleep d >>= fun () -> raise Timeout let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()] @@ -582,7 +582,7 @@ let wrap_syscall event ch action = | Retry_write -> register_action Write ch action | e when Lwt.Exception_filter.run e -> - Lwt.fail e + Lwt.reraise e (* +-----------------------------------------------------------------+ | Basic file input/output | @@ -636,7 +636,7 @@ let wait_read ch = Lwt.return_unit else register_action Read ch ignore) - Lwt.fail + Lwt.reraise external stub_read : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_read" external read_job : Unix.file_descr -> Bytes.t -> int -> int -> int job = "lwt_unix_read_job" @@ -694,7 +694,7 @@ let wait_write ch = Lwt.return_unit else register_action Write ch ignore) - Lwt.fail + Lwt.reraise external stub_write : Unix.file_descr -> Bytes.t -> int -> int -> int = "lwt_unix_write" external write_job : Unix.file_descr -> Bytes.t -> int -> int -> int job = "lwt_unix_write_job" @@ -1034,7 +1034,7 @@ let file_exists name = (fun e -> match e with | Unix.Unix_error _ -> Lwt.return_false - | _ -> Lwt.fail e) [@ocaml.warning "-4"] + | _ -> Lwt.reraise e) [@ocaml.warning "-4"] external utimes_job : string -> float -> float -> unit job = "lwt_unix_utimes_job" @@ -1140,7 +1140,7 @@ struct (fun e -> match e with | Unix.Unix_error _ -> Lwt.return_false - | _ -> Lwt.fail e) [@ocaml.warning "-4"] + | _ -> Lwt.reraise e) [@ocaml.warning "-4"] end @@ -1408,7 +1408,7 @@ let files_of_directory path = (fun () -> readdir_n handle chunk_size) (fun exn -> closedir handle >>= fun () -> - Lwt.fail exn) >>= fun entries -> + Lwt.reraise exn) >>= fun entries -> if Array.length entries < chunk_size then begin state := LDS_done; closedir handle >>= fun () -> @@ -1423,7 +1423,7 @@ let files_of_directory path = (fun () -> readdir_n handle chunk_size) (fun exn -> closedir handle >>= fun () -> - Lwt.fail exn) >>= fun entries -> + Lwt.reraise exn) >>= fun entries -> if Array.length entries < chunk_size then begin state := LDS_done; closedir handle >>= fun () -> @@ -2395,7 +2395,7 @@ let () = let _waitpid flags pid = Lwt.catch (fun () -> Lwt.return (Unix.waitpid flags pid)) - Lwt.fail + Lwt.reraise let waitpid = if Sys.win32 then diff --git a/test/unix/test_lwt_bytes.ml b/test/unix/test_lwt_bytes.ml index e29843ca8c..6de438b8de 100644 --- a/test/unix/test_lwt_bytes.ml +++ b/test/unix/test_lwt_bytes.ml @@ -793,7 +793,7 @@ let suite = suite "lwt_bytes" [ ) (function | Invalid_argument _message -> Lwt.return_true - | exn -> Lwt.fail exn + | exn -> Lwt.reraise exn ) end; @@ -825,7 +825,7 @@ let suite = suite "lwt_bytes" [ ) (function | Invalid_argument _message -> Lwt.return_true - | exn -> Lwt.fail exn + | exn -> Lwt.reraise exn ) end; @@ -839,7 +839,7 @@ let suite = suite "lwt_bytes" [ ) (function | Invalid_argument _message -> Lwt.return_true - | exn -> Lwt.fail exn + | exn -> Lwt.reraise exn ) end; ] diff --git a/test/unix/test_lwt_engine.ml b/test/unix/test_lwt_engine.ml index 38c7dcff11..3b6a5d231e 100644 --- a/test/unix/test_lwt_engine.ml +++ b/test/unix/test_lwt_engine.ml @@ -49,7 +49,7 @@ let timing_tests = [ | Lwt_unix.Timeout -> Lwt.return (Unix.gettimeofday ()) | exn -> - Lwt.fail exn) + Lwt.reraise exn) >>= fun stop -> diff --git a/test/unix/test_lwt_io.ml b/test/unix/test_lwt_io.ml index f6bad19cd7..f902f5e3ed 100644 --- a/test/unix/test_lwt_io.ml +++ b/test/unix/test_lwt_io.ml @@ -320,7 +320,7 @@ let suite = suite "lwt_io" [ exceptions_observed := !exceptions_observed + 1; Lwt.return_unit | exn -> - Lwt.fail exn) [@ocaml.warning "-4"] + Lwt.reraise exn) [@ocaml.warning "-4"] in let fd_r, fd_w = Lwt_unix.pipe () in @@ -353,7 +353,7 @@ let suite = suite "lwt_io" [ let filename = ref "." in let wrap f (filename', chan) = filename := filename'; f chan in let write_data chan = Lwt_io.write chan "test file content" in - let write_data_fail _ = Lwt.fail Dummy_error in + let write_data_fail _ = Lwt.fail Dummy_error in Lwt_io.with_temp_file (wrap write_data) ~prefix >>= fun _ -> let no_temps1 = not (Sys.file_exists !filename) in Lwt.catch @@ -422,7 +422,7 @@ let suite = suite "lwt_io" [ (function | Unix.Unix_error (Unix.EISDIR, "file_length", ".") -> Lwt.return_true - | exn -> Lwt.fail exn) + | exn -> Lwt.reraise exn) end; test "input channel of_bytes initial position" diff --git a/test/unix/test_lwt_unix.ml b/test/unix/test_lwt_unix.ml index b802d867da..609ca3c2a0 100644 --- a/test/unix/test_lwt_unix.ml +++ b/test/unix/test_lwt_unix.ml @@ -172,7 +172,7 @@ let utimes_tests = [ (function | Unix.Unix_error (Unix.ENOENT, "utimes", _) -> Lwt.return_unit | Unix.Unix_error (Unix.EUNKNOWNERR _, "utimes", _) -> Lwt.return_unit - | e -> Lwt.fail e) [@ocaml.warning "-4"] >>= fun () -> + | e -> Lwt.reraise e) [@ocaml.warning "-4"] >>= fun () -> Lwt.return_true); ] @@ -218,7 +218,7 @@ let readdir_tests = Lwt.return (Some filename)) (function | End_of_file -> Lwt.return_none - | exn -> Lwt.fail exn) + | exn -> Lwt.reraise exn) >>= function | None -> Lwt.return acc | Some filename -> loop (filename::acc) @@ -305,7 +305,7 @@ let readdir_tests = (function | Unix.Unix_error (Unix.EBADF, tag', _) when tag' = tag -> Lwt.return_true - | exn -> Lwt.fail exn) [@ocaml.warning "-4"] + | exn -> Lwt.reraise exn) [@ocaml.warning "-4"] in Lwt_list.for_all_s (fun (tag, t) -> expect_ebadf tag t) @@ -711,7 +711,7 @@ let writev_tests = Lwt.return_false) (function | Invalid_argument _ -> Lwt.return_true - | e -> Lwt.fail e) + | e -> Lwt.reraise e) in let close write_fd = fun () -> @@ -963,7 +963,7 @@ let bind_tests = | Unix.Unix_error (Unix.EADDRINUSE, "bind", _) | Unix.Unix_error (Unix.EISDIR, "bind", _) as exn -> if attempts <= 1 then - Lwt.fail exn + Lwt.reraise exn else bind_loop (attempts - 1) | Unix.Unix_error (Unix.EPERM, "bind", _) -> @@ -972,8 +972,8 @@ let bind_tests = test should add a check for WSL by checking for the existence of /proc/version, reading it, and checking its contents for the string "WSL". *) - Lwt.fail Skip - | e -> Lwt.fail e) [@ocaml.warning "-4"] + raise Skip + | e -> Lwt.reraise e) [@ocaml.warning "-4"] in Lwt.finalize @@ -1014,7 +1014,7 @@ let bind_tests = Lwt.return_false) (function | Unix.Unix_error (Unix.EBADF, _, _) -> Lwt.return_true - | e -> Lwt.fail e) [@ocaml.warning "-4"]); + | e -> Lwt.reraise e) [@ocaml.warning "-4"]); test "bind: aborted" (fun () -> @@ -1028,7 +1028,7 @@ let bind_tests = Lwt.return_false) (function | Exit -> Lwt.return_true - | e -> Lwt.fail e)) + | e -> Lwt.reraise e)) (fun () -> Lwt_unix.close socket)); ] diff --git a/test/unix/test_mcast.ml b/test/unix/test_mcast.ml index dbdfd446cf..a44838f552 100644 --- a/test/unix/test_mcast.ml +++ b/test/unix/test_mcast.ml @@ -26,7 +26,7 @@ let child mcast_addr join fd = if debug then Printf.printf "\nReceived multicast message %S\n%!" (Bytes.unsafe_to_string (Bytes.sub buf 0 n)); if Bytes.sub buf 0 n <> hello then - Lwt.fail (Failure "unexpected multicast message") + raise (Failure "unexpected multicast message") else Lwt.return_unit @@ -61,9 +61,9 @@ let test_mcast name join set_loop = | Unix.Unix_error (Unix.EINVAL, "send", _) | Unix.Unix_error (Unix.ENODEV, "setsockopt", _) | Unix.Unix_error (Unix.ENETUNREACH, "send", _) -> - Lwt.fail Skip + raise Skip | e -> - Lwt.fail e + Lwt.reraise e ) in Lwt.finalize t (fun () -> Lwt.join [Lwt_unix.close fd1; Lwt_unix.close fd2]) diff --git a/test/unix/test_sleep_and_timeout.ml b/test/unix/test_sleep_and_timeout.ml index 40acf13853..70831ea57e 100644 --- a/test/unix/test_sleep_and_timeout.ml +++ b/test/unix/test_sleep_and_timeout.ml @@ -35,7 +35,7 @@ let suite = suite "Lwt_unix sleep and timeout" [ | Lwt_unix.Timeout -> let check = cmp_elapsed_time "timeout" start_time duration in Lwt.return check - | exn -> Lwt.fail exn + | exn -> Lwt.reraise exn ) end; @@ -61,7 +61,7 @@ let suite = suite "Lwt_unix sleep and timeout" [ let check = cmp_elapsed_time "with_timeout : timeout" start_time duration in Lwt.return check - | exn -> Lwt.fail exn + | exn -> Lwt.reraise exn ) end; From 4d98a0a934c677833d68fc00a61f1cfd7320fa12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 7 Feb 2024 11:24:17 +0100 Subject: [PATCH 3/3] Use reraise instead of fail in more places in ppx --- src/ppx/ppx_lwt.ml | 6 +++--- src/ppx/ppx_lwt.mli | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/ppx/ppx_lwt.ml b/src/ppx/ppx_lwt.ml index c2030be231..e77486c1aa 100644 --- a/src/ppx/ppx_lwt.ml +++ b/src/ppx/ppx_lwt.ml @@ -23,7 +23,7 @@ let add_wildcard_case cases = if not has_wildcard then cases @ (let loc = Location.none in - [case ~lhs:[%pat? exn] ~guard:None ~rhs:[%expr Lwt.fail exn]]) + [case ~lhs:[%pat? exn] ~guard:None ~rhs:[%expr Lwt.reraise exn]]) else cases (** {3 Internal names} *) @@ -154,11 +154,11 @@ let lwt_expression mapper exp attributes ext_loc = Some (mapper#expression { new_exp with pexp_attributes }) (* [assert%lwt $e$] ≡ - [try Lwt.return (assert $e$) with exn -> Lwt.fail exn] *) + [try Lwt.return (assert $e$) with exn -> Lwt.reraise exn] *) | Pexp_assert e -> let new_exp = let loc = !default_loc in - [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.fail exn] + [%expr try Lwt.return (assert [%e e]) with exn -> Lwt.reraise exn] in Some (mapper#expression { new_exp with pexp_attributes }) diff --git a/src/ppx/ppx_lwt.mli b/src/ppx/ppx_lwt.mli index 1d3a541e6a..0912c07e01 100644 --- a/src/ppx/ppx_lwt.mli +++ b/src/ppx/ppx_lwt.mli @@ -80,10 +80,10 @@ catch (fun () -> f x) prerr_endline msg; return () | exn -> - Lwt.fail exn) + Lwt.reraise exn) ]} - Note that the [exn -> Lwt.fail exn] branch is automatically added + Note that the [exn -> Lwt.reraise exn] branch is automatically added when needed. - finalizer: