From c2fbe5b8ddc3d3a7f9fda8acda79140dbe188370 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Thu, 16 Oct 2025 05:39:02 +0200 Subject: [PATCH 1/5] core: factorize 'let Pending callbacks = p.state' in a helper function --- src/core/lwt.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/core/lwt.ml b/src/core/lwt.ml index 257134c63..5323728a7 100644 --- a/src/core/lwt.ml +++ b/src/core/lwt.ml @@ -469,6 +469,9 @@ struct ('a, _, _) promise Lwt_sequence.node -> 'a cancel_callback_list + let[@inline] get_pending : ('a, underlying, pending) state -> 'a callbacks = function + | Pending callbacks -> callbacks + (* Notes: These type definitions are guilty of performing several optimizations, @@ -1291,7 +1294,7 @@ struct run_callbacks callbacks result) let resolve ?allow_deferring ?maximum_callback_nesting_depth p result = - let Pending callbacks = p.state in + let callbacks = get_pending p.state in let p = set_promise_state p result in run_callbacks_or_defer_them @@ -1574,7 +1577,7 @@ struct let node = Lwt_sequence.add_r (to_public_resolver p) sequence in let node = cast_sequence_node node p in - let Pending callbacks = p.state in + let callbacks = get_pending p.state in callbacks.cancel_callbacks <- Cancel_callback_list_remove_sequence_node node; @@ -1585,7 +1588,7 @@ struct let node = Lwt_sequence.add_l (to_public_resolver p) sequence in let node = cast_sequence_node node p in - let Pending callbacks = p.state in + let callbacks = get_pending p.state in callbacks.cancel_callbacks <- Cancel_callback_list_remove_sequence_node node; @@ -1629,7 +1632,7 @@ struct [p] callback in - let Pending p'_callbacks = p'.state in + let p'_callbacks = get_pending p'.state in add_cancel_callback p'_callbacks remove_the_callback; to_public_promise p' @@ -1773,7 +1776,7 @@ struct resolve ~allow_deferring:false outer_promise p'.state | Pending p'_callbacks -> - let Pending outer_callbacks = outer_promise.state in + let outer_callbacks = get_pending outer_promise.state in merge_callbacks ~from:p'_callbacks ~into:outer_callbacks; outer_callbacks.how_to_cancel <- p'_callbacks.how_to_cancel; From faff34058422db6ff581bd796efdd575fc597aba Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Thu, 16 Oct 2025 06:34:03 +0200 Subject: [PATCH 2/5] core/lwt.ml: simplify [run_callback_or_defer_it] as it never defers --- src/core/lwt.ml | 165 ++++++------------------------------------------ 1 file changed, 21 insertions(+), 144 deletions(-) diff --git a/src/core/lwt.ml b/src/core/lwt.ml index 5323728a7..1c47711ff 100644 --- a/src/core/lwt.ml +++ b/src/core/lwt.ml @@ -1031,11 +1031,7 @@ sig 'a resolved_state -> unit - val run_callback_or_defer_it : - ?run_immediately_and_ensure_tail_call:bool -> - callback:(unit -> 'a) -> - if_deferred:(unit -> 'a * 'b regular_callback * 'b resolved_state) -> - 'a + val run_callback : ('a -> 'b) -> 'a -> 'b val handle_with_async_exception_hook : ('a -> unit) -> 'a -> unit @@ -1084,7 +1080,7 @@ struct the current implementation of [Lwt.cancel] needs to call it directly. Promise resolution and callback calling are separated in a unique way in [cancel]. - - [run_callback_or_defer_it], which is used by [Lwt.bind] and similar + - [run_callback], which is used by [Lwt.bind] and similar functions to call single callbacks when the promises passed to [Lwt.bind], etc., are already resolved. @@ -1302,40 +1298,7 @@ struct p - let run_callback_or_defer_it - ?(run_immediately_and_ensure_tail_call = false) - ~callback:f - ~if_deferred = - - if run_immediately_and_ensure_tail_call then - f () - - else - let should_defer = - !current_callback_nesting_depth - >= default_maximum_callback_nesting_depth - in - - if should_defer then begin - let immediate_result, deferred_callback, deferred_result = - if_deferred () in - let deferred_record = - { - regular_callbacks = - Regular_callback_list_implicitly_removed_callback - deferred_callback; - cancel_callbacks = Cancel_callback_list_empty; - how_to_cancel = Not_cancelable; - cleanups_deferred = 0 - } - in - Queue.push - (Deferred (deferred_record, deferred_result)) deferred_callbacks; - immediate_result - end - else - run_in_resolution_loop (fun () -> - f ()) + let[@inline] run_callback callback v = callback v end include Resolution_loop @@ -1877,13 +1840,7 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> f v) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + run_callback f v | Rejected _ as result -> to_public_promise {state = result} @@ -1934,13 +1891,7 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> f v) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + run_callback f v | Rejected exn -> to_public_promise {state = Rejected (add_loc exn)} @@ -1990,17 +1941,13 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> + run_callback + (fun () -> to_public_promise {state = try Fulfilled (f v) with exn when Exception_filter.run exn -> Rejected exn}) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + () | Rejected _ as result -> to_public_promise {state = result} @@ -2060,13 +2007,7 @@ struct to_public_promise p | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> h exn) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + run_callback h exn | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in @@ -2122,13 +2063,7 @@ struct to_public_promise p | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> h (add_loc exn)) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + run_callback h (add_loc exn) | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in @@ -2188,22 +2123,10 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> f' v) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + run_callback f' v | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> h exn) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + run_callback h exn | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in @@ -2265,22 +2188,10 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> f' v) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + run_callback f' v | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> h (add_loc exn)) - ~if_deferred:(fun () -> - let (p'', callback) = - create_result_promise_and_callback_if_deferred () in - (p'', callback, p.state)) + run_callback h (add_loc exn) | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in @@ -2305,11 +2216,7 @@ struct match p.state with | Rejected Canceled -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f ()) - ~if_deferred:(fun () -> - ((), (fun _ -> handle_with_async_exception_hook f ()), Fulfilled ())) + run_callback (handle_with_async_exception_hook f) () | Rejected _ -> () @@ -2341,12 +2248,7 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f v) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) + run_callback (handle_with_async_exception_hook f) v | Rejected _ -> () @@ -2377,12 +2279,7 @@ struct () | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f exn) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) + run_callback (handle_with_async_exception_hook f) exn | Pending p_callbacks -> let callback = callback_if_deferred () in @@ -2402,20 +2299,10 @@ struct match p.state with | Fulfilled _ -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f ()) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) + run_callback (handle_with_async_exception_hook f) () | Rejected _ -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f ()) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) + run_callback (handle_with_async_exception_hook f) () | Pending p_callbacks -> let callback = callback_if_deferred () in @@ -2441,20 +2328,10 @@ struct match p.state with | Fulfilled v -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook f v) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) + run_callback (handle_with_async_exception_hook f) v | Rejected exn -> - run_callback_or_defer_it - ~run_immediately_and_ensure_tail_call:true - ~callback:(fun () -> handle_with_async_exception_hook g exn) - ~if_deferred:(fun () -> - let callback = callback_if_deferred () in - ((), callback, p.state)) + run_callback (handle_with_async_exception_hook g) exn | Pending p_callbacks -> let callback = callback_if_deferred () in From 621bba6f017b3f4c5df5dd04711369e24380c8a5 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Thu, 16 Oct 2025 08:21:25 +0200 Subject: [PATCH 3/5] core/lwt.ml: box resolved states This commit guarantees that, even if we later weaken the type information available on `state`, we keep precise guarantees on `result` values -- they are not a subset of possible states anymore, but a separate type. There may be a performance impact to this change, so running benchmarks would be useful. --- src/core/lwt.ml | 331 +++++++++++++++++++++++------------------------- 1 file changed, 155 insertions(+), 176 deletions(-) diff --git a/src/core/lwt.ml b/src/core/lwt.ml index 1c47711ff..7c1da643e 100644 --- a/src/core/lwt.ml +++ b/src/core/lwt.ml @@ -392,8 +392,7 @@ struct } and (_, _, _) state = - | Fulfilled : 'a -> ('a, underlying, resolved) state - | Rejected : exn -> ( _, underlying, resolved) state + | Resolved : 'a resolved_state -> ('a, underlying, resolved) state | Pending : 'a callbacks -> ('a, underlying, pending) state | Proxy : ('a, _, 'c) promise -> ('a, proxy, 'c) state @@ -439,7 +438,7 @@ struct and cancel_callback = unit -> unit - and 'a resolved_state = ('a, underlying, resolved) state + and 'a resolved_state = ('a, exn) result and how_to_cancel = | Not_cancelable : how_to_cancel @@ -477,11 +476,6 @@ struct These type definitions are guilty of performing several optimizations, without which they would be much easier to understand. - - The type parameters of ['a resolved_state] guarantee that it is either - [Fulfilled _] or [Rejected _]. So, it is equivalent to - [('a, exn) Stdlib.result], and, indeed, should have an identical - memory representation. - - As per the Overview, there are regular callbacks and cancel callbacks. Cancel callbacks are called only on cancellation, and, then, before any regular callbacks are called. @@ -565,11 +559,6 @@ struct type. The introduction and immediate elimination of [Internal _] seems to be optimized away even on older versions of OCaml that don't have Flambda and don't support [[@@ocaml.unboxed]]. *) - - (* This could probably save an allocation by using [Obj.magic]. *) - let state_of_result = function - | Ok x -> Fulfilled x - | Error exn -> Rejected exn end include Public_types @@ -608,8 +597,7 @@ struct fun p -> match p.state with - | Fulfilled _ -> (p : (_, underlying, _) promise) - | Rejected _ -> p + | Resolved _ -> (p : (_, underlying, _) promise) | Pending _ -> p | Proxy p' -> let p'' = underlying p' in @@ -657,8 +645,6 @@ struct signature that is a near-duplicate of [Main_internal_types], or some abuse of functors. *) - - type 'a may_now_be_proxy = | State_may_now_be_pending_proxy : ('a, _, pending) promise -> 'a may_now_be_proxy @@ -711,6 +697,9 @@ struct end open Basic_helpers +let set_promise_state_resolved p result = + set_promise_state p (Resolved result) + (* Small helpers to avoid catching ocaml-runtime exceptions *) module Exception_filter = struct type t = exn -> bool @@ -888,8 +877,7 @@ struct match (underlying p).state with (* Some of the promises may already have been resolved at the time this function is called. *) - | Fulfilled _ -> () - | Rejected _ -> () + | Resolved _ -> () | Pending callbacks -> match callbacks.regular_callbacks with @@ -978,8 +966,8 @@ struct let Internal p = to_internal_promise p in match (underlying p).state with | Pending callbacks -> add_regular_callback_list_node callbacks node - | Fulfilled _ -> assert false - | Rejected _ -> assert false); + | Resolved _ -> assert false + ); cell @@ -1216,9 +1204,9 @@ struct (* Pattern matching is much faster than polymorphic comparison. *) let is_canceled = match result with - | Rejected Canceled -> true - | Rejected _ -> false - | Fulfilled _ -> false + | Error Canceled -> true + | Error _ -> false + | Ok _ -> false in if is_canceled then run_cancel_callbacks callbacks.cancel_callbacks; @@ -1291,7 +1279,7 @@ struct let resolve ?allow_deferring ?maximum_callback_nesting_depth p result = let callbacks = get_pending p.state in - let p = set_promise_state p result in + let p = set_promise_state_resolved p result in run_callbacks_or_defer_them ?allow_deferring ?maximum_callback_nesting_depth callbacks result; @@ -1325,15 +1313,16 @@ struct let p = underlying p in match p.state with - | Rejected Canceled -> - () - | Fulfilled _ -> - Printf.ksprintf invalid_arg "Lwt.%s" api_function_name - | Rejected _ -> - Printf.ksprintf invalid_arg "Lwt.%s" api_function_name + | Resolved result -> + begin match result with + | Error Canceled -> () + | Ok _ -> + Printf.ksprintf invalid_arg "Lwt.%s" api_function_name + | Error _ -> + Printf.ksprintf invalid_arg "Lwt.%s" api_function_name + end | Pending _ -> - let result = state_of_result result in let State_may_have_changed p = resolve ~allow_deferring:false p result in ignore p @@ -1346,15 +1335,16 @@ struct let p = underlying p in match p.state with - | Rejected Canceled -> - () - | Fulfilled _ -> - Printf.ksprintf invalid_arg "Lwt.%s" api_function_name - | Rejected _ -> - Printf.ksprintf invalid_arg "Lwt.%s" api_function_name + | Resolved result -> + begin match result with + | Error Canceled -> () + | Ok _ -> + Printf.ksprintf invalid_arg "Lwt.%s" api_function_name + | Error _ -> + Printf.ksprintf invalid_arg "Lwt.%s" api_function_name + end | Pending _ -> - let result = state_of_result result in let State_may_have_changed p = resolve ~maximum_callback_nesting_depth:1 p result in ignore p @@ -1376,7 +1366,7 @@ struct behavior: it runs callbacks directly on the current stack. It should therefore be possible to cause a stack overflow using this function. *) let cancel p = - let canceled_result = Rejected Canceled in + let canceled_result = Error Canceled in (* Walks the promise dependency graph backwards, looking for cancelable initial promises, and cancels (only) them. @@ -1399,9 +1389,7 @@ struct let p = underlying p in match p.state with (* If the promise is not still pending, it can't be canceled. *) - | Fulfilled _ -> - callbacks_accumulator - | Rejected _ -> + | Resolved _ -> callbacks_accumulator | Pending callbacks -> @@ -1410,7 +1398,7 @@ struct callbacks_accumulator | Cancel_this_promise -> let State_may_have_changed p = - set_promise_state p canceled_result in + set_promise_state_resolved p canceled_result in ignore p; (Packed callbacks)::callbacks_accumulator | Propagate_cancel_to_one p' -> @@ -1452,13 +1440,13 @@ sig end = struct let return v = - to_public_promise {state = Fulfilled v} + to_public_promise {state = Resolved (Ok v)} let of_result result = - to_public_promise {state = state_of_result result} + to_public_promise {state = Resolved result} let fail exn = - to_public_promise {state = Rejected exn} + to_public_promise {state = Resolved (Error exn)} let return_unit = return () let return_none = return None @@ -1470,10 +1458,10 @@ struct let return_error x = return (Error x) let fail_with msg = - to_public_promise {state = Rejected (Failure msg)} + to_public_promise {state = Resolved (Error (Failure msg))} let fail_invalid_arg msg = - to_public_promise {state = Rejected (Invalid_argument msg)} + to_public_promise {state = Resolved (Error (Invalid_argument msg))} end include Trivial_promises @@ -1562,8 +1550,7 @@ struct let protected p = let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with - | Fulfilled _ -> p - | Rejected _ -> p + | Resolved _ -> p | Pending _ -> let p' = new_pending ~how_to_cancel:Cancel_this_promise in @@ -1603,8 +1590,7 @@ struct let no_cancel p = let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with - | Fulfilled _ -> p - | Rejected _ -> p + | Resolved _ -> p | Pending p_callbacks -> let p' = new_pending ~how_to_cancel:Not_cancelable in @@ -1733,10 +1719,8 @@ struct else match p'.state with - | Fulfilled _ -> - resolve ~allow_deferring:false outer_promise p'.state - | Rejected _ -> - resolve ~allow_deferring:false outer_promise p'.state + | Resolved result -> + resolve ~allow_deferring:false outer_promise result | Pending p'_callbacks -> let outer_callbacks = get_pending outer_promise.state in @@ -1801,7 +1785,7 @@ struct let callback p_result = match p_result with - | Fulfilled v -> + | Ok v -> current_storage := saved_storage; let p' = @@ -1826,7 +1810,7 @@ struct (* Make the outer promise [p''] behaviorally identical to the promise [p'] returned by [f] by making [p'] into a proxy of [p'']. *) - | Rejected _ as p_result -> + | Error _ as p_result -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in @@ -1839,11 +1823,11 @@ struct in match p.state with - | Fulfilled v -> + | Resolved (Ok v) -> run_callback f v - | Rejected _ as result -> - to_public_promise {state = result} + | Resolved (Error _) as error_state -> + to_public_promise {state = error_state} | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in @@ -1861,7 +1845,7 @@ struct let callback p_result = match p_result with - | Fulfilled v -> + | Ok v -> current_storage := saved_storage; let p' = @@ -1877,12 +1861,12 @@ struct make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' - | Rejected exn -> + | Error exn -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = - resolve ~allow_deferring:false p'' (Rejected (add_loc exn)) in + resolve ~allow_deferring:false p'' (Error (add_loc exn)) in ignore p'' in @@ -1890,11 +1874,11 @@ struct in match p.state with - | Fulfilled v -> + | Resolved (Ok v) -> run_callback f v - | Rejected exn -> - to_public_promise {state = Rejected (add_loc exn)} + | Resolved (Error exn) -> + to_public_promise {state = Resolved (Error (add_loc exn))} | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in @@ -1912,12 +1896,12 @@ struct let callback p_result = match p_result with - | Fulfilled v -> + | Ok v -> current_storage := saved_storage; let p''_result = - try Fulfilled (f v) with exn - when Exception_filter.run exn -> Rejected exn + try Ok (f v) with exn + when Exception_filter.run exn -> Error exn in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in @@ -1927,12 +1911,12 @@ struct resolve ~allow_deferring:false p'' p''_result in ignore p'' - | Rejected _ as p_result -> + | Error _ as p''_result -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in let State_may_have_changed p'' = - resolve ~allow_deferring:false p'' p_result in + resolve ~allow_deferring:false p'' p''_result in ignore p'' in @@ -1940,17 +1924,17 @@ struct in match p.state with - | Fulfilled v -> + | Resolved (Ok v) -> run_callback (fun () -> to_public_promise - {state = - try Fulfilled (f v) - with exn when Exception_filter.run exn -> Rejected exn}) + {state = Resolved ( + try Ok (f v) + with exn when Exception_filter.run exn -> Error exn)}) () - | Rejected _ as result -> - to_public_promise {state = result} + | Resolved (Error _) as resolved_state -> + to_public_promise {state = resolved_state} | Pending p_callbacks -> let (p'', callback) = create_result_promise_and_callback_if_deferred () in @@ -1974,7 +1958,7 @@ struct let callback p_result = match p_result with - | Fulfilled _ as p_result -> + | Ok _ -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in @@ -1982,7 +1966,7 @@ struct resolve ~allow_deferring:false p'' p_result in ignore p'' - | Rejected exn -> + | Error exn -> current_storage := saved_storage; let p' = @@ -2003,10 +1987,10 @@ struct in match p.state with - | Fulfilled _ -> + | Resolved (Ok _) -> to_public_promise p - | Rejected exn -> + | Resolved (Error exn) -> run_callback h exn | Pending p_callbacks -> @@ -2029,7 +2013,7 @@ struct let callback p_result = match p_result with - | Fulfilled _ as p_result -> + | Ok _ -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying p'' in @@ -2037,7 +2021,7 @@ struct resolve ~allow_deferring:false p'' p_result in ignore p'' - | Rejected exn -> + | Error exn -> current_storage := saved_storage; let p' = @@ -2059,10 +2043,10 @@ struct in match p.state with - | Fulfilled _ -> + | Resolved (Ok _) -> to_public_promise p - | Rejected exn -> + | Resolved (Error exn) -> run_callback h (add_loc exn) | Pending p_callbacks -> @@ -2085,7 +2069,7 @@ struct let callback p_result = match p_result with - | Fulfilled v -> + | Ok v -> current_storage := saved_storage; let p' = @@ -2101,7 +2085,7 @@ struct make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' - | Rejected exn -> + | Error exn -> current_storage := saved_storage; let p' = @@ -2122,10 +2106,10 @@ struct in match p.state with - | Fulfilled v -> + | Resolved (Ok v) -> run_callback f' v - | Rejected exn -> + | Resolved (Error exn) -> run_callback h exn | Pending p_callbacks -> @@ -2148,7 +2132,7 @@ struct let callback p_result = match p_result with - | Fulfilled v -> + | Ok v -> current_storage := saved_storage; let p' = @@ -2165,7 +2149,7 @@ struct make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in ignore p'' - | Rejected exn -> + | Error exn -> current_storage := saved_storage; let p' = @@ -2187,10 +2171,10 @@ struct in match p.state with - | Fulfilled v -> + | Resolved (Ok v) -> run_callback f' v - | Rejected exn -> + | Resolved (Error exn) -> run_callback h (add_loc exn) | Pending p_callbacks -> @@ -2215,13 +2199,10 @@ struct let p = underlying p in match p.state with - | Rejected Canceled -> + | Resolved (Error Canceled) -> run_callback (handle_with_async_exception_hook f) () - | Rejected _ -> - () - - | Fulfilled _ -> + | Resolved _ -> () | Pending callbacks -> @@ -2238,19 +2219,19 @@ struct fun result -> match result with - | Fulfilled v -> + | Ok v -> current_storage := saved_storage; handle_with_async_exception_hook f v - | Rejected _ -> + | Error _ -> () in match p.state with - | Fulfilled v -> + | Resolved (Ok v) -> run_callback (handle_with_async_exception_hook f) v - | Rejected _ -> + | Resolved (Error _) -> () | Pending p_callbacks -> @@ -2266,19 +2247,19 @@ struct fun result -> match result with - | Fulfilled _ -> + | Ok _ -> () - | Rejected exn -> + | Error exn -> current_storage := saved_storage; handle_with_async_exception_hook f exn in match p.state with - | Fulfilled _ -> + | Resolved (Ok _) -> () - | Rejected exn -> + | Resolved (Error exn) -> run_callback (handle_with_async_exception_hook f) exn | Pending p_callbacks -> @@ -2298,10 +2279,10 @@ struct in match p.state with - | Fulfilled _ -> + | Resolved (Ok _) -> run_callback (handle_with_async_exception_hook f) () - | Rejected _ -> + | Resolved (Error _) -> run_callback (handle_with_async_exception_hook f) () | Pending p_callbacks -> @@ -2317,20 +2298,20 @@ struct fun result -> match result with - | Fulfilled v -> + | Ok v -> current_storage := saved_storage; handle_with_async_exception_hook f v - | Rejected exn -> + | Error exn -> current_storage := saved_storage; handle_with_async_exception_hook g exn in match p.state with - | Fulfilled v -> + | Resolved (Ok v) -> run_callback (handle_with_async_exception_hook f) v - | Rejected exn -> + | Resolved (Error exn) -> run_callback (handle_with_async_exception_hook g) exn | Pending p_callbacks -> @@ -2346,8 +2327,7 @@ let wrap_in_cancelable p = let Internal p_internal = to_internal_promise p in let p_underlying = underlying p_internal in match p_underlying.state with - | Fulfilled _ -> p - | Rejected _ -> p + | Resolved _ -> p | Pending _ -> let p', r = task () in on_cancel p' (fun () -> cancel p); @@ -2384,17 +2364,17 @@ struct let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled _ -> + | Resolved (Ok _) -> () - | Rejected exn -> + | Resolved (Error exn) -> h exn | Pending p_callbacks -> let callback result = match result with - | Fulfilled _ -> + | Ok _ -> () - | Rejected exn -> + | Error exn -> h exn in add_implicitly_removed_callback p_callbacks callback @@ -2407,17 +2387,17 @@ struct let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled _ -> + | Resolved (Ok _) -> () - | Rejected exn -> + | Resolved (Error exn) -> !async_exception_hook exn | Pending p_callbacks -> let callback result = match result with - | Fulfilled _ -> + | Ok _ -> () - | Rejected exn -> + | Error exn -> !async_exception_hook exn in add_implicitly_removed_callback p_callbacks callback @@ -2426,17 +2406,17 @@ struct let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled _ -> + | Resolved (Ok _) -> () - | Rejected exn -> + | Resolved (Error exn) -> reraise exn | Pending p_callbacks -> let callback result = match result with - | Fulfilled _ -> + | Ok _ -> () - | Rejected exn -> + | Error exn -> !async_exception_hook exn in add_implicitly_removed_callback p_callbacks callback @@ -2447,7 +2427,7 @@ struct let p' = new_pending ~how_to_cancel:(propagate_cancel_to_several ps) in let number_pending_in_ps = ref 0 in - let join_result = ref (Fulfilled ()) in + let join_result = ref (Ok ()) in (* Callback attached to each promise in [ps] that is still pending at the time [join] is called. *) @@ -2455,13 +2435,13 @@ struct let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in begin match new_result with - | Fulfilled () -> () - | Rejected _ -> + | Ok () -> () + | Error _ -> (* For the first promise in [ps] to be rejected, set the result of the [join] to rejected with the same exception.. *) match !join_result with - | Fulfilled () -> join_result := new_result - | Rejected _ -> () + | Ok () -> join_result := new_result + | Error _ -> () end; (* In all cases, decrement the number of promises still pending, and @@ -2482,7 +2462,7 @@ struct match ps with | [] -> if !number_pending_in_ps = 0 then - to_public_promise {state = !join_result} + to_public_promise {state = Resolved !join_result} else to_public_promise p' @@ -2495,18 +2475,18 @@ struct add_implicitly_removed_callback p_callbacks callback; attach_callback_or_resolve_immediately ps - | Rejected _ as p_result -> + | Resolved (Error _ as p_result) -> (* As in the callback above, but for already-resolved promises in [ps]: reject the [join] with the same exception as in the first rejected promise found. [join] still waits for any pending promises before actually resolving, though. *) begin match !join_result with - | Fulfilled () -> join_result := p_result; - | Rejected _ -> () + | Ok () -> join_result := p_result; + | Error _ -> () end; attach_callback_or_resolve_immediately ps - | Fulfilled () -> + | Resolved (Ok ()) -> attach_callback_or_resolve_immediately ps in @@ -2562,8 +2542,8 @@ struct | p :: ps -> let Internal q = to_internal_promise p in match (underlying q).state with - | Fulfilled _ -> count_and_gather_rejected total rejected ps - | Rejected _ -> count_and_gather_rejected (total + 1) (p :: rejected) ps + | Resolved (Ok _) -> count_and_gather_rejected total rejected ps + | Resolved (Error _) -> count_and_gather_rejected (total + 1) (p :: rejected) ps | Pending _ -> count_and_gather_rejected total rejected ps in let rec count_fulfilled total ps = @@ -2572,8 +2552,8 @@ struct | p :: ps -> let Internal q = to_internal_promise p in match (underlying q).state with - | Fulfilled _ -> count_fulfilled (total + 1) ps - | Rejected _ -> count_and_gather_rejected 1 [p] ps + | Resolved (Ok _) -> count_fulfilled (total + 1) ps + | Resolved (Error _) -> count_and_gather_rejected 1 [p] ps | Pending _ -> count_fulfilled total ps in count_fulfilled 0 ps @@ -2592,10 +2572,10 @@ struct | Pending _ -> nth_resolved ps n - | Fulfilled _ -> + | Resolved (Ok _) -> if n <= 0 then p else nth_resolved ps (n - 1) - | Rejected _ -> + | Resolved (Error _) -> if n <= 0 then p else nth_resolved ps (n - 1) @@ -2613,10 +2593,10 @@ struct cancel p; nth_resolved_and_cancel_pending ps n - | Fulfilled _ -> + | Resolved (Ok _) -> if n <= 0 then (List.iter cancel ps; p) else nth_resolved_and_cancel_pending ps (n - 1) - | Rejected _ -> + | Resolved (Error _) -> if n <= 0 then (List.iter cancel ps; p) else nth_resolved_and_cancel_pending ps (n - 1) @@ -2698,16 +2678,16 @@ struct match ps with | [] -> - Fulfilled (List.rev results) + Ok (List.rev results) | p::ps -> let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled v -> + | Resolved (Ok v) -> collect_fulfilled_promises_after_pending (v::results) ps - | Rejected _ as result -> + | Resolved (Error _ as result) -> result | Pending _ -> @@ -2727,11 +2707,11 @@ struct | p::ps -> let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled v -> + | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected (v::acc) ps - | Rejected _ as result -> - to_public_promise {state = result} + | Resolved (Error _) as error_state -> + to_public_promise {state = error_state} | Pending _ -> collect_already_fulfilled_promises_or_find_rejected acc ps @@ -2760,11 +2740,11 @@ struct | p::ps -> let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled v -> + | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected [v] ps - | Rejected _ as result -> - to_public_promise {state = result} + | Resolved (Error _) as error_state -> + to_public_promise {state = error_state} | Pending _ -> check_for_already_resolved_promises ps @@ -2787,12 +2767,12 @@ struct | p::ps' -> let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled v -> + | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected (v::acc) ps' - | Rejected _ as result -> + | Resolved (Error _) as error_state -> List.iter cancel ps; - to_public_promise {state = result} + to_public_promise {state = error_state} | Pending _ -> collect_already_fulfilled_promises_or_find_rejected acc ps' @@ -2819,12 +2799,12 @@ struct | p::ps' -> let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled v -> + | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected [v] ps' - | Rejected _ as result -> + | Resolved (Error _) as error_state -> List.iter cancel ps; - to_public_promise {state = result} + to_public_promise {state = error_state} | Pending _ -> check_for_already_resolved_promises ps' @@ -2850,15 +2830,15 @@ struct match ps with | [] -> resolve ~allow_deferring:false to_resolve - (Fulfilled (List.rev fulfilled, List.rev pending)) + (Ok (List.rev fulfilled, List.rev pending)) | p::ps -> let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with - | Fulfilled v -> + | Resolved (Ok v) -> finish to_resolve (v::fulfilled) pending ps - | Rejected _ as result -> + | Resolved (Error _ as result) -> resolve ~allow_deferring:false to_resolve result | Pending _ -> @@ -2875,11 +2855,11 @@ struct | p::ps -> let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with - | Fulfilled v -> + | Resolved (Ok v) -> collect_already_resolved_promises (v::results) pending ps - | Rejected _ as result -> - to_public_promise {state = result} + | Resolved (Error _) as error_state -> + to_public_promise {state = error_state} | Pending _ -> collect_already_resolved_promises results (p::pending) ps @@ -2903,11 +2883,11 @@ struct | p::ps' -> let Internal p_internal = to_internal_promise p in match (underlying p_internal).state with - | Fulfilled v -> + | Resolved (Ok v) -> collect_already_resolved_promises [v] pending_acc ps' - | Rejected _ as result -> - to_public_promise {state = result} + | Resolved (Error _) as error_state -> + to_public_promise {state = error_state} | Pending _ -> check_for_already_resolved_promises (p::pending_acc) ps' @@ -2981,8 +2961,8 @@ struct let state p = let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled v -> Return v - | Rejected exn -> Fail exn + | Resolved (Ok v) -> Return v + | Resolved (Error exn) -> Fail exn | Pending _ -> Sleep let debug_state_is expected_state p = @@ -2991,15 +2971,14 @@ struct let is_sleeping p = let Internal p = to_internal_promise p in match (underlying p).state with - | Fulfilled _ -> false - | Rejected _ -> false + | Resolved _ -> false | Pending _ -> true let poll p = let Internal p = to_internal_promise p in match (underlying p).state with - | Rejected e -> reraise e - | Fulfilled v -> Some v + | Resolved (Error e) -> reraise e + | Resolved (Ok v) -> Some v | Pending _ -> None From 79ce02acb8a5d786768bd70010fa0d075fb82dcc Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Thu, 16 Oct 2025 08:50:15 +0200 Subject: [PATCH 4/5] remove the (unsound) static disipline on promise states The static discipline on promise states requires an `Obj.magic` in promise state update. This appears to work correctly under OCaml 4, but is known to cause segfaults under concurrent usage with OCaml 5. --- src/core/lwt.ml | 322 ++++++++++++++++++++++++------------------------ 1 file changed, 161 insertions(+), 161 deletions(-) diff --git a/src/core/lwt.ml b/src/core/lwt.ml index 7c1da643e..a33bb9e53 100644 --- a/src/core/lwt.ml +++ b/src/core/lwt.ml @@ -375,56 +375,39 @@ struct [@@@ocaml.warning "-37"] - type underlying = private Underlying_and_this_constructor_is_not_used - type proxy = private Proxy_and_this_constructor_is_not_used - - type resolved = private Resolved_and_this_constructor_is_not_used - type pending = private Pending_and_this_constructor_is_not_used + type direct = private Direct_and_this_constructor_is_not_used + type indirect = private Indirect_and_this_constructor_is_not_used [@@@ocaml.warning "+37"] - + let failwith_not_pending () = + failwith "Lwt internal error: a 'pending' state was expected" (* Promises proper. *) - type ('a, 'u, 'c) promise = { - mutable state : ('a, 'u, 'c) state; + type 'a promise = { + mutable state : ('a, indirect) state; } - and (_, _, _) state = - | Resolved : 'a resolved_state -> ('a, underlying, resolved) state - | Pending : 'a callbacks -> ('a, underlying, pending) state - | Proxy : ('a, _, 'c) promise -> ('a, proxy, 'c) state + and (_, _) state = + | Resolved : 'a resolved_state -> ('a, 'd) state + | Pending : 'a callbacks -> ('a, 'd) state + | Proxy : 'a promise -> ('a, indirect) state (* Note: - A promise whose state is [Proxy _] is a "proxy" promise. A promise whose - state is *not* [Proxy _] is an "underlying" promise. + A promise whose state may be [Proxy _] is an "indirect" promise. A promise whose + state may *not* be [Proxy _] is a "direct" promise. - The "underlying promise of [p]" is: + The "underlying promise of [p]" is the following direct promise: - - [p], if [p] is itself underlying. + - [p], if [p] is itself direct. - Otherwise, [p] is a proxy and has state [Proxy p']. The underlying promise of [p] is the underlying promise of [p']. In other words, to find the underlying promise of a proxy, Lwt follows the [Proxy _] links to the end. *) - (* Note: - - When a promise is resolved, or becomes a proxy, its state field is - mutated. This invalidates the type invariants on the promise. See internal - function [set_promise_state] for details about that. - - When an Lwt function has a reference to a promise, and also registers a - callback that has a reference to the same promise, the invariants on the - reference may become invalid by the time the callback is called. All such - callbacks have comments explaining what the valid invariants are at that - point, and/or casts to (1) get the correct typing and (2) document the - potential state change for readers of the code. *) - - - (* Callback information for pending promises. *) and 'a callbacks = { @@ -443,8 +426,8 @@ struct and how_to_cancel = | Not_cancelable : how_to_cancel | Cancel_this_promise : how_to_cancel - | Propagate_cancel_to_one : (_, _, _) promise -> how_to_cancel - | Propagate_cancel_to_several : (_, _, _) promise list -> how_to_cancel + | Propagate_cancel_to_one : _ promise -> how_to_cancel + | Propagate_cancel_to_several : _ promise list -> how_to_cancel and 'a regular_callback_list = | Regular_callback_list_empty @@ -465,11 +448,12 @@ struct storage * cancel_callback -> _ cancel_callback_list | Cancel_callback_list_remove_sequence_node : - ('a, _, _) promise Lwt_sequence.node -> + 'a promise Lwt_sequence.node -> 'a cancel_callback_list - let[@inline] get_pending : ('a, underlying, pending) state -> 'a callbacks = function + let[@inline] get_pending : ('a, 'd) state -> 'a callbacks = function | Pending callbacks -> callbacks + | _ -> failwith_not_pending () (* Notes: @@ -533,11 +517,11 @@ struct type +'a t type -'a u - let to_public_promise : ('a, _, _) promise -> 'a t = Obj.magic - let to_public_resolver : ('a, _, _) promise -> 'a u = Obj.magic + let to_public_promise : 'a promise -> 'a t = Obj.magic + let to_public_resolver : 'a promise -> 'a u = Obj.magic - type _ packed_promise = - | Internal : ('a, _, _) promise -> 'a packed_promise + type _ packed_promise = (* TODO erase this now-unnecessary abstraction *) + | Internal : 'a promise -> 'a packed_promise [@@ocaml.unboxed] let to_internal_promise (p : 'a t) : 'a packed_promise = @@ -566,21 +550,24 @@ include Public_types module Basic_helpers : sig - val identical : ('a, _, _) promise -> ('a, _, _) promise -> bool - val underlying : ('a, 'u, 'c) promise -> ('a, underlying, 'c) promise + val identical : 'a promise -> 'a promise -> bool + val underlying : 'a promise -> ('a, direct) state * 'a promise + + val underlying_promise : 'a promise -> 'a promise + val underlying_state : 'a promise -> ('a, direct) state - type ('a, 'u, 'c) state_changed = - | State_may_have_changed of ('a, 'u, 'c) promise + type 'a state_changed = + | State_may_have_changed of 'a promise [@@ocaml.unboxed] val set_promise_state : - ('a, _, _) promise -> ('a, 'u, 'c) state -> ('a, 'u, 'c) state_changed + 'a promise -> ('a, indirect) state -> 'a state_changed type 'a may_now_be_proxy = | State_may_now_be_pending_proxy : - ('a, _, pending) promise -> 'a may_now_be_proxy + 'a promise -> 'a may_now_be_proxy [@@ocaml.unboxed] val may_now_be_proxy : - ('a, underlying, pending) promise -> 'a may_now_be_proxy + 'a promise -> 'a may_now_be_proxy end = struct (* Checks physical equality ([==]) of two internal promises. Unlike [==], does @@ -592,27 +579,43 @@ struct If multiple [Proxy _] links are traversed, [underlying] updates all the proxies to point immediately to their final underlying promise. *) - let rec underlying - : type u c. ('a, u, c) promise -> ('a, underlying, c) promise = - fun p -> - - match p.state with - | Resolved _ -> (p : (_, underlying, _) promise) - | Pending _ -> p - | Proxy p' -> - let p'' = underlying p' in - if not (identical p'' p') then - p.state <- Proxy p''; - p'' - - - - type ('a, 'u, 'c) state_changed = - | State_may_have_changed of ('a, 'u, 'c) promise + let underlying (p : 'a promise) : ('a, direct) state * 'a promise = + let rec loop ps p = + match p.state with + | (Resolved _ | Pending _) as direct -> + List.iter (fun prox -> prox.state <- Proxy p) ps; + direct, p + | Proxy p' -> + loop (p :: ps) p' + in loop [] p + + (* a specialized version that only returns the state *) + let underlying_state (p : 'a promise) : ('a, direct) state = + let rec loop ps p = + match p.state with + | (Resolved _ | Pending _) as direct -> + List.iter (fun prox -> prox.state <- Proxy p) ps; + direct + | Proxy p' -> + loop (p :: ps) p' + in loop [] p + + (* a specialized version that only returns the promise *) + let underlying_promise (p : 'a promise) : 'a promise = + let rec loop ps p = + match p.state with + | (Resolved _ | Pending _) -> + List.iter (fun prox -> prox.state <- Proxy p) ps; + p + | Proxy p' -> + loop (p :: ps) p' + in loop [] p + + type 'a state_changed = + | State_may_have_changed of 'a promise [@@ocaml.unboxed] let set_promise_state p state = - let p : (_, _, _) promise = Obj.magic p in p.state <- state; State_may_have_changed p @@ -647,7 +650,7 @@ struct type 'a may_now_be_proxy = | State_may_now_be_pending_proxy : - ('a, _, pending) promise -> 'a may_now_be_proxy + 'a promise -> 'a may_now_be_proxy [@@ocaml.unboxed] let may_now_be_proxy p = State_may_now_be_pending_proxy p @@ -874,7 +877,7 @@ struct defer a cleanup, or actually clean up their callback lists. *) ps |> List.iter (fun p -> let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with (* Some of the promises may already have been resolved at the time this function is called. *) | Resolved _ -> () @@ -964,7 +967,7 @@ struct let node = Regular_callback_list_explicitly_removable_callback cell in ps |> List.iter (fun p -> let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Pending callbacks -> add_regular_callback_list_node callbacks node | Resolved _ -> assert false ); @@ -1008,9 +1011,9 @@ sig val resolve : ?allow_deferring:bool -> ?maximum_callback_nesting_depth:int -> - ('a, underlying, pending) promise -> + 'a promise -> 'a resolved_state -> - ('a, underlying, resolved) state_changed + 'a state_changed val run_callbacks_or_defer_them : ?allow_deferring:bool -> @@ -1310,9 +1313,9 @@ struct therefore be possible to cause a stack overflow using this function. *) let wakeup_general api_function_name r result = let Internal p = to_internal_resolver r in - let p = underlying p in + let state, p = underlying p in - match p.state with + match state with | Resolved result -> begin match result with | Error Canceled -> () @@ -1332,9 +1335,9 @@ struct let wakeup_later_general api_function_name r result = let Internal p = to_internal_resolver r in - let p = underlying p in + let state, p = underlying p in - match p.state with + match state with | Resolved result -> begin match result with | Error Canceled -> () @@ -1379,15 +1382,15 @@ struct The callbacks of these initial promises are then run, in a separate phase. These callbacks propagate cancellation forwards to any dependent promises. See "Cancellation" in the Overview. *) - let propagate_cancel : (_, _, _) promise -> packed_callbacks list = + let propagate_cancel : _ promise -> packed_callbacks list = fun p -> let rec cancel_and_collect_callbacks : - 'a 'u 'c. packed_callbacks list -> ('a, 'u, 'c) promise -> + 'a . packed_callbacks list -> 'a promise -> packed_callbacks list = - fun (type c) callbacks_accumulator (p : (_, _, c) promise) -> + fun callbacks_accumulator (p : _ promise) -> - let p = underlying p in - match p.state with + let state, p = underlying p in + match state with (* If the promise is not still pending, it can't be canceled. *) | Resolved _ -> callbacks_accumulator @@ -1470,8 +1473,7 @@ include Trivial_promises module Pending_promises : sig (* Internal *) - val new_pending : - how_to_cancel:how_to_cancel -> ('a, underlying, pending) promise + val new_pending : how_to_cancel:how_to_cancel -> 'a promise val propagate_cancel_to_several : _ t list -> how_to_cancel (* Initial pending promises (public) *) @@ -1501,7 +1503,7 @@ struct with the invariants, because [Propagate_cancel_to_several] packs them, and code that matches on [Propagate_cancel_to_several] doesn't care about them anyway. *) - let cast_promise_list : 'a t list -> ('a, _, _) promise list = Obj.magic in + let cast_promise_list : 'a t list -> 'a promise list = Obj.magic in Propagate_cancel_to_several (cast_promise_list ps) @@ -1519,8 +1521,8 @@ struct let cast_sequence_node (node : 'a u Lwt_sequence.node) - (_actual_content:('a, 'u, 'c) promise) - : ('a, 'u, 'c) promise Lwt_sequence.node = + (_actual_content:'a promise) + : 'a promise Lwt_sequence.node = Obj.magic node let add_task_r sequence = @@ -1549,7 +1551,7 @@ struct let protected p = let Internal p_internal = to_internal_promise p in - match (underlying p_internal).state with + match underlying_state p_internal with | Resolved _ -> p | Pending _ -> @@ -1557,7 +1559,7 @@ struct let callback p_result = let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in - let p' = underlying p' in + let p' = underlying_promise p' in (* In this callback, [p'] will either still itself be pending, or it will have become a proxy for a pending promise. The reasoning for this is almost the same as in the comment at [may_now_be_proxy]. The @@ -1589,7 +1591,7 @@ struct let no_cancel p = let Internal p_internal = to_internal_promise p in - match (underlying p_internal).state with + match underlying_state p_internal with | Resolved _ -> p | Pending p_callbacks -> @@ -1597,7 +1599,7 @@ struct let callback p_result = let State_may_now_be_pending_proxy p' = may_now_be_proxy p' in - let p' = underlying p' in + let p' = underlying_promise p' in (* In this callback, [p'] will either still itself be pending, or it will have become a proxy for a pending promise. The reasoning for this is as in [protected] and [may_now_be_proxy], but even simpler, @@ -1703,14 +1705,13 @@ struct but [~outer_promise] still pending, depending on the order in which callbacks are run. *) let make_into_proxy - (type c) - ~(outer_promise : ('a, underlying, pending) promise) - ~(user_provided_promise : ('a, _, c) promise) - : ('a, underlying, c) state_changed = + ~(outer_promise : 'a promise) + ~(user_provided_promise : 'a promise) + : 'a state_changed = (* Using [p'] as it's the name used inside [bind], etc., for promises with this role -- [p'] is the promise returned by the user's function. *) - let p' = underlying user_provided_promise in + let state, p' = underlying user_provided_promise in if identical p' outer_promise then State_may_have_changed p' @@ -1718,7 +1719,7 @@ struct the reference through [p'] has the right type. *) else - match p'.state with + match state with | Resolved result -> resolve ~allow_deferring:false outer_promise result @@ -1750,7 +1751,7 @@ struct let bind p f = let Internal p = to_internal_promise p in - let p = underlying p in + let state, p = underlying p in (* In case [Lwt.bind] needs to defer the call to [f], this function will be called to create: @@ -1796,7 +1797,7 @@ struct (* Run the user's function [f]. *) let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in (* [p''] was an underlying promise when it was created above, but it may have become a proxy by the time this code is being executed. However, it is still either an underlying pending promise, or a @@ -1812,7 +1813,7 @@ struct | Error _ as p_result -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let _state, p'' = underlying p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p_result in @@ -1822,7 +1823,7 @@ struct (to_public_promise p'', callback) in - match p.state with + match state with | Resolved (Ok v) -> run_callback f v @@ -1836,7 +1837,7 @@ struct let backtrace_bind add_loc p f = let Internal p = to_internal_promise p in - let p = underlying p in + let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in @@ -1855,7 +1856,7 @@ struct let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let _state, p'' = underlying p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in @@ -1863,7 +1864,7 @@ struct | Error exn -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' (Error (add_loc exn)) in @@ -1873,7 +1874,7 @@ struct (to_public_promise p'', callback) in - match p.state with + match state with | Resolved (Ok v) -> run_callback f v @@ -1887,7 +1888,7 @@ struct let map f p = let Internal p = to_internal_promise p in - let p = underlying p in + let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in @@ -1905,7 +1906,7 @@ struct in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p''_result in @@ -1913,7 +1914,7 @@ struct | Error _ as p''_result -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p''_result in @@ -1923,7 +1924,7 @@ struct (to_public_promise p'', callback) in - match p.state with + match state with | Resolved (Ok v) -> run_callback (fun () -> @@ -1949,7 +1950,7 @@ struct with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in - let p = underlying p in + let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in @@ -1960,7 +1961,7 @@ struct match p_result with | Ok _ -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p_result in @@ -1976,7 +1977,7 @@ struct let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in @@ -1986,7 +1987,7 @@ struct (to_public_promise p'', callback) in - match p.state with + match state with | Resolved (Ok _) -> to_public_promise p @@ -2004,7 +2005,7 @@ struct with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in - let p = underlying p in + let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in @@ -2015,7 +2016,7 @@ struct match p_result with | Ok _ -> let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = resolve ~allow_deferring:false p'' p_result in @@ -2032,7 +2033,7 @@ struct let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in @@ -2042,7 +2043,7 @@ struct (to_public_promise p'', callback) in - match p.state with + match state with | Resolved (Ok _) -> to_public_promise p @@ -2060,7 +2061,7 @@ struct with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in - let p = underlying p in + let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in @@ -2079,7 +2080,7 @@ struct let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in @@ -2095,7 +2096,7 @@ struct let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in @@ -2105,7 +2106,7 @@ struct (to_public_promise p'', callback) in - match p.state with + match state with | Resolved (Ok v) -> run_callback f' v @@ -2123,7 +2124,7 @@ struct with exn when Exception_filter.run exn -> fail exn in let Internal p = to_internal_promise p in - let p = underlying p in + let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = let p'' = new_pending ~how_to_cancel:(Propagate_cancel_to_one p) in @@ -2143,7 +2144,7 @@ struct let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in @@ -2160,7 +2161,7 @@ struct let Internal p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in - let p'' = underlying p'' in + let p'' = underlying_promise p'' in let State_may_have_changed p'' = make_into_proxy ~outer_promise:p'' ~user_provided_promise:p' in @@ -2170,7 +2171,7 @@ struct (to_public_promise p'', callback) in - match p.state with + match state with | Resolved (Ok v) -> run_callback f' v @@ -2196,9 +2197,9 @@ struct let on_cancel p f = let Internal p = to_internal_promise p in - let p = underlying p in + let state = underlying_state p in - match p.state with + match state with | Resolved (Error Canceled) -> run_callback (handle_with_async_exception_hook f) () @@ -2212,7 +2213,7 @@ struct let on_success p f = let Internal p = to_internal_promise p in - let p = underlying p in + let state = underlying_state p in let callback_if_deferred () = let saved_storage = !current_storage in @@ -2227,7 +2228,7 @@ struct () in - match p.state with + match state with | Resolved (Ok v) -> run_callback (handle_with_async_exception_hook f) v @@ -2240,7 +2241,7 @@ struct let on_failure p f = let Internal p = to_internal_promise p in - let p = underlying p in + let state = underlying_state p in let callback_if_deferred () = let saved_storage = !current_storage in @@ -2255,7 +2256,7 @@ struct handle_with_async_exception_hook f exn in - match p.state with + match state with | Resolved (Ok _) -> () @@ -2268,7 +2269,7 @@ struct let on_termination p f = let Internal p = to_internal_promise p in - let p = underlying p in + let state = underlying_state p in let callback_if_deferred () = let saved_storage = !current_storage in @@ -2278,7 +2279,7 @@ struct handle_with_async_exception_hook f () in - match p.state with + match state with | Resolved (Ok _) -> run_callback (handle_with_async_exception_hook f) () @@ -2291,7 +2292,7 @@ struct let on_any p f g = let Internal p = to_internal_promise p in - let p = underlying p in + let state = underlying_state p in let callback_if_deferred () = let saved_storage = !current_storage in @@ -2307,7 +2308,7 @@ struct handle_with_async_exception_hook g exn in - match p.state with + match state with | Resolved (Ok v) -> run_callback (handle_with_async_exception_hook f) v @@ -2325,8 +2326,7 @@ include Sequential_composition [Sequential_composition]. *) let wrap_in_cancelable p = let Internal p_internal = to_internal_promise p in - let p_underlying = underlying p_internal in - match p_underlying.state with + match underlying_state p_internal with | Resolved _ -> p | Pending _ -> let p', r = task () in @@ -2363,7 +2363,7 @@ struct in let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok _) -> () | Resolved (Error exn) -> @@ -2386,7 +2386,7 @@ struct in let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok _) -> () | Resolved (Error exn) -> @@ -2405,7 +2405,7 @@ struct let ignore_result p = let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok _) -> () | Resolved (Error exn) -> @@ -2448,9 +2448,9 @@ struct resolve the [join] once all promises resolve. *) number_pending_in_ps := !number_pending_in_ps - 1; if !number_pending_in_ps = 0 then begin - let p' = underlying p' in + let p' = underlying_promise p' in let State_may_have_changed p' = - resolve ~allow_deferring:false (underlying p') !join_result in + resolve ~allow_deferring:false p' !join_result in ignore p' end in @@ -2469,7 +2469,7 @@ struct | p::ps -> let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Pending p_callbacks -> number_pending_in_ps := !number_pending_in_ps + 1; add_implicitly_removed_callback p_callbacks callback; @@ -2541,7 +2541,7 @@ struct | [] -> Error (total, rejected) | p :: ps -> let Internal q = to_internal_promise p in - match (underlying q).state with + match underlying_state q with | Resolved (Ok _) -> count_and_gather_rejected total rejected ps | Resolved (Error _) -> count_and_gather_rejected (total + 1) (p :: rejected) ps | Pending _ -> count_and_gather_rejected total rejected ps @@ -2551,7 +2551,7 @@ struct | [] -> Ok total | p :: ps -> let Internal q = to_internal_promise p in - match (underlying q).state with + match underlying_state q with | Resolved (Ok _) -> count_fulfilled (total + 1) ps | Resolved (Error _) -> count_and_gather_rejected 1 [p] ps | Pending _ -> count_fulfilled total ps @@ -2568,7 +2568,7 @@ struct | p::ps -> let Internal p' = to_internal_promise p in - match (underlying p').state with + match underlying_state p' with | Pending _ -> nth_resolved ps n @@ -2588,7 +2588,7 @@ struct | p::ps -> let Internal p' = to_internal_promise p in - match (underlying p').state with + match underlying_state p' with | Pending _ -> cancel p; nth_resolved_and_cancel_pending ps n @@ -2615,7 +2615,7 @@ struct let callback result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in - let p = underlying p in + let p = underlying_promise p in let State_may_have_changed p = resolve ~allow_deferring:false p result in ignore p @@ -2643,7 +2643,7 @@ struct let callback result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in List.iter cancel ps; - let p = underlying p in + let p = underlying_promise p in let State_may_have_changed p = resolve ~allow_deferring:false p result in ignore p @@ -2683,7 +2683,7 @@ struct | p::ps -> let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok v) -> collect_fulfilled_promises_after_pending (v::results) ps @@ -2706,7 +2706,7 @@ struct | p::ps -> let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected (v::acc) ps @@ -2727,7 +2727,7 @@ struct let callback _result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in - let p = underlying p in + let p = underlying_promise p in let result = collect_fulfilled_promises_after_pending [] ps in let State_may_have_changed p = resolve ~allow_deferring:false p result in @@ -2739,7 +2739,7 @@ struct | p::ps -> let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected [v] ps @@ -2766,7 +2766,7 @@ struct | p::ps' -> let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected (v::acc) ps' @@ -2785,7 +2785,7 @@ struct let callback _result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in - let p = underlying p in + let p = underlying_promise p in let result = collect_fulfilled_promises_after_pending [] ps in List.iter cancel ps; let State_may_have_changed p = @@ -2798,7 +2798,7 @@ struct | p::ps' -> let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected [v] ps' @@ -2821,11 +2821,11 @@ struct invalid_arg "Lwt.nchoose_split [] would return a promise that is pending forever"; let rec finish - (to_resolve : ('a list * 'a t list, underlying, pending) promise) + (to_resolve : ('a list * 'a t list) promise) (fulfilled : 'a list) (pending : 'a t list) (ps : 'a t list) - : ('a list * 'a t list, underlying, resolved) state_changed = + : ('a list * 'a t list) state_changed = match ps with | [] -> @@ -2834,7 +2834,7 @@ struct | p::ps -> let Internal p_internal = to_internal_promise p in - match (underlying p_internal).state with + match underlying_state p_internal with | Resolved (Ok v) -> finish to_resolve (v::fulfilled) pending ps @@ -2854,7 +2854,7 @@ struct | p::ps -> let Internal p_internal = to_internal_promise p in - match (underlying p_internal).state with + match underlying_state p_internal with | Resolved (Ok v) -> collect_already_resolved_promises (v::results) pending ps @@ -2872,7 +2872,7 @@ struct let callback _result = let State_may_now_be_pending_proxy p = may_now_be_proxy p in - let p = underlying p in + let p = underlying_promise p in let State_may_have_changed p = finish p [] [] ps in ignore p in @@ -2882,7 +2882,7 @@ struct | p::ps' -> let Internal p_internal = to_internal_promise p in - match (underlying p_internal).state with + match underlying_state p_internal with | Resolved (Ok v) -> collect_already_resolved_promises [v] pending_acc ps' @@ -2960,7 +2960,7 @@ struct let state p = let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Ok v) -> Return v | Resolved (Error exn) -> Fail exn | Pending _ -> Sleep @@ -2970,13 +2970,13 @@ struct let is_sleeping p = let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved _ -> false | Pending _ -> true let poll p = let Internal p = to_internal_promise p in - match (underlying p).state with + match underlying_state p with | Resolved (Error e) -> reraise e | Resolved (Ok v) -> Some v | Pending _ -> None From 044773b9cb4cba808b6bb93b9da9d9dd09e240be Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Thu, 16 Oct 2025 09:37:17 +0200 Subject: [PATCH 5/5] minor: drop the now-useless [packed_promise] type --- src/core/lwt.ml | 119 ++++++++++++++++++++---------------------------- 1 file changed, 49 insertions(+), 70 deletions(-) diff --git a/src/core/lwt.ml b/src/core/lwt.ml index a33bb9e53..e766d7090 100644 --- a/src/core/lwt.ml +++ b/src/core/lwt.ml @@ -520,29 +520,8 @@ struct let to_public_promise : 'a promise -> 'a t = Obj.magic let to_public_resolver : 'a promise -> 'a u = Obj.magic - type _ packed_promise = (* TODO erase this now-unnecessary abstraction *) - | Internal : 'a promise -> 'a packed_promise - [@@ocaml.unboxed] - - let to_internal_promise (p : 'a t) : 'a packed_promise = - Internal (Obj.magic p) - let to_internal_resolver (r : 'a u) : 'a packed_promise = - Internal (Obj.magic r) - - (* Most functions that take a public promise (['a t]) convert it to an - internal promise as follows: - - (* p : 'a t *) - - let Internal p = to_internal_promise p in - - (* p : ('a, u, c) promise, where u and c are fresh types, i.e. the - invariants on p are unknown. *) - - This cast is a no-op cast. It only produces a reference with a different - type. The introduction and immediate elimination of [Internal _] seems to - be optimized away even on older versions of OCaml that don't have Flambda - and don't support [[@@ocaml.unboxed]]. *) + let to_internal_promise : 'a t -> 'a promise = Obj.magic + let to_internal_resolver : 'a u -> 'a promise = Obj.magic end include Public_types @@ -876,7 +855,7 @@ struct (* Go through the promises the cell had originally been added to, and either defer a cleanup, or actually clean up their callback lists. *) ps |> List.iter (fun p -> - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with (* Some of the promises may already have been resolved at the time this function is called. *) @@ -966,7 +945,7 @@ struct let node = Regular_callback_list_explicitly_removable_callback cell in ps |> List.iter (fun p -> - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Pending callbacks -> add_regular_callback_list_node callbacks node | Resolved _ -> assert false @@ -1312,7 +1291,7 @@ struct behavior: it runs callbacks directly on the current stack. It should therefore be possible to cause a stack overflow using this function. *) let wakeup_general api_function_name r result = - let Internal p = to_internal_resolver r in + let p = to_internal_resolver r in let state, p = underlying p in match state with @@ -1334,7 +1313,7 @@ struct let wakeup_exn r exn = wakeup_general "wakeup_exn" r (Error exn) let wakeup_later_general api_function_name r result = - let Internal p = to_internal_resolver r in + let p = to_internal_resolver r in let state, p = underlying p in match state with @@ -1412,7 +1391,7 @@ struct cancel_and_collect_callbacks [] p in - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let callbacks = propagate_cancel p in callbacks |> List.iter (fun (Packed callbacks) -> @@ -1550,7 +1529,7 @@ struct let protected p = - let Internal p_internal = to_internal_promise p in + let p_internal = to_internal_promise p in match underlying_state p_internal with | Resolved _ -> p @@ -1590,7 +1569,7 @@ struct to_public_promise p' let no_cancel p = - let Internal p_internal = to_internal_promise p in + let p_internal = to_internal_promise p in match underlying_state p_internal with | Resolved _ -> p @@ -1750,7 +1729,7 @@ struct some way, especially if assuming Flambda. *) let bind p f = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state, p = underlying p in (* In case [Lwt.bind] needs to defer the call to [f], this function will be @@ -1793,7 +1772,7 @@ struct try f v with exn when Exception_filter.run exn -> fail exn in - let Internal p' = to_internal_promise p' in + let p' = to_internal_promise p' in (* Run the user's function [f]. *) let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in @@ -1836,7 +1815,7 @@ struct p'' let backtrace_bind add_loc p f = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -1853,7 +1832,7 @@ struct try f v with exn when Exception_filter.run exn -> fail (add_loc exn) in - let Internal p' = to_internal_promise p' in + let p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let _state, p'' = underlying p'' in @@ -1887,7 +1866,7 @@ struct p'' let map f p = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -1949,7 +1928,7 @@ struct try f () with exn when Exception_filter.run exn -> fail exn in - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -1974,7 +1953,7 @@ struct try h exn with exn when Exception_filter.run exn -> fail exn in - let Internal p' = to_internal_promise p' in + let p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying_promise p'' in @@ -2004,7 +1983,7 @@ struct try f () with exn when Exception_filter.run exn -> fail exn in - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -2030,7 +2009,7 @@ struct with exn when Exception_filter.run exn -> fail (add_loc exn) in - let Internal p' = to_internal_promise p' in + let p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying_promise p'' in @@ -2060,7 +2039,7 @@ struct try f () with exn when Exception_filter.run exn -> fail exn in - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -2077,7 +2056,7 @@ struct try f' v with exn when Exception_filter.run exn -> fail exn in - let Internal p' = to_internal_promise p' in + let p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying_promise p'' in @@ -2093,7 +2072,7 @@ struct try h exn with exn when Exception_filter.run exn -> fail exn in - let Internal p' = to_internal_promise p' in + let p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying_promise p'' in @@ -2123,7 +2102,7 @@ struct try f () with exn when Exception_filter.run exn -> fail exn in - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state, p = underlying p in let create_result_promise_and_callback_if_deferred () = @@ -2141,7 +2120,7 @@ struct with exn when Exception_filter.run exn -> fail (add_loc exn) in - let Internal p' = to_internal_promise p' in + let p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying_promise p'' in @@ -2158,7 +2137,7 @@ struct with exn when Exception_filter.run exn -> fail (add_loc exn) in - let Internal p' = to_internal_promise p' in + let p' = to_internal_promise p' in let State_may_now_be_pending_proxy p'' = may_now_be_proxy p'' in let p'' = underlying_promise p'' in @@ -2196,7 +2175,7 @@ struct let on_cancel p f = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state = underlying_state p in match state with @@ -2212,7 +2191,7 @@ struct let on_success p f = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state = underlying_state p in let callback_if_deferred () = @@ -2240,7 +2219,7 @@ struct add_implicitly_removed_callback p_callbacks callback let on_failure p f = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state = underlying_state p in let callback_if_deferred () = @@ -2268,7 +2247,7 @@ struct add_implicitly_removed_callback p_callbacks callback let on_termination p f = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state = underlying_state p in let callback_if_deferred () = @@ -2291,7 +2270,7 @@ struct add_implicitly_removed_callback p_callbacks callback let on_any p f g = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in let state = underlying_state p in let callback_if_deferred () = @@ -2325,7 +2304,7 @@ include Sequential_composition (* This belongs with the [protected] and such, but it depends on primitives from [Sequential_composition]. *) let wrap_in_cancelable p = - let Internal p_internal = to_internal_promise p in + let p_internal = to_internal_promise p in match underlying_state p_internal with | Resolved _ -> p | Pending _ -> @@ -2361,7 +2340,7 @@ struct try f () with exn when Exception_filter.run exn -> fail exn in - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok _) -> @@ -2384,7 +2363,7 @@ struct try f () with exn when Exception_filter.run exn -> fail exn in - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok _) -> @@ -2403,7 +2382,7 @@ struct add_implicitly_removed_callback p_callbacks callback let ignore_result p = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok _) -> @@ -2467,7 +2446,7 @@ struct to_public_promise p' | p::ps -> - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Pending p_callbacks -> @@ -2540,7 +2519,7 @@ struct match ps with | [] -> Error (total, rejected) | p :: ps -> - let Internal q = to_internal_promise p in + let q = to_internal_promise p in match underlying_state q with | Resolved (Ok _) -> count_and_gather_rejected total rejected ps | Resolved (Error _) -> count_and_gather_rejected (total + 1) (p :: rejected) ps @@ -2550,7 +2529,7 @@ struct match ps with | [] -> Ok total | p :: ps -> - let Internal q = to_internal_promise p in + let q = to_internal_promise p in match underlying_state q with | Resolved (Ok _) -> count_fulfilled (total + 1) ps | Resolved (Error _) -> count_and_gather_rejected 1 [p] ps @@ -2567,7 +2546,7 @@ struct assert false | p::ps -> - let Internal p' = to_internal_promise p in + let p' = to_internal_promise p in match underlying_state p' with | Pending _ -> nth_resolved ps n @@ -2587,7 +2566,7 @@ struct assert false | p::ps -> - let Internal p' = to_internal_promise p in + let p' = to_internal_promise p in match underlying_state p' with | Pending _ -> cancel p; @@ -2681,7 +2660,7 @@ struct Ok (List.rev results) | p::ps -> - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok v) -> @@ -2705,7 +2684,7 @@ struct return (List.rev acc) | p::ps -> - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected (v::acc) ps @@ -2738,7 +2717,7 @@ struct to_public_promise p | p::ps -> - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected [v] ps @@ -2765,7 +2744,7 @@ struct return (List.rev acc) | p::ps' -> - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected (v::acc) ps' @@ -2797,7 +2776,7 @@ struct to_public_promise p | p::ps' -> - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok v) -> collect_already_fulfilled_promises_or_find_rejected [v] ps' @@ -2833,7 +2812,7 @@ struct (Ok (List.rev fulfilled, List.rev pending)) | p::ps -> - let Internal p_internal = to_internal_promise p in + let p_internal = to_internal_promise p in match underlying_state p_internal with | Resolved (Ok v) -> finish to_resolve (v::fulfilled) pending ps @@ -2853,7 +2832,7 @@ struct return (List.rev results, pending) | p::ps -> - let Internal p_internal = to_internal_promise p in + let p_internal = to_internal_promise p in match underlying_state p_internal with | Resolved (Ok v) -> collect_already_resolved_promises (v::results) pending ps @@ -2881,7 +2860,7 @@ struct to_public_promise p | p::ps' -> - let Internal p_internal = to_internal_promise p in + let p_internal = to_internal_promise p in match underlying_state p_internal with | Resolved (Ok v) -> collect_already_resolved_promises [v] pending_acc ps' @@ -2959,7 +2938,7 @@ struct external reraise : exn -> 'a = "%reraise" let state p = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Ok v) -> Return v | Resolved (Error exn) -> Fail exn @@ -2969,13 +2948,13 @@ struct return (state p = expected_state) let is_sleeping p = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved _ -> false | Pending _ -> true let poll p = - let Internal p = to_internal_promise p in + let p = to_internal_promise p in match underlying_state p with | Resolved (Error e) -> reraise e | Resolved (Ok v) -> Some v