pax_global_header00006660000000000000000000000064142027330520014510gustar00rootroot0000000000000052 comment=3706942bed7a2d0ae7d1c003977546d165d3263b async_unix-0.15.0/000077500000000000000000000000001420273305200137535ustar00rootroot00000000000000async_unix-0.15.0/.gitignore000066400000000000000000000000411420273305200157360ustar00rootroot00000000000000_build *.install *.merlin _opam async_unix-0.15.0/CHANGES.md000066400000000000000000001255371420273305200153620ustar00rootroot00000000000000## 113.43.00 - Switched if-then-else style from: if test then begin E1; E2; end else begin E3; E4; end to: if test then ( E1; E2) else ( E3; E4); This style puts keywords at the start of lines and closing delimiters at the end. And makes it lighter-weight to be more consistent about using the delimiters. - Switched `Async_unix` from `>>=` and `>>|` to `let%bind` and `let%map`, where appropriate. - Fixed a race in `Thread_safe.block_on_async` that allowed Async code to run without the scheduler starting. There is important initialization that happens when the scheduler starts, like handling SIGPIPE. - Added `Scheduler.make_async_unusable`. - Fixed a bug in `Thread_safe.block_on_async_exn`. The bug was that the execution context wasn't restored to the main execution context in the main thread after returning from the call to `Thread_safe.block_on_async`. This leads to main-thread code running in some random execution context. If that code then raises, all hell can break loose due to exceptions being sent to random monitors. - Make the Check_buffer_age edge-triggered; the exception is send to the writer's monitor only when the state changes from not-backed-up to backed-up. - Currently whether `phys_equal Writer.stdout Writer.stderr` when running inline tests depends on a few factors: - whether the test is run by jenga or from the terminal - when was Writer.{stdout,stderr} first forced: inside a test or not This makes tests flaky and is confusing for users. This feature makes sure that we always have the equality of writers when running inline tests. - Changed `Async.Process.collect_output_and_wait` to *not* force close on the process' stdin. Maybe the process is just slow to consume its input. An external process working for 5s is not uncommon or unreasonable at all and should be allowed. - Added convenience functions for reading and writing bin_prot via Reader/Writer: Writer.save_bin_prot Reader.load_bin_prot Reader.load_bin_prot_exn - Fixed a bug in Async's `Shutdown.shutdown`, which did not run at-shutdown handlers in a try-with, and behaved badly (did not shutdown) if an at-shutdown handler raised. - Moves the `Time_source` unit tests from `async_unix/src/time_source_tests.ml` to `async/test/test_time_source.ml` converting them to expect tests. - Make `write_gen` fail "gracefully" when `~length` or `~blit_to_bigstring` raise. - Make `write_gen` fail "gracefully" when `~length` or `~blit_to_bigstring` raise. - Fix a problem with `Writer.write_gen`. Context: The `write_gen` function creates generic writing functions based on a `blit_to_bigstring` function. The blit function writes arbitrary portions of the input's binary representation into a bigstring. Problem: The current documentation claims that "If it is difficult to write only part of a value, one can choose to not support `?pos` and `?len`." However, even if `~pos` and `~len` are never supplied, the implementation may choose to split the given value between two write buffers, thus requiring the user of `write_gen` to provide a blit function that writes only part of a value. Solution: Add a function `write_gen_whole` that never splits a value, at the cost of potentially wasting write buffer space. Correct the documentation to refer users to the new function, instead of the suggestion "to not support `?pos` and `?len`." - Reordered labeled arguments in some `Writer` code. - We occasionally need to pass stdin to a process, and right now it's verbose to do because all of a sudden you can't use `run_lines_exn` and friends. Passing all of stdin upfront is oftentimes enough. - writer0 allocates a large chunk of memory at top level as a buffer for `write_sexp_internal`. Make this lazy for callers that don't writer sexps, and reduce the initial size of the buffer. - Added module `Async.Std.Require_explicit_time_source`, so that one can require code to be explicit about what time source is used and not unintentionally use the wall clock. The idiom is to do: open! Require_explicit_time_source or, in an import.ml: include Require_explicit_time_source ## 113.33.00 - expose a function to get the number of jobs that async has run since Scheduler.go - In `Log` change `sexp` to be immediate rather than lazy. This changes the behavior the `sexp` function. I've gone through the entire tree rewriting `sexp` to `create_s`, attempting to follow these guidelines: - If the logging is clearly intended to always happen (error logging, transaction log logging, etc.) I translated the call unguarded. - If the logging was already guarded with an if statetment I translated the call unguarded. - Otherwise, I added a call to `Log.would_log` as a guarding if. This duplicates the behavior of `sexp`, which would avoid the sexp conversion if the log message was never going to be logged. - `Writer.with_file_atomic` checks if destination file exists and then stats it to get existing permissions. File can go away before the call to stat, which would make the `with_file_atomic` to error out, which seems harsh. I think it is better to continue on in this case. Besides, `Async.file_exists` is essentially just another stat, so we might as well just do the stat without checking whether file exists or not. - Moved various `let%test`'s in `Async_unix` library into their own module. I'd like the `let%test`'s to be in files that depend on `Std`, so that they can pick up a top-level side effect that `Std` does, specifically the assignment of `Monitor.try_with_log_exn`. The child feature of this feature makes the change to do that assignment. - Changed the `Async_unix` library's assignment of `Monitor.try_with_log_exn` to be a top-level side effect that happens if `Async_unix.Std` is used. This fixes a bug in which `Thread_safe.block_on_async` (and other bits of `Async_unix`) failed to to do the assignment. The assignment was part of `Scheduler.go`, which isn't called by `Thread_safe.block_on_async`. This in turn cause programs that use `Thread_safe.block_on_async` and do not use `Scheduler.go`, like inline tests, to raise if they needed to report an exception raised to `Monitor.try_with` that already returned. - Deprecate the (blocking) `Sexp.save_*` functions in `Async_unix.Std`. Please do not switch from `Sexp.save*` to `Writer.save_sexp*` in this feature -- this feature is just for the deprecation. You can do the switch in a subfeature or later feature. A note aboute `Core_extended.Sexp` ---------------------------------- This feature causes surprising behavior in `Core_extended.Sexp`, where opening `Async.Std` undoes any previous open of `Core_extended.Std`: open Core.Std open Core_extended.Std type t = int Sexp.Comprehension.t `@@deriving sexp` open Async.Std type u = int Sexp.Comprehension.t `@@deriving sexp` The type `t` is fine but `u` fails to compile because at that point the module Sexp has no submodule Comprehension. But we already have the same problem with module `Unix` if you open `Async.Std` after `Core_extended.Std`, so I left the `Sexp` module as is. - Added `Async.Unix.Stats.compare`. - Changed Async's logging of exceptions raised to a `Monitor.try_with` that already returned to use `Log.Global.sexp` rather than `Log.global.error`. For logs that use single-line sexps, that makes them much nicer. - Added to `Async.Scheduler` `Time_ns` analogs of `cycle_start` and `cycle_times`: val cycle_start_ns : unit -> Time_ns.t val cycle_times_ns : unit -> Time_ns.Span.t Stream.t - I'm tired of having to write `>>| ok_exn` after most calls to Process, let's just make Process provide these functions directly. Also you can't write `>>| ok_exn` nicely anyway when using the let%bind and friends. - Added a test demonstrating that `Async.Process.create` returns `Ok` when `exec` fails. And updated the `create`'s documentation. ## 113.24.00 - In the periodic check for a Writer buffer have too old data, eliminated allocation and generally improved performance. This eliminated a large source of allocation in a simple TCP pingpong benchmark `bench/pingpong`. - Removed allocation in the Async scheduler's code that detects the thread-pool being stuck. This involved switching it to use `Time_ns` rather than `Time`. This eliminates a relatively large source of allocation in a simple TCP-pingpong benchmark `bench/pingpong`. - Switched to ppx. - Improved the Async scheduler's to allocate a `handle_fired` function once, rather than every time it calls `advance_clock`. - Added `Fd_by_descr.find_exn`, to avoid the option allocated by `Fd_by_descr.find`. Used it to reduce allocation in the Async scheduler. - Improved `Reader.load_sexp*` functions to behave better when loading from a non files, e.g. a pipe. Previously, it produced an empty error message because it mistakenly attempted to read the sexp a second time in order to determine the error position. Now it produces a good error message, but without the (impossible to obtain) error position. - In `Async_unix.Syscall`, added a zero-allocation syscall interface, removing sources of allocation as observed when running a simple TCP pingpong benchmark (found in `bench/pingpong`). - Added val time_spent_waiting_for_io : unit -> Time_ns.Span.t to `Scheduler` which returns the amount of time that the Async scheduler has spent in calls to `epoll_wait` (or `select`) since the start of the program. - Changed `In_thread.Helper_thread.create` from: val create : ?priority:Priority.t -> ?name:string -> unit -> t Or_error.t to: val create : ?priority:Priority.t -> ?name:string -> unit -> t Deferred.t Kept around the prior function, renamed as `create_now`. Switching `create` to return a deferred allows it to, when there are no available threads, wait until one becomes available. This, in turn, avoids rare nondeterminstic failures in programs that make heavy use of the thread pool and create a helper thread, when the creation happens at just the wrong time, when no thread is available. Split out `Thread_safe_ivar` from the internals of `Thread_pool`, so that it can be used in other tests, and in particular in a new unified test added by this feature. - Make `Unix_syscalls.Stats` bin-io-able. - Fixed a bug in `Thread_safe.block_on_async*`, in which the execution context wasn't properly restored before returning. - Add a function in `Process` that expects empty output, mirroring `Shell.run`. - Added `Reader.read_one_iobuf_at_a_time`, which is like `read_one_chunk_at_a_time`, except that the user-supplied `handle_chunk` function receives its data in an `Iobuf.t`, and uses the `Iobuf` position to communicate how much data was consumed. This facilitates using reader in scenarios (such as with protogen) where `Iobuf`s are expected (and presently allocated around the bigstring at each call) and the calculation of consumed bytes from the `Iobuf` is duplicated in few places. - `Log.message` used to always logs the message, even if its log level was too low. This has been fixed. - Add writer functions to schedule an iobuf to be written out. - Add `Unix.Inet_addr.Stable`. - Alter `Async.Std.Socket.Address.Inet.Blocking_sexp` to expose the polymorphic variant functions, so that you can include it in a separate polymorphic variant type. Also, expose `Async.Std.Socket.Address.Inet.__t_of_sexp__` to give a deprecation message, instead of a message about the function not existing. - Fixed a bug in Async's `In_thread.Helper_thread`, which wasn't finalizing helper threads, due to a bug in `Thread_pool`, which wasn't finalizing helper threads. The fix was to move the finalization out of `Thread_pool`, where we don't care about it, to `In_thread.Helper_thread`, where we do. Added `Scheduler.max_num_threads : unit -> int`. - Make `Epoll_file_descr_watcher` trigger callbacks for error conditions such as closed pipes. Testing ------- Three new unit tests, all validating appropriate behavior in the case that a Unix pipe is opened, then the read end is closed after reading only part of the data sent by the write end. 1. A test in writer.ml verifying that `Writer.consumer_left` is triggered. Before the fix to `Epoll_file_descr_watcher`, `Writer.consumer_left` would never become determined in this case. 2. A test in fd.ml verifying that `Fd.ready_to` is triggered for the writing fd. Before the fix to `Epoll_file_descr_watcher`, `Fd.ready_to` would never become determined in this case. 3. A test in linux_ext.ml verifying that `Epoll.wait_timeout_after` is triggered. This test shows that epoll reports the ERR flag for the file descriptor in this case, and therefore that `Epoll_file_descr_watcher` needs to pay attention to the ERR flag. - Added to `Writer.write_sexp` an optional `?terminate_with` argument, that specifies how to terminate the string representation of the sexp. This also makes it clear that the default behavior, `~terminate_with:Space_if_needed`, might append a space to the sexp you are outputting if its representation is not enclosed in either () or "" . `Sexp.output_hum` an `Sexp.output_mach` do not have this behavior, so porting non-async code to async could introduce unexpected differences in the output. - Add an Async wrapper for `Core.Std.Unix.getifaddrs`. ## 113.00.00 - Made Async dump core when it reports a "bug in async scheduler". There is no change for toplevel unhandled user exceptions, for which Async does not dump core. - Added `Dump_core_on_job_delay.dump_core` function, which exposes the core-dumping functionality in the C stubs for `Dump_core_on_job_delay`. - Made `Dump_core_on_job_delay.How_to_dump` an ordinary variant and moved it into `Async_kernel.Config`. - Changed `Thread_safe_pipe` functions that write to the pipe to take an additional argument, an `If_closed.t`, that says how to behave if the pipe is closed. The previous behavior is achieved with `~if_closed:Raise`. One can also now use `~if_closed:Return` to they return a variant reporting whether the pipe was closed, rather than raising. Returning a variant allows callers to distinguish the pipe-closed case from other errors. This change also allows us to do a a single acquisition of the Async lock, with the pipe-closed check synchronously immediately preceding the operation, avoiding a race. - Added `Fd.with_file_descr_deferred_exn`. - Improved the performance of `Clock.every`, and in particular reduced its allocation. It now allocates much less, especially with `~continue_on_error:false`. Handled `Clock.every`'s `~stop` argument directly using timing-wheel alarms, rather than using `Deferred.choose`. Slightly changed the behavior of Clock.every' f ~continue_on_error:false in the corner case where `f` raises but its result also becomes determined. Prior to this feature, iteration would stop. After this feature, iteration will continue, because `~continue_on_error:false` just looks at the deferred resulting from `f`. This doesn't affect: Clock.every f ~continue_on_error:false because if `f` raises, then there is no resulting deferred. Benchmark: +----------------------------------------------------+----------+------------+----------+----------+------------+ | Name | Time/Run | mWd/Run | mjWd/Run | Prom/Run | Percentage | +----------------------------------------------------+----------+------------+----------+----------+------------+ | [clock_ns.ml:Clock.every] ~continue-on-error:false | 54.21us | 91.03w | 0.36w | 0.36w | 22.06% | | [clock_ns.ml:Clock.every] ~continue_on_error:true | 245.80us | 93_208.27w | 7.31w | 7.31w | 100.00% | +----------------------------------------------------+----------+------------+----------+----------+------------+ - Added to `Clock.Event.t` type parameters so that one can record a value in the event when it happens or is aborted, and read that value via `Event.status`. type ('a, 'h) t val status : ('a, 'h) t -> [ `Aborted of 'a | `Happened of 'h | `Scheduled_at of Time.t ] val run_at : Time.t -> ('z -> 'h) -> 'z -> (_, 'h) t val abort : ('a, 'h) t -> 'a -> [ `Ok | `Previously_aborted of 'a | `Previously_happened of 'h ] - Fixed a (never observed) race in the Async scheduler's closing of file descriptors. Previously, when the number of active system calls on an `Fd.t` reached zero, the scheduler would call a closure that would immediately schedule the `close()` system call in a thread. It was possible (albeit very unlikely) that that `close()` would run before the scheduler got a chance to update the epoll set, violating the invariant that `close` is only ever called on fds not in the epoll set. Now, the scheduler enqueues an ordinary Async job to do the `close`, and thus the `close` cannot happen until the next cycle, after the scheduler has updated the epoll set. - Changed `Reader` to treat `read` returning `EPIPE` as end-of-file rather than fail, to deal with OpenOnload. This fixes an issue where reading from a TCP connection can return an `EPIPE` if the tcp connection is immediately closed. This happens when the application is running with onload and when the tcp connection is closed immediately after creation. - Reduced allocation of the Async scheduler's `File_descr_watcher`, by using callbacks to handle ready file descriptors. - Fixed `In_thread.Helper_thread.create`'s error message if there are no available threads in the thread pool. The error message is now constructed eagerly. It had been constructed lazily, so by the time it was rendered, the state might have changed, possibly making threads available. This leads to a nonsensical-looking error message that claims that there are no available threads, immediately followed by a list of available threads. - Moved `Log` from `Async_extra` to `Async_unix`, so that the scheduler can refer to it. - When `Writer.with_file_atomic` is unable to clean up its temp file, raise synchronously rather than asynchronously. This eliminates complaints about an exception being thrown after a deferred has been computed. - Added `Log.rotate` to force log rotation. val rotate : t -> unit Deferred.t. - Fixed `Log` rotation to correctly reset the size and number of lines. ## 112.35.00 - Made `Unix.File_kind.t` be `Comparable`, so it can be used in `<:test_result< >>`. - Reduced allocation in Async's scheduler in the common path. The allocation was in `Raw_scheduler.be_the_scheduler.compute_timeout`, which was (statistically, based on perf) the largest single allocator in one of our applications. Now, it way down the list. Note that the application is not a typical Async app in that it does not sit in epoll very much, due to the way we do low-latency I/O. This change will benefit everyone, but only a tiny bit. - Added `Writer.write_bin_prot_no_size_header`. This is needed for Async RPC as it writes a different size on its own. - Fixed a bug in `Writer.transfer`, which didn't close the pipe when the consumer leaves. Simplified the implementation of `Writer.transfer`: - replaced the big loop by a simple iteration function on the pipe that just stop without filling its ivar when it sees the iteration should stop for other reason that `` `Eof `` on the pipe: writer closed, consumer left or stop requested by the user. - replaced the various `choose` by a single one and deal with the closing reason only at this point. - Added `Writer.close_started`, symmetric to Writer.close_finished. ## 112.24.00 - Made `Process.env` type equal `Core.Std.Unix.env` type, effectively adding the ``Replace_raw` variant. - Renamed `Process.wait` as `collect_output_and_wait`, and added a `wait` function that is a thin wrapper around `waitpid`. Also renamed: wait_stdout --> collect_stdout_and_wait wait_stdout_lines --> collect_stdout_lines_and_wait - Added `Unix.getgrouplist`, a wrapper around the eponymous function in core - Change the Async scheduler to run external actions immediately upon dequeueing them, rather than first enqueueing them in the normal job queue. Also, made external actions be jobs rather than closures. - Changed `Unix.Inet_addr.of_string_or_gethostbyname` to not use a sequencer. We had used a sequencer to workaround bugs in winbind, which we don't use anymore. Reported on github: https://github.com/janestreet/async_unix/issues/4 ## 112.17.00 - Moved `Scheduler.yield` to `Async_kernel`. - Added `Reader.load_annotated_sexp*` functions. These are like the existing `Reader.load_sexp*` functions, except they return annotated sexps rather than sexps. Having annotated sexps is useful so that one can report error positions to the user when processing values built by the `t_of_sexp_` functions /after/ they return. I.e. when there aren't syntax errors in the sexps, but rather semantic errors detected later. - Removed noise and redundancy from `Reader.load_sexp` error messages. - Added `Writer.save_sexps`, analogous to `Reader.load_sexps`. - Made `Writer` errors raised by the background flush job include the entire `Writer.t`, rather than just the `Fd.t`. - Added to `Writer.transfer` an optional argument to limit the number of values read at once from the pipe. The old behavior is to have no limit and remains the default. - Added to `Writer` some missing checks for functions that should ensure the input writer isn't closed. - Changed `Scheduler.run_cycles_until_no_jobs_remain` to pause so that alarms scheduled to fire in the past actually fire. This is necessary because of the timing-wheel, which doesn't guarantee to fire an event until alarm-precision after it was scheduled. Without this change, some tests unexpectedly fail, due to jobs not running that should have. ## 112.06.00 - Added `Writer.behave_nicely_in_pipeline`, which makes a program behave nicely when used in a shell pipeline where the consumer goes away. - Modernized code style. - Removed spurious overrides in `Signal`: `set` and `signal`. These overrides are no longer necessary because the functions moved from `Core.Signal` to `Core.Signal.Expert`. - Moved `async_extra`'s `Udp.bind_to_interface_exn` to `Unix`. ## 112.01.00 - Changed `Writer.transfer write pipe` to close `pipe` when the `writer`, is closed. Previously, `Writer.transfer` did not close the pipe when the underlying writer is closed. This was strange because: 1. Callers would have to consistently check for the writer being closed and close the `Pipe.Reader`t= themselves 2. The analogous function `Pipe.transfer` closes the reader on similar circumstances. The absence of the close was noticed as a bug in `Rpc`, which assumed that `Writer.transfer` did the close. - Fixed a bug in `Scheduler.yield` that caused it to pause for 50ms if there is no other pending work and no I/O. - Exposed type equivalence between `Unix.Passwd.t` and `Core.Std.Unix.Passwd.t`. - Changed `Writer.write_bin_prot` to use the new `Bigstring.write_bin_prot`. ## 111.28.00 - Added `Shutdown.set_default_force`, which allows one to change the default `force` value used by `shutdown`. This is useful for applications that call `shutdown` indirectly. val set_default_force : (unit -> unit Deferred.t) -> unit ## 111.25.00 - Added `Unix.Addr_info` and `Name_info`, which wrap `getaddrinfo` and `getnameinfo`. - Improved the scheduler's error message when the thread pool is stuck. ## 111.21.00 - Added `Process.wait_stdout` and `wait_stdout_lines`, which are like `run` and `run_lines`, but take a `Process.t`. ## 111.13.00 - Added `Scheduler.yield_every`, which returns a function that calls `Scheduler.yield` every n-th call. This is useful in circumstances where you don't have strict control over where a deferred is examined, as in a `Deferred.List.iter`. ## 111.11.00 - Added `val Scheduler.yield : unit -> unit Deferred.t`, which becomes determined after the current cycle finishes. - Improved the behavior of the scheduler's thread pool when `Thread.create` raises. With this improvement, when the thread pool is unable to create a thread, it presses on with the threads it has rather than raise. Subsequent attempts to add work to the thread pool will cause the pool to attempt to create the thread, as long as enough time has passed since the most recent thread-creation failure. Before this change, the thread pool wouldn't handle a `Thread.create` exception, and the exception would get raised to whatever code happened to be calling the `Thread_pool` function that tried to create a thread, e.g. `Thread_pool.add_work`. This caused `In_thread.run` to unexpectedly raise, and in turn `In_thread.syscall` to unexpectedly raise, leading to: ``` "Fd.syscall_in_thread bug -- should be impossible" ``` Also, changed `should be impossible` text to `please report`, since there may be other lurking rare exceptions that `In_thread.syscall` can raise, and we'd like to hear about them. We rely on thread-pool-stuck detection to report problems where the inability to create threads causes the inability of the thread pool to make progress. A tweak was needed to make that work -- now the thread-pool-stuck warning is based on whether the thread pool has unstarted work, rather than on whether the thread pool has an "available thread". The latter would no longer work, since it is now possible for the thread pool to have unstarted work and to appear to have an available thread, i.e. `num_threads < max_num_threads`. ## 111.08.00 - Added `Sys.when_file_changes : string -> Time.t Pipe.Reader.t`. - Added `Time.now ()` to some error messages. ## 111.06.00 - In the `Busy_pollers.t` record, made the `kernel_scheduler` field be `sexp_opaque`. Did this so that one doesn't get two copies of the kernel scheduler in sexps of the scheduler, which already has its own `kernel_scheduler` field. ## 111.03.00 - Improved `Socket.accept` to abort and return `` `Socket_closed`` when the file descriptor underlying the socket is closed. - Added to `Socket.bind` a `?reuseaddr:bool` argument, preserving the default as `true`. - Added `Fd.close_started`, which becomes determined when `close` is called on an `Fd.t`. ## 109.60.00 - Fixed a bug in detection of the thread pool being stuck that could overstate the amount of time the pool was stuck. It had been incorrectly reporting the duration of the thread pool being stuck if the pool had no work in it and then got enough jobs to be stuck. In that situation, the duration included the time span before the pool got stuck. If the pool had been idle long enough, this could even spuriously abort the program. ## 109.58.00 - Improved fairness of the async scheduler with respect to external threads, including I/O done in external threads. The change is to add a thread-safe queue of "external actions" that is checked after each job. Previously, when a job given to `In_thread.run` finished, `In_thread.run` would take the async lock, fill the result ivar and run a cycle. The problem is that in some situations, due to poor OS scheduling, the helper thread never had a chance to grab the lock. Now, `In_thread.run` tries to take the lock: - if it can it does as before - if it can't it enqueues a thunk in the external actions queue and wakes up the scheduler With this change, the helper thread doing an `In_thread.run` will always quickly finish once the work is done, and the async scheduler will fill in the result ivar as soon as the current job finishes. - Fixed `Epoll_file_descr_watcher.invariant` to deal with the timerfd, which has the edge-triggered flag set. - Added `Writer.write_gen`, a generic functor for blitting directly to a writer's buffer. ## 109.55.00 - Fixed `Scheduler.is_running` to not initialize the scheduler. - Added `Writer.make_write`, which is a general function for blitting directly to a writer's buffer. - Added `Writer.transfer'`, which is like `Writer.transfer` but allows async actions in the callback. This was requested in pull request #1. - Added `Writer.write_iobuf`, which blits the contents of an iobuf directly to a writer's buffer. ## 109.53.00 - Changed the scheduler to calibrate `Time_stamp_counter` every second. - Improved error messages in the scheduler when `epoll` functions raise. - Made `Scheduler.reset_in_forked_process` close the `epoll` file descriptor. ## 109.52.00 - Fixed a bug in `Unix.mkstemp`, which had a race because it used `Fd.create` in a thread. This bug affected `Writer.with_file_atomic`, `save`, `save_lines`, and `save_sexp`, and could cause corruption of the async scheduler data structures. - Changed async to never do `set_nonblock` on `std{in,out,err}`, which allows `Core` I/O to use the standard file descriptors simultaneously with async. Before this change, the Core I/O libraries could (and sometimes did) fail due to `Sys_blocked_io`. - Changed `Pipe.iter_without_pushback` to never call `f` after `Pipe.close_read` has been called. The new behavior is like `Pipe.iter`. Changed the implementation of `Pipe.fold_gen` and `Pipe.transfer_gen` to be analogous to `Pipe.iter_without_pushback`, and in particular to process as many elements as possible before calling `values_available`. - Added `?expand_macros:bool` argument to `Reader.load_sexp*` functions, to support the new `Sexplib` macros. - Added an optional argument to `Process.run` to accept nonzero exits as successful runs. ## 109.47.00 - Added `Socket.Address.Inet.to_host_and_port`. - Changed `Fd_by_descr` so that it actually calls `Bounded_int_table.invariant`. ## 109.45.00 - Added `Fd.every_ready_to` `Fd.interruptible_every_ready_to` which register a callback to be called every time the fd becomes ready. These can significantly reduce allocation. - Renamed `Fd.ready_to_interruptible` as `Fd.interruptible_ready_to`. - Changed `Fd.ready_fold` to use `Fd.interruptible_ready_to`, to improve its performance. ## 109.42.00 - Added `Reader.drain`. ```ocaml val drain : t -> unit Deferred.t ``` - Added `Writer.with_close`. ```ocaml val with_close : t -> f:(unit -> 'a Deferred.t) -> 'a Deferred.t ``` ## 109.41.00 - Changed `Reader` to treat more `errno` responses to a `read()` system call as `EOF` rather than raise. The following are now treated as `EOF`. ``` ENETDOWN ENETRESET ENETUNREACH ETIMEDOUT ``` - Improved the error message that async prints when the thread pool is stuck, including the time of the error. ## 109.40.00 - Added value `Socket.Type.unix_dgram`, which represents a UNIX domain datagram socket. - Added UDP socket functionality: `Socket.Opt.mcast_{loop,ttl}` and `Socket.mcast_{join,leave}`. - Improved `Fd.ready_fold` to accept `?stop:(unit Deferred.t)` rather than `?stop:('a -> bool)`. ## 109.39.00 - Added "thread-local" storage, `Scheduler.{find,with}_local`, for `LWT` emulation. ```ocaml (** [with_local key value ~f] runs [f] right now with the binding [key ` value]. All calls to [find_local key] in [f] and computations started from [f] will return [value]. *) val with_local : 'a Univ_map.Key.t -> 'a option -> f:(unit -> 'b) -> 'b (** [find_local key] returns the value associated to [key] in the current execution context. *) val find_local : 'a Univ_map.Key.t -> 'a option ``` ## 109.38.00 - Added `Reader.of_pipe` and `Writer.of_pipe`, for converting from `string Pipe.t`'s. These can be used to add arbitrary transformations (e.g. encryption, compression) to code that expects plain file- or socket-based readers and writers. ## 109.36.00 - Added `Process.run_lines`, which runs a process and returns stdout as a list of strings. ## 109.35.00 - Made some configuration possible via additional optional arguments to `go_main`. ```ocaml ?max_num_open_file_descrs:int ?max_num_threads:int ``` - Made some aspects of the async scheduler configurable via functions in `Scheduler`. ```ocaml val set_check_invariants : bool -> unit val set_detect_invalid_access_from_thread : bool -> unit val set_max_inter_cycle_timeout : Time.Span.t -> unit val set_record_backtraces : bool -> unit ``` - Added a dynamic check in `Pipe` that a consumer is used with the correct pipe. Specifically, check that a consumer supplied to a read operation on a `Pipe.Reader.t` was previously created by `add_consumer` with that same reader. - Renamed `Pipe.fold` as `fold_without_pushback` and added `Pipe.fold` with an analogous type to `Pipe.iter`. - Fixed a bug in `Pipe.merge`, which did not always close the resulting pipe when the merge was finished. This had prevented medusa regtests from working correctly. - In `Writer`, changed the default `buffer_age_limit` for files to ``Unlimited`. THis was done for the same reason that we treat files specially in flush on close -- slowness will likely be resolved eventually with a file, unlike with a socket. ## 109.34.00 - Changed the scheduler to detect when the thread pool is stuck, i.e. when all threads are blocked and haven't made progress. Added default handlers for when the thread pool is stuck, and the ability for the user to configure their own handlers. - Changed low-level I/O to not use nonblocking I/O for char devices. This fixes a problem due to `epoll` not working with `/dev/null`. For example: ```ocaml let () = Reader.read_line (Lazy.force Reader.stdin) >>> fun _ -> shutdown 0 ;; let () = never_returns (Scheduler.go ()) ``` had failed when run like: ``` + ./z.exe int64 -> mode:[< `Set | `End] -> int64 Deferred.t`. `lseek t offset ~mode` clears `t`'s buffer and calls `Unix.lseek` on `t`'s file descriptor. - Added function `Writer.bytes_received : t -> int`. - Added function `Unix.mkfifo : ?perm:file_perm -> string -> unit Deferred.t`, which was mistakenly missing. This is a simple wrapper around `Core.Unix.mkfifo`. ## 109.18.00 - added `Async.Unix.fcntl_{get,set}fl`. Made `Reader` and `Writer` detect if they are passed a file descriptor with incorrect permissions (`O_WRONLY` for `Reader`, `O_RDONLY` for `Writer`). ## 109.15.00 - The `epoll`-based scheduler now supports sub-millisecond timeouts, using `Linux_ext.Timerfd`. Async still uses the `select`-based scheduler by default. We plan to switch the default to `epoll` in a few weeks, once we have done more testing. - Eliminated module `Work_group`, which was for limiting the number of threads used by jobs. This was a little-used module that significantly complicated the implementation of the Async thread pool. One should consider using a `Throttle` instead. Along the way, fixed a bug in Async helper threads in which the finalizer could fire too early, causing an unhandled exception. The fix involves relaxing the requirements on when `Thread_pool.finished_with_helper_thread` functions can be called, allowing it to be called while the helper thread still has work, but so long as no future work will be added. ## 109.14.00 - Fixed major performance degradation (since 109.04) in `Reader.read*` functions. - Added function `Rpc.Implementation.map_inv`. ```ocaml val map_inv : 'a t -> f:('b -> 'a) -> 'b t ``` - Add functions `Reader.file_lines` and `Writer.save_lines`. These deal with files as lists of their lines. ```ocaml val Reader.file_lines : string -> string list Deferred.t val Writer.save_lines : string -> string list -> unit Deferred.t ``` - Added a `?wakeup_scheduler:bool` optional argument to functions in the `Thread_safe` module. The default is `true`, which continues the behavior that has been in place since 109.09. However, once can use `~wakeup_scheduler:false` to reduce CPU use, in return for increased latency (because the scheduler won't run a cycle immediately). ## 109.13.00 - Added `Writer.write_line`, which is `Writer.write` plus a newline at the end. - Added `?close_on_exec:bool` argument to `{Reader,Writer}.open_file` and `Async.Unix.open_file`. Made the default `close_on_exec:true` for `Reader` and `Writer`. - Added a `compare` function to `Socket.Address.Inet`. ## 109.12.00 - Fixed a bug in `Fd.syscall_in_thread`. The bug could cause: ```ocaml Fd.syscall_in_thread bug -- should be impossible ``` The bug was that `syscall_in_thread` raised rather than returning `Error`. - Changed `Tcp.connect` and `Tcp.with_connect` to also supply the connected socket. Supplying the connected socket makes it easy to call `Socket` functions, e.g. to find out information about the connection with `Socket.get{peer,sock}name`. This also gives information about the IP address *after* DNS, which wouldn't otherwise be available. One could reconstruct the socket by extracting the fd from the writer, and then calling `Socket.of_fd` with the correct `Socket.Type`. But that is both error prone and not discoverable. - Added `Writer.schedule_bigsubstring`, which parallels `Writer.schedule_bigstring`. ## 109.11.00 - Added a check to fail if `Scheduler.go` is called more than once. ## 109.10.00 - Added `Shutdown.do_not_finish_shutdown_before`. This allows one to add `unit Deferred.t`'s that will delay the `shutdown` from finishing. The implementation is more efficient than using `at_shutdown`. ## 109.09.00 - Added module `Thread_safe_pipe`, for streaming data outside async into async. This a more efficient and feature-ful way to send a sequence of values from outside async into async than `Thread_safe.pipe`, which has been eliminated. - Changed functions in `Thread_safe` to always wake up the scheduler. Changed `Thread_safe.run_in_async{,_exn}` to not run a cycle, and instead rely on the scheduler to run the cycle. ## 109.08.00 - Added module `Async.Process` This is a new module for creating and dealing with child processes. - For `Writer.save`, replaced the `temp_prefix` argument with `temp_file`. - Added `Ivar.invariant` function. - Added value `Scheduler.fold_fields` This lets one fold over the fields in the scheduler, eliminates an annoying place in catalog browser that reached into the internals of async to compute the sizes of the scheduler fields ## 109.07.00 - Changed the async scheduler so that if there are no upcoming events, it times out in 50ms rather than waiting forever. - Improved `Reader.read_one_chunk_at_a_time_until_eof`: - the callback need not consume everything - add `\`Eof_with_unconsumed_data` as a possible result - grow internal buffer of the reader when needed - Added `Shutdown.exit`, removed `Shutdown.shutdown_and_raise`. - Added `Scheduler.force_current_cycle_to_end`. async_unix-0.15.0/CONTRIBUTING.md000066400000000000000000000044101420273305200162030ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ async_unix-0.15.0/LICENSE.md000066400000000000000000000021351420273305200153600ustar00rootroot00000000000000The MIT License Copyright (c) 2008--2022 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. async_unix-0.15.0/Makefile000066400000000000000000000004031420273305200154100ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean async_unix-0.15.0/README.md000066400000000000000000000006361420273305200152370ustar00rootroot00000000000000Async_unix ========== Async_unix includes Unix-related dependencies for things like system calls and threads. Using these, it hooks the Async_kernel scheduler up to either `epoll` or `select`, depending on availability, and manages a thread pool that blocking system calls run in. API documentation for the latest release can be found [here](https://ocaml.janestreet.com/ocaml-core/latest/doc/async/index.html). async_unix-0.15.0/async_unix.opam000066400000000000000000000017211420273305200170120ustar00rootroot00000000000000opam-version: "2.0" version: "v0.15.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/async_unix" bug-reports: "https://github.com/janestreet/async_unix/issues" dev-repo: "git+https://github.com/janestreet/async_unix.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/async_unix/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.08.0"} "async_kernel" {>= "v0.15" & < "v0.16"} "core" {>= "v0.15" & < "v0.16"} "core_kernel" {>= "v0.15" & < "v0.16"} "core_unix" {>= "v0.15" & < "v0.16"} "ppx_jane" {>= "v0.15" & < "v0.16"} "dune" {>= "2.0.0"} ] synopsis: "Monadic concurrency library" description: " Part of Jane Street's Core library The Core suite of libraries is an industrial strength alternative to OCaml's standard library that was developed by Jane Street, the largest industrial user of OCaml. " async_unix-0.15.0/dune-project000066400000000000000000000000201420273305200162650ustar00rootroot00000000000000(lang dune 1.10)async_unix-0.15.0/src/000077500000000000000000000000001420273305200145425ustar00rootroot00000000000000async_unix-0.15.0/src/assign_try_with_log_exn.ml000066400000000000000000000025751420273305200220350ustar00rootroot00000000000000open! Core open! Async_kernel open! Import (* We want to get a log of errors sent to [Monitor.try_with] after the initial return, so on initialization we redirect them to [Log.Global.error]. However, logging errors isn't cheap and there are issues with thread fairness when outputting to stderr (which is the default in many cases for [Global.error]), so, to prevent the [Log] [Writer.t] buffer from growing without bound, we limit the number of currently unflushed error messages created by [try_with_log_exn]. *) let try_with_log_exn = let max_unflushed_errors = 10 in let current_unflushed_errors = ref 0 in let log sexp = Log.Global.sexp sexp ~level:`Error in fun exn -> if !current_unflushed_errors < max_unflushed_errors then ( incr current_unflushed_errors; log [%message "Exception raised to [Monitor.try_with] that already returned." "This error was captured by a default handler in [Async.Log]." (exn : exn)]; if !current_unflushed_errors = max_unflushed_errors then log [%message "Stopped logging exceptions raised to [Monitor.try_with] that already \ returned until error log can be flushed."]; upon (Log.Global.flushed ()) (fun () -> decr current_unflushed_errors)) ;; let () = Async_kernel.Monitor.Expert.try_with_log_exn := try_with_log_exn async_unix-0.15.0/src/assign_try_with_log_exn.mli000066400000000000000000000003251420273305200221750ustar00rootroot00000000000000(*_ This module is internal to Async. It is [include]d in [std.ml] so that any code that uses [Async_unix] does the top-level side effect in this module to assign [Async_kernel.Monitor0.try_with_log_exn]. *) async_unix-0.15.0/src/async_print.ml000066400000000000000000000023641420273305200174320ustar00rootroot00000000000000open Core let stdout () = Lazy.force Writer.stdout let stderr () = Lazy.force Writer.stderr let do_printf writer = ksprintf (fun s -> Writer.write (writer ()) s) let printf fmt = do_printf stdout fmt let fprintf writer fmt = Printf.ksprintf (fun s -> Writer.write writer s) fmt let eprintf fmt = do_printf stderr fmt let print_char c = Writer.write_char (stdout ()) c let prerr_char c = Writer.write_char (stderr ()) c let print_string s = Writer.write (stdout ()) s let prerr_string s = Writer.write (stderr ()) s let print_newline () = Writer.write_char (stdout ()) '\n' let prerr_newline () = Writer.write_char (stderr ()) '\n' let print_endline s = print_string s; print_newline () ;; let prerr_endline s = prerr_string s; prerr_newline () ;; let print_int i = print_string (Int.to_string i) let prerr_int i = prerr_string (Int.to_string i) let print_float f = print_string (Float.to_string_12 f) let prerr_float f = prerr_string (Float.to_string_12 f) let print_s ?mach sexp = print_endline (match mach with | Some () -> Sexp.to_string_mach sexp | None -> Sexp.to_string_hum sexp) ;; let eprint_s ?mach sexp = prerr_endline (match mach with | Some () -> Sexp.to_string_mach sexp | None -> Sexp.to_string_hum sexp) ;; async_unix-0.15.0/src/async_print.mli000066400000000000000000000013071420273305200175770ustar00rootroot00000000000000(** Non-blocking, Async-friendly print functions. *) val print_char : char -> unit val prerr_char : char -> unit val print_string : string -> unit val prerr_string : string -> unit val print_int : int -> unit val prerr_int : int -> unit val print_float : float -> unit val prerr_float : float -> unit val print_endline : string -> unit val prerr_endline : string -> unit val print_newline : unit -> unit val prerr_newline : unit -> unit val print_s : ?mach:unit -> Sexplib.Sexp.t -> unit val printf : ('a, unit, string, unit) format4 -> 'a val fprintf : Writer.t -> ('a, unit, string, unit) format4 -> 'a val eprintf : ('a, unit, string, unit) format4 -> 'a val eprint_s : ?mach:unit -> Sexplib.Sexp.t -> unit async_unix-0.15.0/src/async_sys.ml000066400000000000000000000055361420273305200171200ustar00rootroot00000000000000open Core open Import module Unix = Unix_syscalls let argv = (Sys.argv [@warning "-3"]) let get_argv = Sys.get_argv let executable_name = Sys_unix.executable_name let wrap1 f x1 = In_thread.run (fun () -> f x1) let wrap2 f x1 x2 = In_thread.run (fun () -> f x1 x2) let when_file_changes ?(time_source = Time_source.wall_clock ()) ?(poll_delay = sec 0.5) file = let last_reported_mtime = ref None in let reader, writer = Pipe.create () in let rec loop () = Monitor.try_with ~run: `Schedule ~rest:`Log ~extract_exn:true (fun () -> Unix.stat file) >>> fun stat_result -> if not (Pipe.is_closed writer) then ( (match stat_result with | Error exn -> last_reported_mtime := None; Pipe.write_without_pushback writer (Error exn) | Ok st -> let mtime = st.mtime in let should_report = match !last_reported_mtime with | None -> true | Some last_reported_mtime -> not (Time.equal mtime last_reported_mtime) in if should_report then ( last_reported_mtime := Some mtime; Pipe.write_without_pushback writer (Ok mtime))); Time_source.after time_source (Time_ns.Span.of_span_float_round_nearest poll_delay) >>> loop) in loop (); reader ;; let chdir = wrap1 Sys_unix.chdir let command = wrap1 Sys_unix.command let command_exn = wrap1 Sys_unix.command_exn let quote = Sys.quote let concat_quoted = Sys.concat_quoted let getcwd = wrap1 Sys_unix.getcwd let home_directory = wrap1 Sys_unix.home_directory let ls_dir = wrap1 Sys_unix.ls_dir let readdir = wrap1 Sys_unix.readdir let remove = wrap1 Sys_unix.remove let rename = wrap2 Sys_unix.rename let wrap_is f ?follow_symlinks path = In_thread.run (fun () -> f ?follow_symlinks path) let file_exists = wrap_is Sys_unix.file_exists let file_exists_exn = wrap_is Sys_unix.file_exists_exn let when_file_exists ?follow_symlinks ?(poll_delay = sec 0.5) file = Deferred.create (fun i -> let rec loop () = file_exists ?follow_symlinks file >>> function | `Yes -> Ivar.fill i () | `No -> upon (Clock.after poll_delay) loop | `Unknown -> raise_s [%message "when_file_exists can not check file" (file : string)] in loop ()) ;; let is_directory = wrap_is Sys_unix.is_directory let is_directory_exn = wrap_is Sys_unix.is_directory_exn let is_file = wrap_is Sys_unix.is_file let is_file_exn = wrap_is Sys_unix.is_file_exn let c_int_size = Sys_unix.c_int_size let execution_mode = Sys_unix.execution_mode let getenv = Sys.getenv let getenv_exn = Sys.getenv_exn let int_size = Sys.int_size_in_bits let interactive = Sys.interactive let ocaml_version = Sys.ocaml_version let os_type = Sys.os_type let word_size = Sys.word_size_in_bits let opaque_identity = Sys.opaque_identity let big_endian = Sys.big_endian async_unix-0.15.0/src/async_sys.mli000066400000000000000000000050111420273305200172550ustar00rootroot00000000000000(** This module overrides everything in the [Core.Sys] module that might block. Functions do the same thing as their counterparts in [Core.Sys], but instead return deferreds. For a description of their semantics see the documentation for the [Core.Sys] module. *) open! Core open! Import val argv : string array [@@deprecated "[since 2019-08] Use [Sys.get_argv] instead, which has the correct behavior when \ [caml_sys_modify_argv] is called."] val get_argv : unit -> string array val executable_name : string val file_exists : ?follow_symlinks:bool -> string -> [ `Yes | `No | `Unknown ] Deferred.t val file_exists_exn : ?follow_symlinks:bool -> string -> bool Deferred.t (** [when_file_exists ?poll_delay file] returns a deferred that becomes determined when [file] exists. The default poll delay is 0.5 seconds. It raises an exception if it can not check whether the file is there, in the same cases [file_exists] returns [`Unknown]. *) val when_file_exists : ?follow_symlinks:bool -> ?poll_delay:Time.Span.t -> string -> unit Deferred.t (** [when_file_changes file] polls [file] using [stat] and writes [file]'s mtime to the pipe every time it changes or there's an error. The first time in the pipe will be [file]'s current mtime. To stop polling, close the pipe. *) val when_file_changes : ?time_source:Time_source.t -> ?poll_delay:Time.Span.t -> string -> (Time.t, exn) Result.t Pipe.Reader.t val is_directory : ?follow_symlinks:bool -> string -> [ `Yes | `No | `Unknown ] Deferred.t val is_directory_exn : ?follow_symlinks:bool -> string -> bool Deferred.t val is_file : ?follow_symlinks:bool -> string -> [ `Yes | `No | `Unknown ] Deferred.t val is_file_exn : ?follow_symlinks:bool -> string -> bool Deferred.t val remove : string -> unit Deferred.t val rename : string -> string -> unit Deferred.t val getenv : string -> string option val getenv_exn : string -> string val command : string -> int Deferred.t val command_exn : string -> unit Deferred.t val quote : string -> string val concat_quoted : string list -> string val chdir : string -> unit Deferred.t val getcwd : unit -> string Deferred.t val readdir : string -> string array Deferred.t val ls_dir : string -> string list Deferred.t val home_directory : unit -> string Deferred.t val opaque_identity : 'a -> 'a val interactive : bool ref val os_type : string val word_size : int val int_size : int val big_endian : bool val ocaml_version : string val execution_mode : unit -> [ `Bytecode | `Native ] val c_int_size : unit -> int async_unix-0.15.0/src/async_unix.ml000066400000000000000000000130251420273305200172550ustar00rootroot00000000000000module Async_config = Config module Clock = Clock module Dump_core_on_job_delay = Dump_core_on_job_delay module Fd = Fd module In_thread = In_thread module Io_stats = Io_stats module Log = Log module Print = Async_print module Process = Process module Reader = Reader module Require_explicit_time_source = Require_explicit_time_source module Scheduler = Scheduler module Shutdown = Shutdown module Signal = Signal module Socket = Unix_syscalls.Socket module Sys = Async_sys module Tcp = Tcp module Thread_safe = Thread_safe module Writer = Writer module Unix = struct module Fd = Fd include Unix_syscalls (** @open *) end (* see comment in assign_try_with_log_exn.mli *) include Assign_try_with_log_exn let after = Clock.after let at = Clock.at let every = Clock.every let with_timeout = Clock.with_timeout let schedule = Scheduler.schedule let schedule' = Scheduler.schedule' let shutdown = Shutdown.shutdown let within = Scheduler.within let within' = Scheduler.within' (* We rebind all pervasive and some Core funtions that deal with I/O so that one doesn't unintentionally do blocking stuff in an Async program. *) (** Shadow blocking functions in [Core.Printf] to prevent their unintentional use. *) module Printf = struct let _shadow = `Probably_should_not_use_blocking_Core_Printf_functions_with_Async let bprintf = Core.Printf.bprintf let eprintf = _shadow let exitf = _shadow let failwithf = Core.Printf.failwithf let fprintf _ = _shadow let ifprintf _ = Core.Printf.ifprintf let invalid_argf = Core.Printf.invalid_argf let kbprintf = Core.Printf.kbprintf let kfprintf _ _ = _shadow let ksprintf = Core.Printf.ksprintf let printf = _shadow let sprintf = Core.Printf.sprintf end include struct open Core module Overwrite_ = struct let overwrite1 (`This_is_async__Think_about_blocking as x) = x let overwrite2 `This_is_async__Think_about_blocking = overwrite1 let overwrite3 `This_is_async__Think_about_blocking = overwrite2 let overwrite4 `This_is_async__Think_about_blocking = overwrite3 end open Overwrite_ let close_in_noerr = overwrite1 let close_in = overwrite1 let close_out_noerr = overwrite1 let close_out = overwrite1 let eprintf = Print.eprintf let flush_all = overwrite1 let flush = overwrite1 let fprintf = Print.fprintf let ifprintf = Printf.ifprintf let in_channel_length = overwrite1 let input_binary_int = overwrite1 let input_byte = overwrite1 let input_char = overwrite1 let input_line = overwrite1 let input_lines ?fix_win_eol:_ = overwrite1 let input = overwrite4 let input_value = overwrite1 let open_in_bin = overwrite1 let open_in_gen = overwrite3 let open_in = overwrite1 let open_out_bin = overwrite1 let open_out_gen = overwrite3 let open_out = overwrite1 let out_channel_length = overwrite1 let output_binary_int = overwrite2 let output_byte = overwrite2 let output_char = overwrite2 let output = overwrite4 let output_string = overwrite2 let output_value = overwrite2 let pos_in = overwrite1 let pos_out = overwrite1 let prerr_char = Print.prerr_char let prerr_endline = Print.prerr_endline let prerr_float = Print.prerr_float let prerr_int = Print.prerr_int let prerr_newline = Print.prerr_newline let prerr_string = Print.prerr_string let print_char = Print.print_char let print_endline = Print.print_endline let print_float = Print.print_float let printf = Print.printf let print_int = Print.print_int let print_newline = Print.print_newline let print_s = Print.print_s let print_string = Print.print_string let read_float = overwrite1 let read_int = overwrite1 let read_line = overwrite1 let read_lines = overwrite1 let read_wrap ?binary:_ ~f:_ = overwrite1 let really_input = overwrite4 let seek_in = overwrite2 let seek_out = overwrite1 let set_binary_mode_in = overwrite2 let set_binary_mode_out = overwrite2 let write_lines = overwrite2 let write_wrap ?binary:_ ~f:_ = overwrite1 let eprint_s = overwrite1 [@@deprecated "[since 2019-12] If you want to the blocking version, use [Core.eprint_s] (this \ preserves behavior, but is discouraged). If you want the nonblocking version, use \ [eprint_s_nonblocking] or [Print.eprint_s]"] ;; let eprint_s_nonblocking = Print.eprint_s module LargeFile = struct let seek_out = overwrite1 let pos_out = overwrite1 let out_channel_length = overwrite1 let seek_in = overwrite1 let pos_in = overwrite1 let in_channel_length = overwrite1 end module Sexp : sig include module type of struct include Sexp end val save : ?perm:int -> string -> t -> unit [@@alert blocking "Use [Writer.save_sexp ~hum:false] to avoid blocking."] val save_hum : ?perm:int -> string -> t -> unit [@@alert blocking "Use [Writer.save_sexp ~hum:true] to avoid blocking."] val save_mach : ?perm:int -> string -> t -> unit [@@alert blocking "Use [Writer.save_sexp ~hum:false] to avoid blocking."] val save_sexps : ?perm:int -> string -> t list -> unit [@@alert blocking "Use [Writer.save_sexps ~hum:false] to avoid blocking."] val save_sexps_hum : ?perm:int -> string -> t list -> unit [@@alert blocking "Use [Writer.save_sexps ~hum:true] to avoid blocking."] val save_sexps_mach : ?perm:int -> string -> t list -> unit [@@alert blocking "Use [Writer.save_sexps ~hum:false] to avoid blocking."] end = Sexp end let exit = Shutdown.exit (**/**) module Async_unix_private = struct module Fd_by_descr = Fd_by_descr module Raw_fd = Raw_fd module Raw_scheduler = Raw_scheduler module Syscall = Syscall end (**/**) async_unix-0.15.0/src/backing_out_channel.ml000066400000000000000000000037651420273305200210640ustar00rootroot00000000000000open! Core open! Import type output_chars = bigstring -> len:int -> unit type t = { mutable bigstring_buf : Bigstring.t ; output_char : char -> unit ; output_chars : output_chars ; flush : unit -> unit ; sexp : unit -> Sexp.t } [@@deriving fields] let sexp_of_t t = t.sexp () let invariant t = Invariant.invariant [%here] t [%sexp_of: t] (fun () -> let _check f = Invariant.check_field t f in Fields.iter ~bigstring_buf:ignore ~output_char:ignore ~output_chars:ignore ~flush:ignore ~sexp:ignore) ;; let create ~output_char ~output_chars ~flush ~sexp = { bigstring_buf = Bigstring.create 0; output_char; output_chars; flush; sexp } ;; let of_out_channel out_channel : t = let bytes_buf = Bytes.of_string "" |> ref in create ~output_char:(fun c -> Out_channel.output_char out_channel c) ~output_chars:(fun buf ~len -> if len > Bytes.length !bytes_buf then bytes_buf := Bytes.create (len * 2); Bigstring.To_bytes.blit ~len ~src:buf ~src_pos:0 ~dst:!bytes_buf ~dst_pos:0; Out_channel.output out_channel ~buf:!bytes_buf ~pos:0 ~len) ~flush:(fun () -> Out_channel.flush out_channel) ~sexp:(fun () -> [%sexp { out_channel : Out_channel.t }]) ;; let of_output_char output_char : t = create ~output_char ~flush:Fn.id ~sexp:(fun () -> [%sexp ()]) ~output_chars:(fun buf ~len -> for i = 0 to len - 1 do output_char buf.{i} done) ;; (* Implement the polymorphic [write_gen_* ~blit_to_string] API here rather than in every abstraction. [create ~output_chars] is a simpler basis for this functionality with very little cost in abstraction - it only gives up buffer management details. *) let output t ~blit_to_bigstring ~src ~src_len ~src_pos = if src_len > Bigstring.length t.bigstring_buf then t.bigstring_buf <- Bigstring.create (src_len * 2); blit_to_bigstring ~src ~src_pos ~dst:t.bigstring_buf ~dst_pos:0 ~len:src_len; t.output_chars t.bigstring_buf ~len:src_len ;; let flush t = t.flush () async_unix-0.15.0/src/backing_out_channel.mli000066400000000000000000000012341420273305200212220ustar00rootroot00000000000000(** [Backing_out_channel] generalizes [Out_channel] to a narrow interface that can be used to collect strings, etc. *) open! Core open! Import type t [@@deriving sexp_of] include Invariant.S with type t := t type output_chars = bigstring -> len:int -> unit val of_out_channel : Out_channel.t -> t val of_output_char : (char -> unit) -> t val create : output_char:(char -> unit) -> output_chars:output_chars -> flush:(unit -> unit) -> sexp:(unit -> Sexp.t) -> t val output_char : t -> char -> unit val output : t -> blit_to_bigstring:('a, Bigstring.t) Blit.blit -> src:'a -> src_len:int -> src_pos:int -> unit val flush : t -> unit async_unix-0.15.0/src/clock.ml000066400000000000000000000061701420273305200161730ustar00rootroot00000000000000open! Core open! Import open Async_kernel.Clock_ns module Or_timeout = Or_timeout let run_at time f a = run_at (Time_ns.of_time_float_round_nearest time) f a let run_after span f a = run_after (Time_ns.Span.of_span_float_round_nearest span) f a let at time = at (Time_ns.of_time_float_round_nearest time) let after span = after (Time_ns.Span.of_span_float_round_nearest span) let with_timeout span d = with_timeout (Time_ns.Span.of_span_float_round_nearest span) d module Event = struct module Abort_result = Event.Abort_result module Fired = Event.Fired module Reschedule_result = Event.Reschedule_result type ('a, 'h) t = ('a, 'h) Event.t [@@deriving sexp_of] type t_unit = Event.t_unit [@@deriving sexp_of] let invariant = Event.invariant let abort = Event.abort let abort_exn = Event.abort_exn let abort_if_possible = Event.abort_if_possible let fired = Event.fired let scheduled_at t = Time_ns.to_time_float_round_nearest (Event.scheduled_at t) let at time = Event.at (Time_ns.of_time_float_round_nearest time) let after span = Event.after (Time_ns.Span.of_span_float_round_nearest span) let reschedule_at t time = Event.reschedule_at t (Time_ns.of_time_float_round_nearest time) ;; let reschedule_after t span = Event.reschedule_after t (Time_ns.Span.of_span_float_round_nearest span) ;; let run_at time f x = Event.run_at (Time_ns.of_time_float_round_nearest time) f x let run_after span f x = Event.run_after (Time_ns.Span.of_span_float_round_nearest span) f x ;; module Status = struct type ('a, 'h) t = | Aborted of 'a | Happened of 'h | Scheduled_at of Time.t [@@deriving sexp_of] end let status t : _ Status.t = match Event.status t with | Aborted a -> Aborted a | Happened h -> Happened h | Scheduled_at time -> Scheduled_at (Time_ns.to_time_float_round_nearest time) ;; end let at_varying_intervals ?stop f = at_varying_intervals ?stop (fun () -> Time_ns.Span.of_span_float_round_nearest (f ())) ;; let at_intervals ?start ?stop span = let start = Option.map start ~f:Time_ns.of_time_float_round_nearest in at_intervals ?start ?stop (Time_ns.Span.of_span_float_round_nearest span) ;; let every' ?start ?stop ?continue_on_error ?finished span f = every' ?start ?stop ?continue_on_error ?finished (Time_ns.Span.of_span_float_round_nearest span) f ;; let every ?start ?stop ?continue_on_error span f = every ?start ?stop ?continue_on_error (Time_ns.Span.of_span_float_round_nearest span) f ;; let run_at_intervals' ?start ?stop ?continue_on_error span f = let start = Option.map start ~f:Time_ns.of_time_float_round_nearest in run_at_intervals' ?start ?stop ?continue_on_error (Time_ns.Span.of_span_float_round_nearest span) f ;; let run_at_intervals ?start ?stop ?continue_on_error span f = let start = Option.map start ~f:Time_ns.of_time_float_round_nearest in run_at_intervals ?start ?stop ?continue_on_error (Time_ns.Span.of_span_float_round_nearest span) f ;; let duration_of f = let%map res, span = duration_of f in res, Time_ns.Span.to_span_float_round_nearest span ;; async_unix-0.15.0/src/clock.mli000066400000000000000000000002551420273305200163420ustar00rootroot00000000000000(** A {{!Async_kernel.Clock_intf.Clock}[Clock]} based on [Core.Time]. *) open! Core open! Import include Async_kernel.Clock_ns.Clock with module Time := Time (** @open *) async_unix-0.15.0/src/config.ml000066400000000000000000000021141420273305200163370ustar00rootroot00000000000000open! Core module Unix = Core_unix include Async_kernel.Async_kernel_config let file_descr_watcher = match file_descr_watcher with | (Epoll | Select) as x -> x | Epoll_if_timerfd -> (* Without timerfd, epoll_wait(2) timeouts would have only millisecond precision. *) if Result.is_ok Linux_ext.Timerfd.create then Epoll else Select ;; let max_num_open_file_descrs = if not (Max_num_open_file_descrs.equal max_num_open_file_descrs Max_num_open_file_descrs.default) then max_num_open_file_descrs else ( match file_descr_watcher with | Select -> (* The maximum numeric value for a file descriptor watchable by [select] is limited by [FD_SETSIZE], which happens to be 1024 on Linux. *) Max_num_open_file_descrs.create_exn 1024 | Epoll | Epoll_if_timerfd -> Int.min Max_num_open_file_descrs.(default |> raw) (match Unix.RLimit.(get num_file_descriptors).max with | Infinity -> Int.max_value | Limit int64 -> int64 |> Int64.to_int_exn) |> Max_num_open_file_descrs.create_exn) ;; async_unix-0.15.0/src/config.mli000066400000000000000000000001151420273305200165070ustar00rootroot00000000000000include module type of struct include Async_kernel.Async_kernel_config end async_unix-0.15.0/src/dump_core_on_job_delay.ml000066400000000000000000000024301420273305200215540ustar00rootroot00000000000000open! Core open! Import module Dump_type = struct (* This variant mirrors an enum in the C, so order in this declaration matters. *) type t = | Call_abort | Call_gcore end external dump_core : Dump_type.t -> unit = "dump_core_on_job_delay_dump_core" external watch : float -> Dump_type.t -> unit = "dump_core_on_job_delay_watch" external tick : unit -> unit = "dump_core_on_job_delay_tick" module How_to_dump = struct include Config.Dump_core_on_job_delay.How_to_dump let choose_dump_type : t -> Dump_type.t = function | Call_abort -> Call_abort | Call_gcore -> Call_gcore | Default -> (match Sys_unix.file_exists "/usr/bin/gcore" with | `Yes -> Call_gcore | `No | `Unknown -> Call_abort) ;; end let start_watching ~dump_if_delayed_by ~how_to_dump = let dump_type = How_to_dump.choose_dump_type how_to_dump in let dump_if_delayed_by_sec = Time.Span.to_sec dump_if_delayed_by in let tick_interval = sec (dump_if_delayed_by_sec /. 10.) in ignore (Thread.create ~on_uncaught_exn:`Print_to_stderr (fun () -> watch dump_if_delayed_by_sec dump_type) () : Thread.t); Clock.every tick_interval tick ;; let dump_core ?(how_to_dump = How_to_dump.Default) () = dump_core (How_to_dump.choose_dump_type how_to_dump) ;; async_unix-0.15.0/src/dump_core_on_job_delay.mli000066400000000000000000000022551420273305200217320ustar00rootroot00000000000000(** Dump core if jobs are delayed, to get additional debug information when running on UNIX systems that support core dumps. It is not normally enabled, but may be enabled for any program by setting the appropriate field, [dump_core_on_job_delay], in the [ASYNC_CONFIG] environment variable. *) open! Core open! Import module How_to_dump : sig type t = Config.Dump_core_on_job_delay.How_to_dump.t = | Default | Call_abort | Call_gcore [@@deriving sexp_of] end (** [start_watching] starts a regular async job (via [Clock.every]) that increments a counter, and a C thread to make sure that the counter is incremented in a timely manner. *) val start_watching : dump_if_delayed_by:Time.Span.t -> how_to_dump:How_to_dump.t -> unit (** [dump_core ()] dumps a core file using [/usr/bin/gcore] if it exists, or by calling [abort()] if not (or with [~how_to_dump:Call_abort]). With gcore, the dump is done in a child process, and the core file is written to [/tmp/core.$N.$PID], where [$PID] is the process id and [$N] is a counter that is incremented on each call to [dump_core]. *) val dump_core : ?how_to_dump:How_to_dump.t -> unit -> unit async_unix-0.15.0/src/dump_core_on_job_delay_stubs.c000066400000000000000000000071741420273305200226200ustar00rootroot00000000000000#define _GNU_SOURCE #include #include #include #include #include #include #include #include #include "ocaml_utils.h" /* this type must be kept strictly in sync with the OCaml type */ typedef enum { CALL_ABORT = 0, CALL_GCORE = 1, DUMP_TYPE_LIMIT = 2 /* used to catch mismatch between this type and the OCaml type */ } core_dump_type; static int num_ticks = 0; /* updated by regular Async job */ static int core_dump_count = 0; #define CORE_FILENAME_MAX_LEN (4 + 1 + 10 + 1) /* max pid is 2^22 on 64 bit systems, which is 7 digits + 1 for terminating NULL. */ #define PID_STR_MAX_LEN 10 static void dump_core (core_dump_type dump_type) { pid_t main_pid = getpid (); pid_t fork_pid; int status; char gcore_path[] = "/usr/bin/gcore"; char pid_str[PID_STR_MAX_LEN]; char core_filename[CORE_FILENAME_MAX_LEN]; /* core.. */ char *args[] = { NULL, NULL, NULL, NULL, NULL }; char *env[] = { NULL }; core_dump_count = core_dump_count + 1; switch (dump_type) { case CALL_ABORT: abort (); break; case CALL_GCORE: fork_pid = fork (); if (fork_pid) { waitpid (fork_pid, &status, 0); } else { assert (snprintf (core_filename, CORE_FILENAME_MAX_LEN, "core.%i", core_dump_count) < CORE_FILENAME_MAX_LEN); assert (snprintf (pid_str, PID_STR_MAX_LEN, "%d", main_pid) < PID_STR_MAX_LEN); args[0] = gcore_path; args[1] = "-o"; args[2] = core_filename; args[3] = pid_str; execve(gcore_path, args, env); }; break; case DUMP_TYPE_LIMIT: caml_leave_blocking_section(); caml_failwith ("bug in dump_core_on_job_delay_dump_core"); }; } CAMLprim value dump_core_on_job_delay_dump_core (value v_dump_type) { CAMLparam1 (v_dump_type); core_dump_type dump_type = Int_val (v_dump_type); if ( dump_type >= DUMP_TYPE_LIMIT ) caml_failwith ("bug in dump_core_on_job_delay_dump_core"); dump_core (dump_type); CAMLreturn (Val_unit); } CAMLprim value dump_core_on_job_delay_watch (value v_dump_if_delayed_by, value v_dump_type) { CAMLparam2 (v_dump_if_delayed_by, v_dump_type); useconds_t dump_if_delayed_by = Double_val (v_dump_if_delayed_by) * 1000 * 1000; core_dump_type dump_type = CALL_ABORT; int last_num_ticks_seen = num_ticks; bool already_dumped_this_cycle = false; dump_type = Int_val (v_dump_type); if ( dump_type >= DUMP_TYPE_LIMIT ) caml_failwith ("bug in dump_core_on_job_delay_watch"); /* We give up the CAML lock because we intend to run the following loop for the life of the program. */ caml_enter_blocking_section(); for (;;) { usleep (dump_if_delayed_by); /* If [last_num_ticks_seen] is the same as the last time we woke up, then the Async tick job has been delayed. */ if (last_num_ticks_seen == num_ticks) { if (!already_dumped_this_cycle) { already_dumped_this_cycle = true; dump_core (dump_type); } } else { /* Otherwise, if the count has changed, and we reset everything. */ already_dumped_this_cycle = false; last_num_ticks_seen = num_ticks; }; }; caml_leave_blocking_section(); CAMLreturn (Val_unit); } CAMLprim value dump_core_on_job_delay_tick (value v_unit) { /* Not strictly needed, but it keeps the compiler from complaining about an unused [v_unit] arg, and there really isn't a need to make this as fast as possible. */ CAMLparam1 (v_unit); num_ticks = num_ticks + 1; CAMLreturn (Val_unit); } async_unix-0.15.0/src/dune000066400000000000000000000007171420273305200154250ustar00rootroot00000000000000(library (name async_unix) (public_name async_unix) (libraries async_kernel core_unix.bigstring_unix core_kernel.bounded_int_table core core_unix.filename_unix core_unix.iobuf_unix core_unix.nano_mutex async_kernel.read_write_pair core_unix.squeue core_unix.sys_unix thread_pool thread_safe_ivar core_unix.time_ns_unix core_unix.time_stamp_counter core_unix.time_unix core_unix.uuid) (c_names dump_core_on_job_delay_stubs) (preprocess (pps ppx_jane)))async_unix-0.15.0/src/epoll_file_descr_watcher.ml000066400000000000000000000122271420273305200221070ustar00rootroot00000000000000open Core open Import open File_descr_watcher_intf open Read_write_pair.Export module Epoll = Linux_ext.Epoll module Timerfd = Linux_ext.Timerfd module Flags = struct include Epoll.Flags let in_out = in_ + out (* Use the edge-triggered behavior so we don't have to reset the timerfd when it expires. *) let for_timerfd = in_ + et let of_rw = function | `Read -> in_ | `Write -> out ;; end type t = { timerfd : Timerfd.t ; epoll : Epoll.t ; handle_fd_read_ready : File_descr.t -> Flags.t -> unit ; handle_fd_write_ready : File_descr.t -> Flags.t -> unit } [@@deriving sexp_of, fields] let backend = Config.File_descr_watcher.Epoll let is_timerfd t fd = File_descr.equal fd (Timerfd.to_file_descr t.timerfd) let invariant t : unit = try let check f field = f (Field.get field t) in Fields.iter ~timerfd: (check (fun timerfd -> [%test_result: Flags.t option] (Epoll.find t.epoll (Timerfd.to_file_descr timerfd)) ~expect:(Some Flags.for_timerfd))) ~epoll: (check (fun epoll -> Epoll.iter epoll ~f:(fun _ flags -> assert ( List.exists Flags.[ in_; out; in_out; for_timerfd ] ~f:(fun flags' -> Flags.equal flags flags'))))) ~handle_fd_read_ready:ignore ~handle_fd_write_ready:ignore with | exn -> raise_s [%message "Epoll_file_descr_watcher.invariant failed" (exn : exn) ~epoll_file_descr_watcher:(t : t)] ;; type 'a additional_create_args = timerfd:Linux_ext.Timerfd.t -> 'a let create ~timerfd ~num_file_descrs ~handle_fd_read_ready ~handle_fd_write_ready = let epoll = Or_error.ok_exn Epoll.create ~num_file_descrs ~max_ready_events:(Epoll_max_ready_events.raw Config.epoll_max_ready_events) in let err_or_hup = Flags.(hup + err) in let handle_fd read_or_write handle_fd = let bit = Flags.of_rw read_or_write in fun file_descr flags -> (* A difference between select and epoll crops up here: epoll has implicit event flags for hangup (HUP) and error (ERR), whereas select will just return that fd as "ready" in its appropriate fd_set. Since we don't know if it's ready for IN or OUT, we have to go lookup the entry if the HUP or ERR flag is set. *) if Flags.do_intersect flags bit || (Flags.do_intersect flags err_or_hup && Flags.do_intersect (Epoll.find_exn epoll file_descr) bit) then handle_fd file_descr in Epoll.set epoll (Timerfd.to_file_descr timerfd) Flags.for_timerfd; { timerfd ; epoll ; handle_fd_read_ready = handle_fd `Read handle_fd_read_ready ; handle_fd_write_ready = handle_fd `Write handle_fd_write_ready } ;; let reset_in_forked_process t = Epoll.close t.epoll let iter t ~f = Epoll.iter t.epoll ~f:(fun file_descr flags -> if not (is_timerfd t file_descr) then ( if Flags.do_intersect flags Flags.in_ then f file_descr `Read; if Flags.do_intersect flags Flags.out then f file_descr `Write)) ;; let set t file_descr desired = let actual_flags = Epoll.find t.epoll file_descr in let desired_flags = match desired.read, desired.write with | false, false -> None | true, false -> Some Flags.in_ | false, true -> Some Flags.out | true, true -> Some Flags.in_out in match actual_flags, desired_flags with | None, None -> `Ok | None, Some d -> (match Epoll.set t.epoll file_descr d with | exception Core_unix.Unix_error (EPERM, _, _) -> `Unsupported | () -> `Ok) | Some _, None -> Epoll.remove t.epoll file_descr; `Ok | Some a, Some d -> if not (Flags.equal a d) then Epoll.set t.epoll file_descr d; `Ok ;; module Pre = struct type t = unit [@@deriving sexp_of] end let pre_check _t = () module Check_result = struct type t = ([ `Ok | `Timeout ], exn * Backtrace.t) Result.t [@@deriving sexp_of] let ok = Ok `Ok let timeout = Ok `Timeout end let epoll_wait (type a) (epoll : Epoll.t) (timeout : a Timeout.t) (span_or_unit : a) = match timeout with | Immediately -> Epoll.wait epoll ~timeout:`Immediately | After -> Epoll.wait_timeout_after epoll span_or_unit ;; let thread_safe_check t () timeout span_or_unit = match epoll_wait t.epoll timeout span_or_unit with | `Ok -> Check_result.ok | `Timeout -> Check_result.timeout | exception e -> Error (e, Backtrace.Exn.most_recent ()) ;; let post_check t check_result = try match check_result with (* We think 514 should be treated like EINTR. *) | Error (Unix.Unix_error ((EINTR | EUNKNOWNERR 514), _, _), _) -> () | Error (exn, backtrace) -> raise_s [%message "epoll raised unexpected exn" (exn : exn) (backtrace : Backtrace.t)] | Ok `Timeout -> () | Ok `Ok -> Epoll.iter_ready t.epoll ~f:t.handle_fd_write_ready; Epoll.iter_ready t.epoll ~f:t.handle_fd_read_ready; Epoll.Expert.clear_ready t.epoll with | exn -> let backtrace = Backtrace.Exn.most_recent () in raise_s [%message "Epoll.post_check bug" (exn : exn) (backtrace : Backtrace.t) (check_result : Check_result.t) ~epoll_file_descr_watcher:(t : t)] ;; async_unix-0.15.0/src/epoll_file_descr_watcher.mli000066400000000000000000000003041420273305200222510ustar00rootroot00000000000000open! Core open! Import type 'a additional_create_args = timerfd:Linux_ext.Timerfd.t -> 'a include File_descr_watcher_intf.S with type 'a additional_create_args := 'a additional_create_args async_unix-0.15.0/src/fd.ml000066400000000000000000000262071420273305200154740ustar00rootroot00000000000000open Core open Import module Scheduler = Raw_scheduler module Fd = Raw_fd include Fd.T open Fd let debug = debug let is_closed = is_closed let is_open = is_open let syscall = syscall let syscall_exn = syscall_exn let syscall_result_exn = syscall_result_exn let with_file_descr = with_file_descr let with_file_descr_exn = with_file_descr_exn module Kind = struct include Fd.Kind let blocking_infer_using_stat file_descr = let st = Unix.fstat file_descr in match st.st_kind with | S_REG | S_DIR | S_BLK | S_LNK -> File | S_CHR -> Char | S_FIFO -> Fifo | S_SOCK -> Socket (if Unix.getsockopt file_descr SO_ACCEPTCONN then `Passive else `Active) ;; let infer_using_stat file_descr = In_thread.syscall_exn ~name:"fstat" (fun () -> blocking_infer_using_stat file_descr) ;; end let to_string t = Sexp.to_string_hum (sexp_of_t t) let the_one_and_only () = Scheduler.the_one_and_only () let create ?avoid_setting_nonblock kind file_descr info = Scheduler.create_fd ?avoid_setting_nonblock (the_one_and_only ()) kind file_descr info ;; (* We do not make [stdin], [stdout], or [stderr] nonblocking so that one can use Core I/O libraries simultaneously with async without them failing due to [Sys_blocked_io]. *) let create_std_descr file_descr info = create (Kind.blocking_infer_using_stat file_descr) file_descr info ~avoid_setting_nonblock:true ;; let stdin = Memo.unit (fun () -> create_std_descr Unix.stdin (Info.of_string "")) let stdout = Memo.unit (fun () -> create_std_descr Unix.stdout (Info.of_string "")) ;; let stderr = Memo.unit (fun () -> create_std_descr Unix.stderr (Info.of_string "")) ;; let supports_nonblock t = Fd.supports_nonblock t let clear_nonblock t = (* By setting [t.can_set_nonblock] to false we're making the user choice persistent: the next time a nonblocking operation is attempted it simply won't work, instead of ignoring the user choice and setting nonblock anyway *) t.can_set_nonblock <- false; match t.nonblock_status with | Blocking -> () | Nonblocking | Unknown -> t.nonblock_status <- Blocking; Unix.clear_nonblock t.file_descr ;; module Close = struct type socket_handling = | Shutdown_socket | Do_not_shutdown_socket type file_descriptor_handling = | Close_file_descriptor of socket_handling | Do_not_close_file_descriptor let close ?(file_descriptor_handling = Close_file_descriptor Shutdown_socket) t = if debug then Debug.log "Fd.close" t [%sexp_of: t]; (match t.state with | Close_requested _ | Closed -> () | Open close_started -> Ivar.fill close_started (); let do_close_syscall () = don't_wait_for (let%map () = match file_descriptor_handling with | Do_not_close_file_descriptor -> return () | Close_file_descriptor socket_handling -> Monitor.protect ~run: `Schedule ~rest:`Log ~finally:(fun () -> In_thread.syscall_exn ~name:"close" (fun () -> Unix.close t.file_descr)) (fun () -> match t.kind, socket_handling with | Socket `Active, Shutdown_socket -> In_thread.syscall_exn ~name:"shutdown" (fun () -> Unix.shutdown t.file_descr ~mode:SHUTDOWN_ALL) | _ -> return ()) in Ivar.fill t.close_finished ()) in let scheduler = the_one_and_only () in let kernel_scheduler = scheduler.kernel_scheduler in set_state t (Close_requested (Kernel_scheduler.current_execution_context kernel_scheduler, do_close_syscall)); (* Notify other users of this fd that it is going to be closed. *) Scheduler.request_stop_watching scheduler t `Read `Closed; Scheduler.request_stop_watching scheduler t `Write `Closed; (* If there are no syscalls in progress, then start closing the fd. *) Scheduler.maybe_start_closing_fd scheduler t); Ivar.read t.close_finished ;; end include Close let close_finished t = Ivar.read t.close_finished let close_started t = match t.state with | Open close_started -> Ivar.read close_started | Close_requested _ | Closed -> return () ;; let create_borrowed ?avoid_setting_nonblock kind file_descr info ~f = let fd = create ?avoid_setting_nonblock kind file_descr info in Monitor.protect ~run:`Schedule ~rest:`Log ~name:"Fd.create_borrowed" (fun () -> f fd) ~finally:(fun () -> close ~file_descriptor_handling:Do_not_close_file_descriptor fd) ;; let with_close t ~f = Monitor.protect ~run:`Schedule ~rest:`Log (fun () -> f t) ~finally:(fun () -> close t) ;; let with_file_descr_deferred t f = match inc_num_active_syscalls t with | `Already_closed -> return `Already_closed | `Ok -> let%map result = Monitor.try_with ~run: `Schedule ~rest:`Log (fun () -> f t.file_descr) in Scheduler.dec_num_active_syscalls_fd (the_one_and_only ()) t; (match result with | Ok x -> `Ok x | Error e -> `Error e) ;; let with_file_descr_deferred_exn t f = match%map with_file_descr_deferred t f with | `Ok x -> x | `Error exn -> raise exn | `Already_closed -> raise_s [%message "Fd.with_file_descr_deferred_exn got closed fd" ~_:(t : t_hum)] ;; let start_watching t read_or_write watching = if debug then Debug.log "Fd.start_watching" (t, read_or_write) [%sexp_of: t * Read_write_pair.Key.t]; let r = the_one_and_only () in match Scheduler.request_start_watching r t read_or_write watching with | (`Unsupported | `Already_closed | `Watching) as x -> x | `Already_watching -> raise_s [%message "cannot watch an fd already being watched" ~fd:(t : t) ~scheduler:(r : Scheduler.t)] ;; let stop_watching_upon_interrupt t read_or_write ivar ~interrupt = upon (choose [ choice interrupt (fun () -> `Interrupted) ; choice (Ivar.read ivar) (fun _ -> `Not_interrupted) ]) (function | `Not_interrupted -> () | `Interrupted -> if Ivar.is_empty ivar then Scheduler.request_stop_watching (the_one_and_only ()) t read_or_write `Interrupted) ;; let interruptible_ready_to t read_or_write ~interrupt = if debug then Debug.log "Fd.interruptible_ready_to" (t, read_or_write) [%sexp_of: t * Read_write_pair.Key.t]; let ready = Ivar.create () in match start_watching t read_or_write (Watch_once ready) with | `Already_closed -> return `Closed | `Unsupported -> return (if Deferred.is_determined interrupt then `Interrupted else `Ready) | `Watching -> stop_watching_upon_interrupt t read_or_write ready ~interrupt; Deferred.map (Ivar.read ready) ~f:(function | `Unsupported -> if Deferred.is_determined interrupt then `Interrupted else `Ready | (`Bad_fd | `Closed | `Interrupted | `Ready) as res -> res) ;; let ready_to t read_or_write = if debug then Debug.log "Fd.ready_to" (t, read_or_write) [%sexp_of: t * Read_write_pair.Key.t]; let ready = Ivar.create () in match start_watching t read_or_write (Watch_once ready) with | `Already_closed -> return `Closed | `Unsupported -> return `Ready | `Watching -> (match%map Ivar.read ready with | `Unsupported -> `Ready | (`Bad_fd | `Closed | `Ready) as x -> x | `Interrupted -> (* impossible *) assert false) ;; let interruptible_every_ready_to t read_or_write ~interrupt f x = if debug then Debug.log "Fd.interruptible_every_ready_to" (t, read_or_write) [%sexp_of: t * Read_write_pair.Key.t]; let job = Scheduler.(create_job (t ())) f x in let finished = Ivar.create () in match start_watching t read_or_write (Watch_repeatedly (job, finished)) with | `Already_closed -> return `Closed | `Unsupported -> return `Unsupported | `Watching -> stop_watching_upon_interrupt t read_or_write finished ~interrupt; (Ivar.read finished :> [ `Bad_fd | `Closed | `Unsupported | `Interrupted ] Deferred.t) ;; let every_ready_to t read_or_write f x = if debug then Debug.log "Fd.every_ready_to" (t, read_or_write) [%sexp_of: t * Read_write_pair.Key.t]; let job = Scheduler.(create_job (t ())) f x in let finished = Ivar.create () in match start_watching t read_or_write (Watch_repeatedly (job, finished)) with | `Already_closed -> return `Closed | `Unsupported -> return `Unsupported | `Watching -> (match%map Ivar.read finished with | (`Unsupported | `Bad_fd | `Closed) as x -> x | `Interrupted -> (* impossible *) assert false) ;; let syscall_in_thread t ~name f = match%map with_file_descr_deferred t (fun file_descr -> In_thread.syscall ~name (fun () -> f file_descr)) with | `Error e -> (* [In_thread.syscall] catches any exceptions [f] can raise, so this can only be reached when there's something wrong with the [In_thread] machinery itself. *) raise_s [%message "Fd.syscall_in_thread problem -- please report this" name ~_:(e : exn)] | `Already_closed -> `Already_closed | `Ok x -> (match x with | Ok x -> `Ok x | Error exn -> `Error exn) ;; let syscall_in_thread_exn t ~name f = match%map syscall_in_thread t ~name f with | `Ok x -> x | `Error exn -> raise exn | `Already_closed -> raise_s [%message "Fd.syscall_in_thread_exn of a closed fd" name ~_:(t : t_hum)] ;; let of_in_channel ic kind = create kind (Unix.descr_of_in_channel ic) (Info.of_string "") ;; let of_out_channel oc kind = create kind (Unix.descr_of_out_channel oc) (Info.of_string "") ;; let of_in_channel_auto ic = Kind.infer_using_stat (Unix.descr_of_in_channel ic) >>| of_in_channel ic ;; let of_out_channel_auto oc = Kind.infer_using_stat (Unix.descr_of_out_channel oc) >>| of_out_channel oc ;; let file_descr_exn t = if is_closed t then raise_s [%message "Fd.file_descr_exn on already closed fd" ~_:(t : t)] else t.file_descr ;; let to_int_exn t = File_descr.to_int (file_descr_exn t) let expect_file_descr_redirection_for_fd fd ~f = if fd.num_active_syscalls > 0 then raise_s [%sexp "File descriptor can't be redirected while in use", (fd : t)]; Exn.protect ~f ~finally:(fun () -> fd.kind <- Kind.blocking_infer_using_stat fd.file_descr) ;; let expect_file_descr_redirection file_descr ~f = let fd_by_descr = Raw_scheduler.fd_by_descr (the_one_and_only ()) in match Fd_by_descr.find fd_by_descr file_descr with | None -> f () | Some fd -> expect_file_descr_redirection_for_fd fd ~f ;; module Private = struct let replace t kind info = if is_closed t then raise_s [%message "Fd.replace got closed fd" ~fd:(t : t) (kind : Kind.t) ~scheduler:(the_one_and_only () : Scheduler.t)] else ( t.kind <- kind; t.info <- (match info with | `Set i -> i | `Extend i -> Info.create "replaced" (i, `previously_was t.info) [%sexp_of: Info.t * [ `previously_was of Info.t ]])) ;; end async_unix-0.15.0/src/fd.mli000066400000000000000000000331171420273305200156430ustar00rootroot00000000000000(** An [Fd.t] is a wrapper around a Unix file descriptor, with additional information about the kind of file descriptor and logic to ensure that we don't use a file descriptor that has been closed, or close a file descriptor that is in use. Since Async uses multiple threads to make read/write and other system calls on file descriptors, and Unix reuses descriptors after they are closed, Async has to be very careful that the file descriptor passed to a system call is referring to the file it intends, and not some other completely unrelated file that Unix has decided to assign to the same descriptor. Provided that one only accesses a file descriptor within the context of the functions below, [Fd] guarantees that the file descriptor will not have been closed/reused and will correspond to the same file that it did when the [Fd.t] was created: {v with_file_descr with_file_descr_deferred syscall syscall_exn syscall_result_exn syscall_in_thread syscall_in_thread_exn v} The [Fd] module keeps track of which of these functions are currently accessing the file descriptor, and ensures that any close happens after they complete. Also, once close has been called, it refuses to provide further access to the file descriptor, either by returning a variant [`Already_closed] or by raising an exception. Some of the above functions take an optional [?nonblocking:bool] argument. The default is [false], but if it is set to [true], then before supplying the underlying [file_descr], the [Fd] module will first call [Unix.set_nonblock file_descr], if it hasn't previously done so on that file descriptor. This is intended to support making nonblocking system calls (e.g., connect, read, write) directly within Async, without releasing the OCaml lock or the Async lock, and without using another thread. *) open! Core open! Import module Kind : sig type t = | Char (** a terminal *) | Fifo (** a pipe *) | File (** a regular file *) | Socket of [ `Unconnected (** the result of [socket()] *) | `Bound (** the result of [bind()] *) | `Passive (** the result of [listen()] *) | `Active (** the result of [connect()] or [accept()] *) ] [@@deriving sexp_of] val infer_using_stat : Unix.File_descr.t -> t Deferred.t end type t [@@deriving sexp_of] type t_hum = t [@@deriving sexp_of] val info : t -> Info.t (** [to_string t] returns a pretty sexp of the representation of [t]. *) val to_string : t -> string (** [create ?support_nonblock kind file_descr] creates a new [t] of the underlying kind and file descriptor. We thought about using [fstat()] rather than requiring the user to supply the kind. But [fstat] can block, which would require putting this in a thread, which has some consequences, and it isn't clear that it gets us that much. Also, [create] is mostly used within the Async implementation -- clients shouldn't need it unless they are mixing Async and non-Async code. If [avoid_setting_nonblock], then Async will not set nonblock flag on the file descriptor. The fd will be used in accordance with the existing flag. *) val create : ?avoid_setting_nonblock:bool (** default is [false] *) -> Kind.t -> Unix.File_descr.t -> Info.t -> t (** [create_borrowed kind descr info ~f] borrows a file descriptor that is not managed by Async, creates an [Fd.t] (see [create]), and runs [f] that uses that fd in async. After [f] is finished (or raises an exception), it returns the file descriptor to its original owner (leaving [Fd.t] in a closed state, but not closing [descr]). The caller must not close [descr] while [create_borrowed] is running. *) val create_borrowed : ?avoid_setting_nonblock:bool (** default is [false] *) -> Kind.t -> Unix.File_descr.t -> Info.t -> f:(t -> 'a Deferred.t) -> 'a Deferred.t (** [kind t] returns the kind of file descriptor that [t] is. *) val kind : t -> Kind.t (** [supports_nonblock t] returns true if [t] supports nonblocking system calls. *) val supports_nonblock : t -> bool (** [clear_nonblock t] clears the [nonblocking] flag on [t] and causes Async to treat the fd as though it doesn't support nonblocking I/O. This is useful for applications that want to share a file descriptor between Async and non-Async code and want to avoid [EWOULDBLOCK] or [EAGAIN] being seen by the non-Async code, which would then cause a [Sys_blocked_io] exception. [clear_nonblock t] has no effect if [not (supports_nonblock t)]. *) val clear_nonblock : t -> unit (** The [Close] module exists to collect [close] and its associated types, so they can be easily reused elsewhere, e.g., [Unix_syscalls]. *) module Close : sig type socket_handling = | Shutdown_socket | Do_not_shutdown_socket type file_descriptor_handling = | Close_file_descriptor of socket_handling | Do_not_close_file_descriptor (** [close t] prevents further use of [t], and makes [shutdown()] and [close()] system calls on [t]'s underlying file descriptor according to the [file_descriptor_handling] argument and whether or not [t] is a socket, i.e., [kind t = Socket `Active]: {v | file_descriptor_handling | shutdown() | close() | |----------------------------------------------+------------+---------| | Do_not_close_file_descriptor | no | no | | Close_file_descriptor Shutdown_socket | if socket | yes | | Close_file_descriptor Do_not_shutdown_socket | no | yes | v} The result of [close] becomes determined once the system calls complete. It is OK to call [close] multiple times on the same [t]; calls subsequent to the initial call will have no effect, but will return the same deferred as the original call. *) val close : ?file_descriptor_handling:file_descriptor_handling (** default is [Close_file_descriptor Shutdown_socket] *) -> t -> unit Deferred.t end include module type of Close (** [close_started t] becomes determined when [close t] is called. *) val close_started : t -> unit Deferred.t (** [close_finished] returns the same result as [close], but differs in that it does not have the side effect of initiating a close. *) val close_finished : t -> unit Deferred.t (** [is_closed t] returns [true] iff [close t] has been called. *) val is_closed : t -> bool (** [with_close t f] applies [f] to [t], returns the result of [f], and closes [t]. *) val with_close : t -> f:(t -> 'a Deferred.t) -> 'a Deferred.t (** [is_open t] is [not (is_closed t]) *) val is_open : t -> bool (** [stdin], [stdout], and [stderr] are wrappers around the standard Unix file descriptors. *) val stdin : unit -> t val stdout : unit -> t val stderr : unit -> t (** [with_file_descr t f] runs [f] on the file descriptor underlying [t], if [is_open t], and returns [`Ok] or [`Error] according to [f]. If [is_closed t], then it does not call [f] and returns [`Already_closed]. *) val with_file_descr : ?nonblocking:bool (** default is [false] *) -> t -> (Unix.File_descr.t -> 'a) -> [ `Ok of 'a | `Already_closed | `Error of exn ] (** [with_file_descr_exn] is like [with_file_descr] except that it raises rather than return [`Already_closed] or [`Error]. *) val with_file_descr_exn : ?nonblocking:bool (** default is [false] *) -> t -> (Unix.File_descr.t -> 'a) -> 'a (** [with_file_descr_deferred t f] runs [f] on the file descriptor underlying [t], if [is_open t], and returns [`Ok] or [`Error] according to [f]. If [is_closed t], then it does not call [f] and returns [`Already_closed]. It ensures that the file descriptor underlying [t] is not closed until the result of [f] becomes determined (or [f] raises). *) val with_file_descr_deferred : t -> (Unix.File_descr.t -> 'a Deferred.t) -> [ `Ok of 'a | `Already_closed | `Error of exn ] Deferred.t (** [with_file_descr_deferred_exn] is like [with_file_descr_deferred], except that it raises rather than return [`Already_closed] or [`Error]. *) val with_file_descr_deferred_exn : t -> (Unix.File_descr.t -> 'a Deferred.t) -> 'a Deferred.t (** [interruptible_ready_to t read_write ~interrupt] returns a deferred that will become determined when the file descriptor underlying [t] can be read from or written to without blocking, or when [interrupt] becomes determined. It's an error to make multiple concurrent calls to [*ready_to] functions on the same file descriptor. *) val interruptible_ready_to : t -> [ `Read | `Write ] -> interrupt:unit Deferred.t -> [ `Bad_fd | `Closed | `Interrupted | `Ready ] Deferred.t (** [ready_to t read_write] is like [interruptible_ready_to], but without the possibility of interruption. *) val ready_to : t -> [ `Read | `Write ] -> [ `Bad_fd | `Closed | `Ready ] Deferred.t (** [interruptible_every_ready_to t read_write ~interrupt f a] checks every Async cycle whether the file descriptor underlying [t] can be read from or written to without blocking, and if so, enqueues a job to run [f a]. [interruptible_every_ready_to] is level triggered -- it will enqueue a job every cycle if I/O is available, even if the prior job hasn't run yet, or the job ran but did not consume the available data. [interruptible_every_ready_to] returns a deferred that will become determined when [interrupt] becomes determined or the file descriptor is closed. *) val interruptible_every_ready_to : t -> [ `Read | `Write ] -> interrupt:unit Deferred.t -> ('a -> unit) -> 'a -> [ `Bad_fd | `Closed | `Unsupported | `Interrupted ] Deferred.t (** [every_ready_to t read_write f x] is like [interruptible_every_ready_to], but without the possibility of interruption. *) val every_ready_to : t -> [ `Read | `Write ] -> ('a -> unit) -> 'a -> [ `Bad_fd | `Closed | `Unsupported ] Deferred.t (** [syscall t f] runs [Async_unix.syscall] with [f] on the file descriptor underlying [t], if [is_open t], and returns [`Ok] or [`Error] according to [f]. If [is_closed t], it does not call [f] and returns [`Already_closed]. *) val syscall : ?nonblocking:bool (** default is [false] *) -> t -> (Unix.File_descr.t -> 'a) -> [ `Already_closed | `Ok of 'a | `Error of exn ] (** [syscall_exn t f] is like [syscall], except it raises rather than return [`Already_closed] or [`Error]. *) val syscall_exn : ?nonblocking:bool (** default is [false] *) -> t -> (Unix.File_descr.t -> 'a) -> 'a (** [syscall_result_exn t f a] is like [syscall_exn], except it does not allocate except in exceptional cases. [a] is passed unchanged to [f], and should be used to eliminate allocations due to closure capture. *) val syscall_result_exn : ?nonblocking:bool (** default is [false] *) -> t -> 'a -> (Unix.File_descr.t -> 'a -> 'b Unix.Syscall_result.t) -> 'b Unix.Syscall_result.t (** [syscall_in_thread t f] runs [In_thread.syscall] with [f] on the file descriptor underlying [t], if [is_open t], and returns a deferred that becomes determined with [`Ok] or [`Error] when the system call completes. If [is_closed t], it does not call [f] and returns [`Already_closed]. *) val syscall_in_thread : t -> name:string -> (Unix.File_descr.t -> 'a) -> [ `Already_closed | `Ok of 'a | `Error of exn ] Deferred.t (** [syscall_in_thread_exn] is like [syscall_in_thread], except it raises rather than return [`Already_closed] or [`Error]. *) val syscall_in_thread_exn : t -> name:string -> (Unix.File_descr.t -> 'a) -> 'a Deferred.t (** [of_in_channel] and [of_out_channel] create an fd from their underlying file descriptor. *) val of_in_channel : In_channel.t -> Kind.t -> t val of_out_channel : Out_channel.t -> Kind.t -> t (** [of_in_channel_auto ic] is just like [of_in_channel], but uses [fstat] to determine the kind. It makes some assumptions about sockets, specifically it assumes that a socket is either listening or connected to something (and it uses [getsockopt] to find out which). Don't pass an [in_channel] containing an unconnected non-listening socket. *) val of_in_channel_auto : In_channel.t -> t Deferred.t (** [of_out_channel_auto ic] is just like [of_out_channel], but uses [fstat] to determine the kind. It makes some assumptions about sockets, specifically it assumes that a socket is either listening or connected to something (and it uses [getsockopt] to find out which). Don't pass an [in_channel] containing an unconnected non listening socket. *) val of_out_channel_auto : Out_channel.t -> t Deferred.t (** [file_descr_exn t] returns the file descriptor underlying [t], unless [is_closed t], in which case it raises. One must be very careful when using this function, and should try not to, since any uses of the resulting file descriptor are unknown to the [Fd] module, and hence can violate the guarantee it is trying to enforce. *) val file_descr_exn : t -> Unix.File_descr.t (** [to_int_exn t] returns the the underlying file descriptor as an int. It has the same caveats as [file_descr_exn]. *) val to_int_exn : t -> int (**/**) (** Run a function [f] with the expectation that it's going to redirect the file descriptor, thereby possibly changing its kind. *) val expect_file_descr_redirection : Unix.File_descr.t -> f:(unit -> 'a) -> 'a module Private : sig (** [replace t kind] is for internal use only, by [Unix_syscalls]. It is used when one wants to reuse a file descriptor in an fd with a new kind. *) val replace : t -> Kind.t -> [ `Set of Info.t | `Extend of Info.t ] -> unit end async_unix-0.15.0/src/fd_by_descr.ml000066400000000000000000000065061420273305200173460ustar00rootroot00000000000000open Core open Import module Fd = Raw_fd type t = Fd.t Option_array.t let capacity t = Option_array.length t let create ~num_file_descrs = if num_file_descrs < 0 then raise_s [%message "[Fd_by_descr.create] got negative [num_file_descrs]" (num_file_descrs : int)]; Option_array.create ~len:num_file_descrs ;; let bounds_check t file_descr = let i = file_descr |> File_descr.to_int in 0 <= i && i < capacity t ;; let bounds_check_error t file_descr = [%message "The file descriptor is not in the range that Async allows, which probably means \ that the program has created too many file descriptors without closing them. You \ can cause Async to allow more file descriptors via the [ASYNC_CONFIG] environment \ variable, like this: ASYNC_CONFIG='((max_num_open_file_descrs ))' foo.exe \ arg1 arg2 ..." (file_descr : File_descr.t) ~min_file_descr:0 ~max_file_descr:(capacity t - 1 : int)] ;; let bounds_check_exn t file_descr = if not (bounds_check t file_descr) then raise_s (bounds_check_error t file_descr) ;; let mem t file_descr = bounds_check t file_descr && Option_array.is_some t (file_descr |> File_descr.to_int) ;; let find t file_descr = if not (bounds_check t file_descr) then None else Option_array.get t (file_descr |> File_descr.to_int) ;; let find_exn t file_descr = bounds_check_exn t file_descr; if Option_array.is_none t (file_descr |> File_descr.to_int) then raise_s [%message "[Fd_by_descr.find_exn] got unknown file_descr" (file_descr : File_descr.t)]; Option_array.get_some_exn t (file_descr |> File_descr.to_int) ;; let remove t (fd : Fd.t) = bounds_check_exn t fd.file_descr; Option_array.set_none t (fd.file_descr |> File_descr.to_int) ;; let add t (fd : Fd.t) = let file_descr = fd.file_descr in if not (bounds_check t file_descr) then error_s (bounds_check_error t file_descr) else if Option_array.is_some t (file_descr |> File_descr.to_int) then error_s [%message "Attempt to register a file descriptor with Async that Async believes it is \ already managing."] else ( Option_array.set_some t (file_descr |> File_descr.to_int) fd; Ok ()) ;; let fold t ~init ~f = let r = ref init in for i = 0 to capacity t - 1 do if Option_array.is_some t i then r := f !r (Option_array.get_some_exn t i) done; !r ;; let foldi t ~init ~f = let r = ref init in for i = 0 to capacity t - 1 do if Option_array.is_some t i then r := f i !r (Option_array.get_some_exn t i) done; !r ;; let iter t ~f = for i = 0 to capacity t - 1 do if Option_array.is_some t i then f (Option_array.get_some_exn t i) done ;; let exists t ~f = Option_array.exists t ~f:(function | None -> false | Some x -> f x) ;; (* The default sexp representation of this is huge and pollutes debug output *) let sexp_of_t t = let fd_alist = foldi ~init:[] t ~f:(fun i acc fd -> (i, fd) :: acc) in [%sexp_of: (int * Fd.t) list] (List.rev fd_alist) ;; let invariant t = try for i = 0 to capacity t - 1 do match Option_array.get t i with | None -> () | Some fd -> Fd.invariant fd; assert (File_descr.equal (i |> File_descr.of_int) (Fd.file_descr fd)) done with | exn -> raise_s [%message "Fd_by_descr.invariant failure" (exn : exn) ~fd:(t : t)] ;; async_unix-0.15.0/src/fd_by_descr.mli000066400000000000000000000013441420273305200175120ustar00rootroot00000000000000(** [Fd_by_descr] is a table of the open [Fd.t]s, indexed by file descriptor number. In this interface, we use [Raw_fd.t] rather than [Fd.t] to avoid a dependency cycle, because the [Fd] module can't be defined yet. *) open! Core open! Import type t [@@deriving sexp_of] include Invariant.S with type t := t val create : num_file_descrs:int -> t val capacity : t -> int val add : t -> Raw_fd.t -> unit Or_error.t val mem : t -> File_descr.t -> bool val find : t -> File_descr.t -> Raw_fd.t option val find_exn : t -> File_descr.t -> Raw_fd.t val remove : t -> Raw_fd.t -> unit val fold : t -> init:'a -> f:('a -> Raw_fd.t -> 'a) -> 'a val iter : t -> f:(Raw_fd.t -> unit) -> unit val exists : t -> f:(Raw_fd.t -> bool) -> bool async_unix-0.15.0/src/file_descr_watcher_intf.ml000066400000000000000000000101751420273305200217340ustar00rootroot00000000000000(** [File_descr_watcher_intf.S] provides an API for for watching a set of file descriptors to see if they are ready for reading or writing. We have two implementations, one using epoll, and one using select. None of the functions need to be thread-safe, with the exception of [thread_safe_check]. So that implementations can easily do non-thread-safe actions, checking for ready I/O is always done in three steps: 1. [pre_check], while holding the async lock 2. [thread_safe_check], while not holding the async lock 3. [post_check], while holding the async lock *) open! Core open Import module Timeout = struct type 'a t = (*_ performance hack: avoid allocation *) | Immediately : unit t | After : Time_ns.Span.t t let variant_of : type a. a t -> a -> [ `Immediately | `After of Time_ns.Span.t ] = fun t span_or_unit -> match t with | Immediately -> `Immediately | After -> `After (span_or_unit : Time_ns.Span.t) ;; end module type S = sig (** A file-descr-watcher is essentially a map from [File_descr.t] to [bool Read_write_pair.t], which defines the set of file descriptors being watched, and for each file descriptor, whether it is being watched for read, write, or both. If a file descriptor is not being watched for either, it is not in the map. *) type t [@@deriving sexp_of] include Invariant.S with type t := t (** [additional_create_args] abstracts over the additional arguments to different file-descr-watcher's [create] function. *) type 'a additional_create_args (** [create ~num_file_descrs] creates a new file-descr-watcher that is able to watch file descriptors in {[ [0, num_file_descrs) ]}. *) val create : (num_file_descrs:int -> handle_fd_read_ready:(File_descr.t -> unit) -> handle_fd_write_ready:(File_descr.t -> unit) -> t) additional_create_args val backend : Config.File_descr_watcher.t (** [set] alters the map of file descriptors being watched. It will take effect on the next call to [thread_safe_check]. Calling [set fd] with [{ read = false, write = false }] removes [fd] from the map. [`Unsupported] can be returned for file descriptors that do not support polling. This usually (always?) means that they are always ready for read or write. *) val set : t -> File_descr.t -> bool Read_write_pair.t -> [ `Ok | `Unsupported ] (** [iter t ~f] iterates over every file descriptor in the map, apply [f] to it once for each of \{`Read,`Write\} that it is being watched for. *) val iter : t -> f:(File_descr.t -> Read_write_pair.Key.t -> unit) -> unit (** [pre_check t] does whatever non-thread-safe work is necessary to prepare for the system call that checks file descriptors being ready for read or write. [pre_check] does not side effect [t]. *) module Pre : sig type t [@@deriving sexp_of] end val pre_check : t -> Pre.t (** [thread_safe_check t pre timeout span_or_unit] checks the file descriptors for their status and returns when at least one is available, or the [timeout, span_or_unit] passes. [thread_safe_check] does not side effect [t]. Unlike the rest of the functions in this module, [thread_safe_check] is thread safe. *) module Check_result : sig type t [@@deriving sexp_of] end val thread_safe_check : t -> Pre.t -> 'a Timeout.t -> 'a -> Check_result.t (** [post_check t check_result] calls the [handle_fd*] functions supplied to [create]: 1. for each file descriptor that is ready to be written to, then 2. for each file descriptor that is ready to be read from. We handle writes before reads so that we get all the writes started going to the external world before we process all the reads. This will nicely batch together all the output based on the reads for the next writes. It is guaranteed that it calls [handle_fd_read*] only on an [fd] that is watched for read as per [set], and [handle_fd_write*] only on an [fd] that is watched for write as per [set]. *) val post_check : t -> Check_result.t -> unit val reset_in_forked_process : t -> unit end async_unix-0.15.0/src/import.ml000066400000000000000000000016001420273305200164030ustar00rootroot00000000000000open Core module Unix = Core_unix module Thread = Core_thread module Time = Time_unix module Time_ns = Time_ns_unix include Int.Replace_polymorphic_compare include Async_kernel module Epoll_max_ready_events = Config.Epoll_max_ready_events module Max_inter_cycle_timeout = Config.Max_inter_cycle_timeout module Max_num_open_file_descrs = Config.Max_num_open_file_descrs module Max_num_threads = Config.Max_num_threads module Min_inter_cycle_timeout = Config.Min_inter_cycle_timeout module Debug = Async_kernel_private.Debug module Job = Async_kernel_private.Job module Kernel_scheduler = Async_kernel_scheduler.Private module File_descr = Unix.File_descr let print_s sexp = Core.printf "%s\n%!" (sexp |> Sexp.to_string_hum) let am_test_runner = Base.Exported_for_specific_uses.am_testing let () = if Async_kernel_config.Print_debug_messages_for.thread_pool then Thread_pool.debug := true ;; async_unix-0.15.0/src/in_thread.ml000066400000000000000000000132351420273305200170350ustar00rootroot00000000000000open Core open Import open Raw_scheduler module Priority = Linux_ext.Priority module When_finished = struct type t = | Notify_the_scheduler | Take_the_async_lock | Try_to_take_the_async_lock [@@deriving enumerate, sexp_of] let default = ref Try_to_take_the_async_lock end let run_after_scheduler_is_started ~priority ~thread ~(when_finished : When_finished.t) ~name ~t f = let ivar = Ivar.create () in let doit () = (* At this point, we are in a thread-pool thread, not the async thread. *) let result = Result.try_with f in let locked = match when_finished with | Take_the_async_lock -> lock t; true | Notify_the_scheduler -> false | Try_to_take_the_async_lock -> (match thread_pool_cpu_affinity t with | Inherit -> try_lock t | Cpuset _ -> (* If the user specified an affinity for the thread pool, they presumably intend for Async jobs to be affinitized differently from thread-pool threads, so we don't even attempt to run jobs on the thread-pool thread. *) false) in if locked then protect ~finally:(fun () -> unlock t) ~f:(fun () -> Ivar.fill ivar result; have_lock_do_cycle t) else thread_safe_enqueue_external_job t (current_execution_context t) (fun () -> Ivar.fill ivar result) () in (match thread with | None -> ok_exn (Thread_pool.add_work t.thread_pool doit ?name ?priority); if Thread_pool.num_threads t.thread_pool = 0 then raise_s [%message "Async's thread pool was unable to create a single thread" ~_: (Thread_pool.last_thread_creation_failure t.thread_pool : (Sexp.t option[@sexp.option]))] | Some helper_thread -> ok_exn (Thread_pool.add_work_for_helper_thread t.thread_pool helper_thread doit ?name ?priority)); Ivar.read ivar >>| Result.ok_exn ;; let run ?priority ?thread ?(when_finished = !When_finished.default) ?name f = match !Raw_scheduler.the_one_and_only_ref with | Initialized t when t.is_running -> run_after_scheduler_is_started ~priority ~thread ~when_finished ~name ~t f | _ -> (* We use [bind unit ...] to force calls to [run_after_scheduler_is_started] to wait until after the scheduler is started. We do this because [run_after_scheduler_is_started] will cause things to run in other threads, and when a job is finished in another thread, it will try to acquire the async lock and manipulate async datastructures. This seems hard to think about if async hasn't even started yet. *) Deferred.bind (return ()) ~f:(fun () -> run_after_scheduler_is_started ~priority ~thread ~when_finished ~name ~t:(Raw_scheduler.t ()) f) ;; module Helper_thread = struct (* A wrapper around [Thread_pool]'s helper thread, so we can attach a finalizer. *) type t = { thread_pool_helper_thread : Thread_pool.Helper_thread.t } [@@deriving fields, sexp_of] (* Both [create] and [create_now] add Async finalizers to the returned helper thread so that the thread can be added back to the set of worker threads when there are no references to the helper thread and the thread has no pending work. Because [Thread_pool.finished_with_helper_thread] needs to acquire the thread pool lock, it cannot be run within an ordinary finalizer, since that could cause it to be run in a context where the code interrupted by the GC might already be holding the thread pool lock, which would result in a deadlock. Hence we use an Async finalizer -- this causes the GC to merely schedule an Async job that calls [Thread_pool.finished_with_helper_thread]. We don't attach the finalizer inside [Thread_pool] because the thread pool doesn't know about Async, and in particular doesn't know about Async finalizers. *) let create_internal scheduler thread_pool_helper_thread = let finalize { thread_pool_helper_thread } = Thread_pool.finished_with_helper_thread scheduler.thread_pool thread_pool_helper_thread in let t = { thread_pool_helper_thread } in add_finalizer_exn scheduler t finalize; t ;; let create_now ?priority ?name () = let scheduler = the_one_and_only () in Result.map (Thread_pool.create_helper_thread scheduler.thread_pool ?name ?priority) ~f:(fun helper_thread -> create_internal scheduler helper_thread) ;; let create ?priority ?name () = let scheduler = the_one_and_only () in let%map helper_thread = run (fun () -> Thread_pool.become_helper_thread scheduler.thread_pool ?name ?priority) in create_internal scheduler (ok_exn helper_thread) ;; end let run ?priority ?thread ?when_finished ?name f = let thread = Option.map thread ~f:Helper_thread.thread_pool_helper_thread in run ?priority ?thread ?when_finished ?name f ;; let syscall ~name f = run ~name (fun () -> Syscall.syscall f) let syscall_exn ~name f = run ~name (fun () -> Result.ok_exn (Syscall.syscall f)) let pipe_of_squeue sq = let r, w = Pipe.create () in (* The functions are defined to avoid unnecessary allocation. *) let pull () = let q = Linked_queue.create () in Squeue.transfer_queue sq q; q in let rec continue q = Linked_queue.iter q ~f:(Pipe.write_without_pushback w); Pipe.pushback w >>> loop (* [run pull] runs [pull] in a thread, because [Squeue.transfer_queue] can block. *) and loop () = run pull >>> continue in loop (); r ;; async_unix-0.15.0/src/in_thread.mli000066400000000000000000000130531420273305200172040ustar00rootroot00000000000000(** The [In_thread] module has functions for interaction between the Async world and other (kernel) threads. The name is to remind us to think about threads and race conditions. All threads come from the one thread pool used for all Async-managed threads. *) open! Core open Async_kernel module Priority : module type of Linux_ext.Priority with type t = Linux_ext.Priority.t module Helper_thread : sig (** A Helper_thread is a thread that is dedicated to handling computations external to Async. We need them because some libraries (e.g. Sqlite3) require that certain collections of computations run in the same thread. *) type t (** [create ?name ()] creates a new helper thread. The [name] will be used as the thread name for any work that that is done by the thread that doesn't get its own name. [create] uses a thread from Async's thread pool, reserving that thread for exclusive use by the helper thread until the helper thread is no longer used (specifically, finalized and is finished with all its work), at which point the thread is made available for general use by the pool. [create] returns a deferred that becomes determined when a helper thread is available. On the other hand, [create_now] checks if a helper thread is available now, and if so returns it, or else returns [Error]. *) val create : ?priority:Priority.t -> ?name:string -> unit -> t Deferred.t val create_now : ?priority:Priority.t -> ?name:string -> unit -> t Or_error.t end (** [pipe_of_squeue squeue] returns a pipe [p] and consumes the contents [squeue], placing them in [p]. It repeatedly grabs everything from [squeue], places it in [p], and then waits for pushback on [p]. *) val pipe_of_squeue : 'a Squeue.t -> 'a Pipe.Reader.t (** [When_finished] describes how [In_thread.run f] behaves when the helper thread finishes [f ()]. *) module When_finished : sig type t = | Notify_the_scheduler (** The helper thread notifies the Async scheduler that the result is ready, so that the scheduler will wake up in a timely manner and run a cycle. *) | Take_the_async_lock (** The helper thread blocks until it can acquire the Async lock, at which point it runs a cycle. *) | Try_to_take_the_async_lock (** If the [thread_pool_cpu_affinity] is [Inherit], then the helper hread tries to take the Async lock and run a cycle. If the [thread_pool_cpu_affinity] is [Cpuset] or the helper thread is unable to acquire the Async lock, then it behaves as in [Notify_the_scheduler]. *) [@@deriving enumerate, sexp_of] (** [default] defines the default value used for [In_thread.run]'s [?when_finished] argument. Changes to [default] affect subsequent calls to [In_thread.run]. Initially, [default = Try_to_take_the_async_lock], which typically leads to better latency by avoiding an extra context switch to pass the result to the Async scheduler thread. However, there are applications (e.g. jenga) where [Notify_the_scheduler] leads to significantly higher throughput by greatly decreasing the total number of Async cycles. *) val default : t ref end (** [run ?priority ?thread ?name f] runs [f ()] in a separate thread outside Async and returns the result as a Deferred in the Async world. If [f ()] raises an exception (asynchronously, since it is another thread) then that exception will be raised to the monitor that called [run]. WARNING: Async code MUST NOT be used from within [f]. By Async code we mean pretty-much all functions of libraries making use of Async. Only a few functions of the Async library can be called inside [In_thread.run]. These are explicitly marked as such, using the phrase "thread-safe". If [thread] is not supplied, then any thread from the thread pool could be used. If you need to run routines in a specific thread (as is required by some libraries like Sqlite), you should create a helper thread and supply it to [run]. If [priority] is supplied, the priority of the thread in the linux scheduler will be set to [priority] for the duration of [f ()], provided the thread is allowed to do so (see [man setpriority]). If you call [run] several times with the same helper thread, the [f ()] calls will run in sequence, in the order in which they are supplied to [run]. Each [f ()] will complete (return or raise) before another [f ()] starts. For example, if you do: {[ let () = run ~thread f1; run ~thread f2; run ~thread f3; ]} Then the thread will run [f1 ()] to completion, then [f2 ()] to completion, then [f3 ()] to completion. If [name] is supplied, the name of the thread will be set to it for the duration of the execution of [f ()]. [when_finished] describes how the helper thread behaves once [f ()] has completed. Its default value is the value of {!When_finished.default} when [run] is called. *) val run : ?priority:Priority.t -> ?thread:Helper_thread.t -> ?when_finished:When_finished.t -> ?name:string -> (unit -> 'a) -> 'a Deferred.t (** [syscall f] runs f, which should be a single system call, and returns the result, handling the restarting of interrupted system calls. To avoid race conditions, the [f] supplied to [syscall] should just make a system call. That way, everything else is done holding the Async lock. *) val syscall : name:string -> (unit -> 'a) -> ('a, exn) Result.t Deferred.t val syscall_exn : name:string -> (unit -> 'a) -> 'a Deferred.t async_unix-0.15.0/src/interruptor.ml000066400000000000000000000066161420273305200175020ustar00rootroot00000000000000open Core open Import module Fd = Raw_fd let debug = Debug.interruptor type t = { pipe : Fd.t Read_write_pair.t ; (* [already_interrupted] keeps track of whether we've already interrupted since the most recent call to [clear], and if so, avoid writing to the pipe again. [already_interrupted] does not exactly track the state of [pipe]. It is possible for [already_interrupted] to be false and for the [pipe] to be nonempty. The key property is that if [already_interrupted] is true then [pipe] is nonempty*) mutable already_interrupted : bool ; clearbuffer : (Bytes.t[@sexp.opaque]) } [@@deriving sexp_of] let invariant _ = () let read_fd t = Read_write_pair.get t.pipe `Read let create ~create_fd = let pipe_read, pipe_write = Unix.pipe () in Unix.set_close_on_exec pipe_read; Unix.set_close_on_exec pipe_write; let pipe_read = create_fd Fd.Kind.Fifo pipe_read (Info.of_string "interruptor_pipe_read") in let pipe_write = create_fd Fifo pipe_write (Info.of_string "interruptor_pipe_write") in { pipe = Read_write_pair.create ~read:pipe_read ~write:pipe_write ; already_interrupted = false ; clearbuffer = Bytes.make 1024 ' ' } ;; (* [bytes_w] is a toplevel to make sure it's not allocated multiple times. *) let bytes_w = Bytes.of_string "w" (* [thread_safe_interrupt] As the name implies, it is safe to call from any thread; [thread_safe_interrupt] does not assume the scheduler lock is held, although it is fine if it is. Because of OCaml's compilation, the test-and-set of [t.already_interrupted] is atomic, so we will only ever write one byte to the pipe before it is cleared. *) let thread_safe_interrupt t = if debug then Debug.log_string "Interruptor.thread_safe_interrupt"; (* BEGIN ATOMIC *) if not t.already_interrupted then ( t.already_interrupted <- true; (* END ATOMIC *) if debug then Debug.log_string "writing to interrupt_pipe_write"; Fd.syscall_exn (Read_write_pair.get t.pipe `Write) ~nonblocking:true (fun file_descr -> try ignore (Unix.write_assume_fd_is_nonblocking file_descr bytes_w : int) with | Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _) -> ())) ;; let clear t = if debug then Debug.log_string "Interruptor.clear"; (* We only need to clear the pipe if it was written to. This saves a system call in the common case. *) if t.already_interrupted then Fd.syscall_exn (Read_write_pair.get t.pipe `Read) ~nonblocking:true (fun file_descr -> let rec loop () = let read_again = try let bytes_read = Unix.read_assume_fd_is_nonblocking file_descr t.clearbuffer ~pos:0 ~len:(Bytes.length t.clearbuffer) in ignore (bytes_read : int); true with | Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _) -> false in if read_again then loop () in loop ()); (* We must clear [already_interrupted] after emptying the pipe. If we did it before, a [thread_safe_interrupt] could come along in between. We would then be left with [already_interrupted = true] and an empty pipe, which would then cause a [thread_safe_interrupt] after [clear] returns to incorrectly be a no-op. *) t.already_interrupted <- false ;; async_unix-0.15.0/src/interruptor.mli000066400000000000000000000015141420273305200176430ustar00rootroot00000000000000(** An interruptor provides a file descriptor that can be used to cause a file-descr-watcher to detect the file descriptor is ready for reading. We use an interruptor when a thread needs the Async scheduler to service a request. *) open! Core open! Import type t [@@deriving sexp_of] include Invariant.S with type t := t val create : create_fd:(Raw_fd.Kind.t -> Unix.File_descr.t -> Info.t -> Raw_fd.t) -> t val read_fd : t -> Raw_fd.t (** [thread_safe_interrupt t] causes [read_fd t] to become ready for reading. *) val thread_safe_interrupt : t -> unit (** [clear t] causes [read_fd t] to become not ready for reading. It is guaranteed that any calls to [thread_safe_interrupt] after [clear t] returns (and prior to another call to [clear t]) will cause [read_fd] to become ready for reading. *) val clear : t -> unit async_unix-0.15.0/src/io_stats.ml000066400000000000000000000014061420273305200167220ustar00rootroot00000000000000open Core type t = { mutable total : Int63.t ; mutable char : Int63.t ; mutable fifo : Int63.t ; mutable file : Int63.t ; mutable socket : Int63.t } [@@deriving sexp] let create () = { total = Int63.zero ; char = Int63.zero ; fifo = Int63.zero ; file = Int63.zero ; socket = Int63.zero } ;; let update t ~(kind : Fd.Kind.t) ~bytes = t.total <- Int63.(t.total + bytes); match kind with | Char -> t.char <- Int63.( + ) t.char bytes | Fifo -> t.fifo <- Int63.( + ) t.fifo bytes | File -> t.file <- Int63.( + ) t.file bytes | Socket _ -> t.socket <- Int63.( + ) t.socket bytes ;; let total t = t.total let get t ~(kind : Fd.Kind.t) = match kind with | Char -> t.char | Fifo -> t.fifo | File -> t.file | Socket _ -> t.socket ;; async_unix-0.15.0/src/io_stats.mli000066400000000000000000000003441420273305200170730ustar00rootroot00000000000000(** Gives stats about system IO usage. *) open! Core type t [@@deriving sexp] val create : unit -> t val update : t -> kind:Fd.Kind.t -> bytes:Int63.t -> unit val total : t -> Int63.t val get : t -> kind:Fd.Kind.t -> Int63.t async_unix-0.15.0/src/log.ml000066400000000000000000001551631420273305200156700ustar00rootroot00000000000000(* this is used by some stable types below, so it needs to be at the top of the file *) module type Rotation_id_intf = sig type t val create : ?time_source:Async_kernel.Synchronous_time_source.t -> Core.Time.Zone.t -> t (* For any rotation scheme that renames logs on rotation, this defines how to do the renaming. *) val rotate_one : t -> t val to_string_opt : t -> string option val of_string_opt : string option -> t option val cmp_newest_first : t -> t -> int end module Stable = struct open! Core.Core_stable module Time = Time_unix.Stable module Level = struct module V1 = struct type t = [ `Debug | `Info | `Error ] [@@deriving bin_io, sexp] let%expect_test "bin_digest Level.V1" = print_endline [%bin_digest: t]; [%expect {| 62fa833cdabec8a41d614848cd11f858 |}] ;; end end module Output = struct module Format = struct module V1 = struct type machine_readable = [ `Sexp | `Sexp_hum | `Bin_prot ] [@@deriving sexp] type t = [ machine_readable | `Text ] [@@deriving sexp] end end end module Sexp_or_string = struct module V1 = struct type t = [ `Sexp of Sexp.V1.t | `String of string ] [@@deriving bin_io, sexp] let%expect_test "bin_digest Sexp_or_string.V1" = print_endline [%bin_digest: t]; [%expect {| 7604679c48980b04476c108e66cf67c8 |}] ;; let to_string = function | `Sexp sexp -> Core.Sexp.to_string sexp | `String str -> str ;; end end module Rotation = struct module V3 = struct type naming_scheme = [ `Numbered | `Timestamped | `Dated | `User_defined of (module Rotation_id_intf) ] type t = { messages : int option ; size : Byte_units.V1.t option ; time : Time.Ofday.V1.t option ; keep : [ `All | `Newer_than of Time.Span.V3.t | `At_least of int ] ; naming_scheme : naming_scheme ; zone : Time.Zone.V1.t } [@@deriving fields] let sexp_of_t t = let a x = Core.Sexp.Atom x and l x = Core.Sexp.List x in let o x name sexp_of = Core.Option.map x ~f:(fun x -> l [ a name; sexp_of x ]) in let messages = o t.messages "messages" Int.V1.sexp_of_t in let size = o t.size "size" Byte_units.V1.sexp_of_t in let time = o t.time "time" Time.Ofday.V1.sexp_of_t in let keep = l [ a "keep" ; (match t.keep with | `All -> a "All" | `Newer_than span -> l [ a "Newer_than"; Time.Span.V3.sexp_of_t span ] | `At_least n -> l [ a "At_least"; Int.V1.sexp_of_t n ]) ] in let naming_scheme = l [ a "naming_scheme" ; (match t.naming_scheme with | `Numbered -> a "Numbered" | `Timestamped -> a "Timestamped" | `Dated -> a "Dated" | `User_defined _ -> a "User_defined") ] in let zone = l [ a "zone"; Time.Zone.V1.sexp_of_t t.zone ] in let all = Core.List.filter_opt [ messages; size; time; Some keep; Some naming_scheme; Some zone ] in l all ;; end end (* Log messages are stored, starting with V2, as an explicit version followed by the message itself. This makes it easier to move the message format forward while still allowing older logs to be read by the new code. If you make a new version you must add a version to the Version module below and should follow the Make_versioned_serializable pattern. *) module Message = struct module Version = struct type t = V2 [@@deriving bin_io, sexp, compare] let%expect_test "bin_digest Message.Version.V2" = print_endline [%bin_digest: t]; [%expect {| 6ae8dff060dc8c96585060b4f76d2974 |}] ;; let ( <> ) t1 t2 = compare t1 t2 <> 0 let to_string t = Core.Sexp.to_string (sexp_of_t t) end module type Versioned_serializable = sig type t [@@deriving bin_io, sexp] val version : Version.t end module Stable_message_common = struct type 'a t = { time : Time.V1.t ; level : Level.V1.t option ; message : 'a ; tags : (string * string) list } [@@deriving bin_io, sexp] end module Make_versioned_serializable (T : Versioned_serializable) : sig type t [@@deriving bin_io, sexp] end with type t = T.t = struct type t = T.t type versioned_serializable = Version.t * T.t [@@deriving bin_io, sexp] let t_of_versioned_serializable (version, t) = if Version.( <> ) version T.version then Core.failwithf !"version mismatch %{Version} <> to expected version %{Version}" version T.version () else t ;; let sexp_of_t t = sexp_of_versioned_serializable (T.version, t) let t_of_sexp sexp = let versioned_t = versioned_serializable_of_sexp sexp in t_of_versioned_serializable versioned_t ;; include Binable.Of_binable.V1 [@alert "-legacy"] (struct type t = versioned_serializable [@@deriving bin_io] end) (struct type t = T.t let to_binable t = T.version, t let of_binable versioned_t = t_of_versioned_serializable versioned_t end) end module V2 = Make_versioned_serializable (struct type t = Sexp_or_string.V1.t Stable_message_common.t [@@deriving bin_io, sexp] let%expect_test "bin_digest Message.V2" = print_endline [%bin_digest: t]; [%expect {| 1dd2225c5392b6ac36b718ee2b1a08db |}] ;; let version = Version.V2 end) (* this is the serialization scheme in 111.18 and before *) module V0 = struct type v0_t = string Stable_message_common.t [@@deriving bin_io, sexp] let%expect_test "bin_digest Message.V1.v0_t" = print_endline [%bin_digest: v0_t]; [%expect {| d790de8237524f270360ccf1e56f7030 |}] ;; let v0_to_v2 (v0_t : v0_t) : V2.t = { time = v0_t.time ; level = v0_t.level ; message = `String v0_t.message ; tags = v0_t.tags } ;; let v2_to_v0 (v2_t : V2.t) : v0_t = { time = v2_t.time ; level = v2_t.level ; message = Sexp_or_string.V1.to_string v2_t.message ; tags = v2_t.tags } ;; include Binable.Of_binable.V1 [@alert "-legacy"] (struct type t = v0_t [@@deriving bin_io] end) (struct let to_binable = v2_to_v0 let of_binable = v0_to_v2 type t = Sexp_or_string.V1.t Stable_message_common.t end) let sexp_of_t t = sexp_of_v0_t (v2_to_v0 t) let t_of_sexp sexp = v0_to_v2 (v0_t_of_sexp sexp) type t = V2.t end end end open Core open Import module Scheduler = Raw_scheduler module Sys = Async_sys module Unix = Unix_syscalls module Level = struct module T = struct type t = [ `Debug | `Info | `Error ] [@@deriving bin_io, compare, enumerate, sexp] let to_string = function | `Debug -> "Debug" | `Info -> "Info" | `Error -> "Error" ;; let of_string = function | "Debug" -> `Debug | "Info" -> `Info | "Error" -> `Error | s -> failwithf "not a valid level %s" s () ;; end include T let arg = Command.Arg_type.enumerated ~list_values_in_help:true ~case_sensitive:false (module T : Command.Enumerable_stringable with type t = t) ;; (* Ordering of log levels in terms of verbosity. *) let as_or_more_verbose_than ~log_level ~msg_level = match log_level, msg_level with | `Error, Some `Error -> true | `Error, (None | Some (`Debug | `Info)) -> false | `Info, (None | Some (`Info | `Error)) -> true | `Info, Some `Debug -> false | `Debug, _ -> true ;; module Stable = Stable.Level end module Rotation = struct (* description of boundaries for file rotation. If all fields are None the file will never be rotated. Any field set to Some _ will cause rotation to happen when that boundary is crossed. Multiple boundaries may be set. Log rotation always causes incrementing rotation conditions (e.g. size) to reset, though this is the responsibililty of the caller to should_rotate. *) module type Id_intf = Rotation_id_intf include Stable.Rotation.V3 let create ?messages ?size ?time ?zone ~keep ~naming_scheme () = { messages ; size ; time ; zone = Option.value zone ~default:(force Time.Zone.local) ; keep ; naming_scheme } ;; let first_occurrence_after time ~ofday ~zone = let first_at_or_after time = Time.occurrence `First_after_or_at time ~ofday ~zone in let candidate = first_at_or_after time in (* we take care not to return the same time we were given *) if Time.equal time candidate then first_at_or_after (Time.add time Time.Span.robust_comparison_tolerance) else candidate ;; let should_rotate t ~last_messages ~last_size ~last_time ~current_time = Fields.fold ~init:false ~messages:(fun acc field -> match Field.get field t with | None -> acc | Some rotate_messages -> acc || rotate_messages <= last_messages) ~size:(fun acc field -> match Field.get field t with | None -> acc | Some rotate_size -> acc || Byte_units.( <= ) rotate_size last_size) ~time:(fun acc field -> match Field.get field t with | None -> acc | Some rotation_ofday -> let rotation_time = first_occurrence_after last_time ~ofday:rotation_ofday ~zone:t.zone in acc || Time.( >= ) current_time rotation_time) ~zone:(fun acc _ -> acc) ~keep:(fun acc _ -> acc) ~naming_scheme:(fun acc _ -> acc) ;; let default ?(zone = force Time.Zone.local) () = { messages = None ; size = None ; time = Some Time.Ofday.start_of_day ; keep = `All ; naming_scheme = `Dated ; zone } ;; end module Sexp_or_string = struct module Stable = Stable.Sexp_or_string include Stable.V1 end let now ~time_source = match time_source with | Some time_source -> Synchronous_time_source.now time_source |> Time_ns.to_time_float_round_nearest | None -> Time.now () ;; module Message : sig type t [@@deriving bin_io, sexp] include Equal.S with type t := t val create : ?level:Level.t -> ?time:Time.t -> ?time_source:Synchronous_time_source.t -> ?tags:(string * string) list -> Sexp_or_string.t -> t val time : t -> Time.t val level : t -> Level.t option val set_level : t -> Level.t option -> t val message : t -> string val raw_message : t -> [ `String of string | `Sexp of Sexp.t ] val tags : t -> (string * string) list val add_tags : t -> (string * string) list -> t val to_write_only_text : ?zone:Time.Zone.t -> t -> string val write_write_only_text : t -> Writer.t -> unit val write_sexp : t -> hum:bool -> Writer.t -> unit val write_bin_prot : t -> Writer.t -> unit module Stable : sig module Version : sig type t [@@deriving of_sexp] end module V0 : sig type nonrec t = t [@@deriving bin_io, sexp] end module V2 : sig type nonrec t = t [@@deriving bin_io, sexp] end end end = struct module Stable = Stable.Message open Stable.Stable_message_common include Stable.V2 let equal (t1 : t) (t2 : t) = let compare_tags = Tuple.T2.compare ~cmp1:String.compare ~cmp2:String.compare in Time.( =. ) t1.time t2.time && [%compare.equal: Level.t option] t1.level t2.level && Poly.equal t1.message t2.message (* The same key can appear more than once in tags, and order shouldn't matter when comparing *) && List.compare [%compare: String.t * String.t] (List.sort ~compare:compare_tags t1.tags) (List.sort ~compare:compare_tags t2.tags) = 0 ;; (* this allows for automagical reading of any versioned sexp, so long as we can always lift to a Message.t *) let t_of_sexp (sexp : Sexp.t) = match sexp with | List (List (Atom "time" :: _) :: _) -> Stable.V0.t_of_sexp sexp | List [ (Atom _ as version); _ ] -> (match Stable.Version.t_of_sexp version with | V2 -> Stable.V2.t_of_sexp sexp) | _ -> failwithf !"Log.Message.t_of_sexp: malformed sexp: %{Sexp}" sexp () ;; let create_raw ?level ~time ?(tags = []) message = { time; level; message; tags } let create ?level ?time ?time_source ?tags message = let time = match time with | Some time -> time | None -> now ~time_source in create_raw ?level ~time ?tags message ;; let time t = t.time let level t = t.level let set_level t level = { t with level } let raw_message t = t.message let message t = Sexp_or_string.to_string (raw_message t) let tags t = t.tags let add_tags t tags = { t with tags = List.rev_append tags t.tags } let to_write_only_text ?(zone = force Time.Zone.local) t = let prefix = match t.level with | None -> "" | Some l -> Level.to_string l ^ " " in let formatted_tags = match t.tags with | [] -> [] | _ :: _ -> " --" :: List.concat_map t.tags ~f:(fun (t, v) -> [ " ["; t; ": "; v; "]" ]) in String.concat ~sep:"" (Time.to_string_abs ~zone t.time :: " " :: prefix :: message t :: formatted_tags) ;; let write_write_only_text t wr = Writer.write wr (to_write_only_text t); Writer.newline wr ;; let write_sexp t ~hum wr = Writer.write_sexp ~hum wr (sexp_of_t t); Writer.newline wr ;; let write_bin_prot t wr = Writer.write_bin_prot wr bin_writer_t t end module Output : sig (* The output module exposes a variant that describes the output type and sub-modules that each expose a write function (or create that returns a write function) that is of type: Level.t -> string -> unit Deferred.t. It is the responsibility of the write function to contain all state, and to clean up after itself. *) module Format : sig type machine_readable = [ `Sexp | `Sexp_hum | `Bin_prot ] [@@deriving sexp] type t = [ machine_readable | `Text ] [@@deriving sexp] module Stable : sig module V1 : sig type nonrec t = t [@@deriving sexp] end end end type t [@@deriving sexp_of] val create : ?rotate:(unit -> unit Deferred.t) -> ?close:(unit -> unit Deferred.t) -> flush:(unit -> unit Deferred.t) -> (Message.t Queue.t -> unit Deferred.t) -> t val write : t -> Message.t Queue.t -> unit Deferred.t val rotate : t -> unit Deferred.t val flush : t -> unit Deferred.t val stdout : ?format:Format.t -> unit -> t val stderr : ?format:Format.t -> unit -> t val writer : Format.t -> Writer.t -> t val file : ?perm:Unix.file_perm -> Format.t -> filename:string -> t val rotating_file : ?perm:Unix.file_perm -> ?time_source:Synchronous_time_source.t -> ?log_on_rotation:(unit -> Message.t list) -> Format.t -> basename:string -> Rotation.t -> t val rotating_file_with_tail : ?perm:Unix.file_perm -> ?time_source:Synchronous_time_source.t -> ?log_on_rotation:(unit -> Message.t list) -> Format.t -> basename:string -> Rotation.t -> t * string Tail.t val filter_to_level : t -> level:Level.t -> t val combine : t list -> t module For_testing : sig val create : map_output:(string -> string) -> t end end = struct module Format = struct type machine_readable = [ `Sexp | `Sexp_hum | `Bin_prot ] [@@deriving sexp] type t = [ machine_readable | `Text ] [@@deriving sexp] module Stable = Stable.Output.Format end module Definitely_a_heap_block : sig type t val the_one_and_only : t end = struct type t = string let the_one_and_only = String.make 1 ' ' end type t = { write : Message.t Queue.t -> unit Deferred.t ; rotate : unit -> unit Deferred.t ; close : unit -> unit Deferred.t ; flush : unit -> unit Deferred.t ; (* experimentation shows that this record, without this field, can sometimes raise when passed to Heap_block.create_exn, which we need to do to add a finalizer. This seems to occur when the functions are top-level and/or constant. More investigation is probably worthwhile. *) heap_block : Definitely_a_heap_block.t } let create ?(rotate = fun () -> return ()) ?(close = fun () -> return ()) ~flush write = let t = { write ; rotate ; close ; flush ; heap_block = Definitely_a_heap_block.the_one_and_only } in Gc.add_finalizer (Heap_block.create_exn t) (fun t -> let t = Heap_block.value t in don't_wait_for (let%bind () = t.flush () in t.close ())); t ;; let write t msgs = t.write msgs let rotate t = t.rotate () let flush t = t.flush () let sexp_of_t _ = Sexp.Atom "" let combine ts = (* There is a crazy test that verifies that we combine things correctly when the same rotate output is included 5 times in Log.create, so we must make this Sequential to enforce the rotate invariants and behavior. *) let iter_combine_exns = (* No need for the Monitor overhead in the case of a single t *) match ts with | [] -> fun (_ : t -> unit Deferred.t) -> Deferred.unit | [ single_t ] -> fun f -> f single_t | ts -> fun f -> Deferred.List.map ~how:`Sequential ts ~f:(fun t -> Monitor.try_with_or_error ~rest:`Log (fun () -> f t)) >>| Or_error.combine_errors_unit >>| Or_error.ok_exn in let write msg = iter_combine_exns (fun t -> t.write msg) in let rotate () = iter_combine_exns (fun t -> t.rotate ()) in let close () = iter_combine_exns (fun t -> t.close ()) in let flush () = iter_combine_exns (fun t -> t.flush ()) in { write; rotate; close; flush; heap_block = Definitely_a_heap_block.the_one_and_only } ;; let filter_to_level t ~level = let write messages = let filtered_messages = Queue.filter messages ~f:(fun message -> Level.as_or_more_verbose_than ~log_level:level ~msg_level:(Message.level message)) in t.write filtered_messages in create ~rotate:t.rotate ~close:t.close ~flush:t.flush write ;; let basic_write format w msg = match format with | `Sexp -> Message.write_sexp msg ~hum:false w | `Sexp_hum -> Message.write_sexp msg ~hum:true w | `Bin_prot -> Message.write_bin_prot msg w | `Text -> Message.write_write_only_text msg w ;; let open_file ?perm filename = (* guard the open_file with a unit deferred to prevent any work from happening before async spins up. Without this no real work will be done, but async will be initialized, which will raise if we later call Scheduler.go_main. *) return () >>= fun () -> Writer.open_file ~append:true filename ?perm ;; let open_writer ~filename ~perm = (* the lazy pushes evaluation to the first place we use it, which keeps writer creation errors within the error handlers for the log. *) lazy (open_file filename ?perm >>| fun w -> (* if we are writing to a slow device, or a temporarily disconnected device it's better to push back on memory in the hopes that the disconnection will resolve than to blow up after a timeout. If we had a better logging error reporting mechanism we could potentially deal with it that way, but we currently don't. *) Writer.set_buffer_age_limit w `Unlimited; w) ;; let write_immediately w format msgs = Queue.iter msgs ~f:(fun msg -> basic_write format w msg); Writer.bytes_received w ;; let write' w format msgs = let%map w = w in write_immediately w format msgs ;; module File : sig val create : ?perm:Unix.file_perm -> Format.t -> filename:string -> t end = struct let create ?perm format ~filename = let w = open_writer ~filename ~perm in create ~close:(fun () -> if Lazy.is_val w then force w >>= Writer.close else return ()) ~flush:(fun () -> if Lazy.is_val w then force w >>= Writer.flushed else return ()) (fun msgs -> let%map (_ : Int63.t) = write' (force w) format msgs in ()) ;; end module Log_writer : sig val create : Format.t -> Writer.t -> t end = struct (* The writer output type takes no responsibility over the Writer.t it is given. In particular it makes no attempt to ever close it. *) let create format w = create ~flush:(fun () -> Writer.flushed w) (fun msgs -> Queue.iter msgs ~f:(fun msg -> basic_write format w msg); return ()) ;; end module Rotating_file : sig val create : ?perm:Unix.file_perm -> ?time_source:Synchronous_time_source.t -> Format.t -> basename:string -> Rotation.t -> log_on_rotation:(unit -> Message.t list) option -> t * string Tail.t end = struct module Make (Id : Rotation.Id_intf) = struct let make_filename ~dirname ~basename id = match Id.to_string_opt id with | None -> dirname ^/ sprintf "%s.log" basename | Some s -> dirname ^/ sprintf "%s.%s.log" basename s ;; let parse_filename_id ~basename filename = if String.equal (Filename.basename filename) (basename ^ ".log") then Id.of_string_opt None else let open Option.Monad_infix in String.chop_prefix (Filename.basename filename) ~prefix:(basename ^ ".") >>= fun id_dot_log -> String.chop_suffix id_dot_log ~suffix:".log" >>= fun id -> Id.of_string_opt (Some id) ;; let current_log_files ~dirname ~basename = Sys.readdir dirname >>| fun files -> List.filter_map (Array.to_list files) ~f:(fun filename -> let filename = dirname ^/ filename in Option.(parse_filename_id ~basename filename >>| fun id -> id, filename)) ;; (* errors from this function should be ignored. If this function fails to run, the disk may fill up with old logs, but external monitoring should catch that, and the core function of the Log module will be unaffected. *) let maybe_delete_old_logs ~dirname ~basename keep = (match keep with | `All -> return [] | `Newer_than span -> current_log_files ~dirname ~basename >>= fun files -> (* This will be compared to the mtime of the file, so we should always use Time.now (wall-clock time) instead a different time source. *) let now = Time.now () in let cutoff = Time.sub now span in Deferred.List.filter files ~f:(fun (_, filename) -> Deferred.Or_error.try_with ~run: `Schedule ~rest:`Log (fun () -> Unix.stat filename) >>| function | Error _ -> false | Ok stats -> Time.( < ) stats.mtime cutoff) | `At_least i -> current_log_files ~dirname ~basename >>| fun files -> let files = List.sort files ~compare:(fun (i1, _) (i2, _) -> Id.cmp_newest_first i1 i2) in List.drop files i) >>= Deferred.List.map ~f:(fun (_i, filename) -> Deferred.Or_error.try_with ~run: `Schedule ~rest:`Log (fun () -> Unix.unlink filename)) >>| fun (_ : unit Or_error.t list) -> () ;; type t = { basename : string ; dirname : string ; rotation : Rotation.t ; format : Format.t ; mutable writer : Writer.t Deferred.t Lazy.t ; mutable filename : string ; mutable last_messages : int ; mutable last_size : int ; mutable last_time : Time.t ; log_files : string Tail.t ; log_on_rotation : unit -> Message.t list ; perm : int option } [@@deriving sexp_of] let we_have_written_to_the_current_writer t = Lazy.is_val t.writer let close_writer t = if we_have_written_to_the_current_writer t then ( let%bind w = Lazy.force t.writer in Writer.close w) else return () ;; let rotate t ~time_source = let basename, dirname = t.basename, t.dirname in close_writer t >>= fun () -> current_log_files ~dirname ~basename >>= fun files -> let files = List.rev (List.sort files ~compare:(fun (i1, _) (i2, _) -> Id.cmp_newest_first i1 i2)) in Deferred.List.iter files ~f:(fun (id, src) -> let id' = Id.rotate_one id in let dst = make_filename ~dirname ~basename id' in if String.equal src t.filename then Tail.extend t.log_files dst; if Id.cmp_newest_first id id' <> 0 then Unix.rename ~src ~dst else return ()) >>= fun () -> maybe_delete_old_logs ~dirname ~basename t.rotation.keep >>| fun () -> let filename = make_filename ~dirname ~basename (Id.create ?time_source (Rotation.zone t.rotation)) in t.last_size <- 0; t.last_messages <- 0; t.last_time <- now ~time_source; t.filename <- filename; t.writer <- open_writer ~filename ~perm:t.perm ;; let write t ~time_source msgs = let current_time = now ~time_source in (if Rotation.should_rotate t.rotation ~last_messages:t.last_messages ~last_size:(Byte_units.of_bytes_int t.last_size) ~last_time:t.last_time ~current_time then rotate ~time_source t >>= fun () -> let msgs = t.log_on_rotation () |> Queue.of_list in let rotation_msgs = Queue.length msgs in write' (Lazy.force t.writer) t.format msgs >>| fun size -> rotation_msgs, size else return (0, Int63.zero)) >>= fun (rotation_msgs, on_rotation_log_size) -> write' (Lazy.force t.writer) t.format msgs >>| fun size -> t.last_messages <- t.last_messages + rotation_msgs + Queue.length msgs; t.last_size <- Int63.to_int_exn size + Int63.to_int_exn on_rotation_log_size; t.last_time <- current_time ;; let create ?perm ?time_source ~log_on_rotation format ~basename rotation = let log_on_rotation = match log_on_rotation with | None -> Fn.const [] | Some f -> f in let basename, dirname = (* make dirname absolute, because cwd may change *) match Filename.is_absolute basename with | true -> Filename.basename basename, return (Filename.dirname basename) | false -> basename, Sys.getcwd () in let log_files = Tail.create () in let t_deferred = dirname >>| fun dirname -> let filename = make_filename ~dirname ~basename (Id.create ?time_source (Rotation.zone rotation)) in { basename ; dirname ; rotation ; format ; writer = open_writer ~filename ~perm ; filename ; last_size = 0 ; last_messages = 0 ; last_time = now ~time_source ; log_files ; log_on_rotation ; perm } in let first_rotate_scheduled = ref false in let close () = let%bind t = t_deferred in close_writer t in let flush () = let%bind t = t_deferred in if Lazy.is_val t.writer then force t.writer >>= Writer.flushed else return () in ( create ~close ~flush ~rotate:(fun () -> t_deferred >>= rotate ~time_source) (fun msgs -> t_deferred >>= fun t -> if not !first_rotate_scheduled then ( first_rotate_scheduled := true; rotate t ~time_source >>= fun () -> write t ~time_source msgs) else write t ~time_source msgs) , log_files ) ;; end module Numbered = Make (struct type t = int let create ?time_source:_ _ = 0 let rotate_one = ( + ) 1 let to_string_opt = function | 0 -> None | x -> Some (Int.to_string x) ;; let cmp_newest_first = Int.ascending let of_string_opt = function | None -> Some 0 | Some s -> (try Some (Int.of_string s) with | _ -> None) ;; end) module Timestamped = Make (struct type t = Time.t let create ?time_source _zone = now ~time_source let rotate_one = Fn.id let to_string_opt ts = Some (Time.to_filename_string ~zone:(force Time.Zone.local) ts) ;; let cmp_newest_first = Time.descending let of_string_opt = function | None -> None | Some s -> (try Some (Time.of_filename_string ~zone:(force Time.Zone.local) s) with | _ -> None) ;; end) module Dated = Make (struct type t = Date.t let create ?time_source zone = Date.of_time (now ~time_source) ~zone let rotate_one = Fn.id let to_string_opt date = Some (Date.to_string date) let cmp_newest_first = Date.descending let of_string_opt = function | None -> None | Some str -> Option.try_with (fun () -> Date.of_string str) ;; end) let create ?perm ?time_source format ~basename (rotation : Rotation.t) = match rotation.naming_scheme with | `Numbered -> Numbered.create format ~basename rotation ?perm ?time_source | `Timestamped -> Timestamped.create format ~basename rotation ?perm ?time_source | `Dated -> Dated.create format ~basename rotation ?perm ?time_source | `User_defined id -> let module Id = (val id : Rotation.Id_intf) in let module User_defined = Make (Id) in User_defined.create format ~basename rotation ?perm ?time_source ;; end let rotating_file ?perm ?time_source ?log_on_rotation format ~basename rotation = fst (Rotating_file.create format ~basename ~log_on_rotation rotation ?perm ?time_source) ;; let rotating_file_with_tail ?perm ?time_source ?log_on_rotation format ~basename rotation = Rotating_file.create format ~basename ~log_on_rotation rotation ?perm ?time_source ;; let file = File.create let writer = Log_writer.create let stdout = let make = Memo.general (fun format -> Log_writer.create format (Lazy.force Writer.stdout)) in fun ?(format = `Text) () -> make format ;; let stderr = let make = Memo.general (fun format -> Log_writer.create format (Lazy.force Writer.stderr)) in fun ?(format = `Text) () -> make format ;; module For_testing = struct let create ~map_output = let stdout = force Writer.stdout in let we_flush_after_each_message_is_processed () = Deferred.unit in create ~flush:we_flush_after_each_message_is_processed (fun queue -> Queue.iter queue ~f:(fun message -> map_output (Message.message message) |> print_endline); Writer.flushed stdout) ;; end end (* A log is a pipe that can take one of four messages. | Msg (level, msg) -> write the message to the current output if the level is appropriate | New_output f -> set the output function for future messages to f | Flush i -> used to get around the current odd design of Pipe flushing. Sends an ivar that the reading side fills in after it has finished handling all previous messages. | Rotate -> inform the output handlers to rotate exactly now The f delivered by New_output must not hold on to any resources that normal garbage collection won't clean up. When New_output is delivered to the pipe the current write function will be discarded without notification. If this proves to be a resource problem (too many syscalls for instance) then we could add an on_discard function to writers that we call when a new writer appears. *) module Update = struct type t = | Msg of Message.t | New_output of Output.t | Flush of unit Ivar.t | Rotate of unit Ivar.t [@@deriving sexp_of] let to_string t = Sexp.to_string (sexp_of_t t) end let default_time_source = if am_running_inline_test then Synchronous_time_source.read_only (Synchronous_time_source.create ~now:Time_ns.epoch ()) else Synchronous_time_source.wall_clock () ;; type t = { updates : Update.t Pipe.Writer.t ; mutable on_error : [ `Raise | `Call of Error.t -> unit ] ; mutable current_level : Level.t ; mutable output_is_disabled : bool ; mutable current_output : Output.t list ; mutable current_time_source : Synchronous_time_source.t ; mutable transform : (Message.t -> Message.t) option } let equal t1 t2 = Pipe.equal t1.updates t2.updates let hash t = Pipe.hash t.updates let sexp_of_t _t = Sexp.Atom "" let push_update t update = if not (Pipe.is_closed t.updates) then Pipe.write_without_pushback t.updates update else failwithf "Log: can't process %s because this log has been closed" (Update.to_string update) () ;; let flushed t = Deferred.create (fun i -> push_update t (Flush i)) let rotate t = Deferred.create (fun rotated -> push_update t (Rotate rotated)) let is_closed t = Pipe.is_closed t.updates module Flush_at_exit_or_gc : sig val add_log : t -> unit val close : t -> unit Deferred.t end = struct module Weak_table = Caml.Weak.Make (struct type z = t type t = z let equal = equal let hash = hash end) (* contains all logs we want to flush at shutdown *) let flush_bag = lazy (Bag.create ()) (* contains all currently live logs. *) let live_logs = lazy (Weak_table.create 1) (* [flush] adds a flush deferred to the flush_bag *) let flush t = if not (is_closed t) then ( let flush_bag = Lazy.force flush_bag in let flushed = flushed t in let tag = Bag.add flush_bag flushed in upon flushed (fun () -> Bag.remove flush_bag tag); flushed) else return () ;; let close t = if not (is_closed t) then ( (* this will cause the log to flush its outputs, but because they may have been reused it does not close them, they'll be closed automatically when they fall out of scope. *) Pipe.write_without_pushback t.updates (New_output (Output.combine [])); let finished = flushed t in Pipe.close t.updates; finished) else return () ;; let finish_at_shutdown = lazy (Shutdown.at_shutdown (fun () -> let live_logs = Lazy.force live_logs in let flush_bag = Lazy.force flush_bag in Weak_table.iter (fun log -> don't_wait_for (flush log)) live_logs; Deferred.all_unit (Bag.to_list flush_bag))) ;; let add_log log = let live_logs = Lazy.force live_logs in Lazy.force finish_at_shutdown; Weak_table.remove live_logs log; Weak_table.add live_logs log; (* If we fall out of scope just close and flush normally. Without this we risk being finalized and removed from the weak table before the the shutdown handler runs, but also before we get all of logs out of the door. *) Gc.add_finalizer_exn log (fun log -> don't_wait_for (close log)) ;; end let close = Flush_at_exit_or_gc.close let create_log_processor ~output = let batch_size = 100 in let output = ref (Output.combine output) in let msgs = Queue.create () in let output_message_queue f = if Queue.length msgs = 0 then f () else Output.write !output msgs >>= fun () -> Queue.clear msgs; f () in fun (updates : Update.t Queue.t) -> let rec loop yield_every = let yield_every = yield_every - 1 in if yield_every = 0 then (* this introduces a yield point so that other async jobs have a chance to run under circumstances when large batches of logs are delivered in bursts. *) Scheduler.yield () >>= fun () -> loop batch_size else ( match Queue.dequeue updates with | None -> output_message_queue (fun _ -> return ()) | Some update -> (match update with | Rotate i -> output_message_queue (fun () -> Output.rotate !output >>= fun () -> Ivar.fill i (); loop yield_every) | Flush i -> output_message_queue (fun () -> Output.flush !output >>= fun () -> Ivar.fill i (); loop yield_every) | Msg msg -> Queue.enqueue msgs msg; loop yield_every | New_output o -> output_message_queue (fun () -> (* we don't close the output because we may re-use it. We rely on the finalizer on the output to call close once it falls out of scope. *) Output.flush !output >>= fun () -> output := o; loop yield_every))) in loop batch_size ;; let process_log_redirecting_all_errors t r output = Monitor.try_with ~run:`Schedule ~rest:`Log (fun () -> let process_log = create_log_processor ~output in Pipe.iter' r ~f:process_log) >>| function | Ok () -> () | Error e -> (match t.on_error with | `Raise -> raise e | `Call f -> f (Error.of_exn e)) ;; let create_internal ~level ~output ~on_error ~time_source ~transform : t = (* this has no optional args so that we make sure to update/consider all internal call sites if the signature changes *) let r, w = Pipe.create () in let time_source = match time_source with | Some time_source -> time_source | None -> default_time_source in let t = { updates = w ; on_error ; current_level = level ; output_is_disabled = List.is_empty output ; current_output = output ; current_time_source = time_source ; transform } in Flush_at_exit_or_gc.add_log t; don't_wait_for (process_log_redirecting_all_errors t r output); t ;; module For_external_use_only = struct (* a more convenient interface for use externally *) let create ~level ~output ~on_error ?time_source ?transform () : t = create_internal ~level ~output ~on_error ~time_source ~transform ;; end let set_output t outputs = t.output_is_disabled <- List.is_empty outputs; t.current_output <- outputs; push_update t (New_output (Output.combine outputs)) ;; let get_output t = t.current_output let get_on_error t = t.on_error let set_on_error t handler = t.on_error <- handler let level t = t.current_level let set_level t level = t.current_level <- level let get_time_source t = t.current_time_source let set_time_source t time_source = t.current_time_source <- time_source let get_transform t = t.transform let set_transform t f = t.transform <- f let copy t = create_internal ~level:(level t) ~output:(get_output t) ~on_error:(get_on_error t) ~time_source:(Some (get_time_source t)) ~transform:(get_transform t) ;; (* would_log is broken out and tested separately for every sending function to avoid the overhead of message allocation when we are just going to drop the message. *) let would_log t msg_level = let output_or_transform_is_enabled = (not t.output_is_disabled) || Option.is_some t.transform in output_or_transform_is_enabled && Level.as_or_more_verbose_than ~log_level:(level t) ~msg_level ;; let push_message t msg = (* We want to call [transform], even if we don't end up pushing the message to an output. This allows for someone to listen to all messages that would theoretically be logged by this log (respecting level), and then maybe log them somewhere else. *) let msg = match t.transform with | None -> msg | Some f -> f msg in if not t.output_is_disabled then push_update t (Msg msg) ;; let message t msg = if would_log t (Message.level msg) then push_message t msg let create_message t ?level ?time ?tags msg = let time_source = get_time_source t in Message.create ?level ?time ~time_source ?tags msg ;; let sexp ?level ?time ?tags t sexp = if would_log t level then push_message t (create_message t ?level ?time ?tags (`Sexp sexp)) ;; let string ?level ?time ?tags t s = if would_log t level then push_message t (create_message t ?level ?time ?tags (`String s)) ;; let printf ?level ?time ?tags t fmt = if would_log t level then ksprintf (fun msg -> push_message t (create_message t ?level ?time ?tags (`String msg))) fmt else ifprintf () fmt ;; let add_uuid_to_tags tags = let uuid = match am_test_runner with | true -> Uuid.Stable.V1.for_testing | false -> Uuid_unix.create () in ("Log.surround_id", Uuid.to_string uuid) :: tags ;; let surround_s_gen ?(tags = []) ~try_with ~map_return ~(log_sexp : ?tags:(string * string) list -> Sexp.t -> unit) ~f msg = let tags = add_uuid_to_tags tags in log_sexp ~tags [%message "Enter" ~_:(msg : Sexp.t)]; map_return (try_with f) ~f:(function | Ok x -> log_sexp ~tags [%message "Exit" ~_:(msg : Sexp.t)]; x | Error exn -> log_sexp ~tags [%message "Raised while " ~_:(msg : Sexp.t) (exn : exn)]; Exn.reraise exn (sprintf !"%{sexp:Sexp.t}" msg)) ;; let surroundf_gen ?(tags = []) ~try_with ~map_return ~(log_string : ?tags:(string * string) list -> string -> unit) = ksprintf (fun msg f -> let tags = add_uuid_to_tags tags in log_string ~tags ("Enter " ^ msg); map_return (try_with f) ~f:(function | Ok x -> log_string ~tags ("Exit " ^ msg); x | Error exn -> log_string ~tags ("Raised while " ^ msg ^ ":" ^ Exn.to_string exn); Exn.reraise exn msg)) ;; let surround_s ?level ?time ?tags t msg f = surround_s_gen ?tags ~try_with: (Monitor.try_with ~run: `Schedule ~rest:`Log ) ~map_return:Deferred.map ~log_sexp:(fun ?tags s -> sexp ?tags ?level ?time t s) ~f msg ;; let surroundf ?level ?time ?tags t fmt = surroundf_gen ?tags ~try_with: (Monitor.try_with ~run: `Schedule ~rest:`Log ) ~map_return:Deferred.map ~log_string:(fun ?tags -> string ?tags ?level ?time t) fmt ;; let set_level_via_param_helper ~f = let open Command.Param in map (flag "log-level" (optional Level.arg) ~doc:"LEVEL The log level") ~f:(Option.iter ~f) ;; let set_level_via_param log = set_level_via_param_helper ~f:(set_level log) let set_level_via_param_lazy log = set_level_via_param_helper ~f:(fun level -> set_level (Lazy.force log) level) ;; let raw ?time ?tags t fmt = printf ?time ?tags t fmt let debug ?time ?tags t fmt = printf ~level:`Debug ?time ?tags t fmt let info ?time ?tags t fmt = printf ~level:`Info ?time ?tags t fmt let error ?time ?tags t fmt = printf ~level:`Error ?time ?tags t fmt let raw_s ?time ?tags t the_sexp = sexp ?time ?tags t the_sexp let debug_s ?time ?tags t the_sexp = sexp ~level:`Debug ?time ?tags t the_sexp let info_s ?time ?tags t the_sexp = sexp ~level:`Info ?time ?tags t the_sexp let error_s ?time ?tags t the_sexp = sexp ~level:`Error ?time ?tags t the_sexp let%bench_module "unused log messages" = (module struct let (log : t) = create_internal ~level:`Info ~output:[ Output.file `Text ~filename:"/dev/null" ] ~on_error:`Raise ~time_source:None ~transform:None ;; let%bench "unused printf" = debug log "blah" let%bench "unused printf w/subst" = debug log "%s" "blah" let%bench "unused string" = string log ~level:`Debug "blah" let%bench "used printf" = info log "blah" end) ;; module type Global_intf = sig val log : t Lazy.t val level : unit -> Level.t val set_level : Level.t -> unit val set_output : Output.t list -> unit val get_output : unit -> Output.t list val set_on_error : [ `Raise | `Call of Error.t -> unit ] -> unit val get_time_source : unit -> Synchronous_time_source.t val set_time_source : Synchronous_time_source.t -> unit val get_transform : unit -> (Message.t -> Message.t) option val set_transform : (Message.t -> Message.t) option -> unit val would_log : Level.t option -> bool val set_level_via_param : unit -> unit Command.Param.t val raw : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val info : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val error : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val debug : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val flushed : unit -> unit Deferred.t val rotate : unit -> unit Deferred.t val printf : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val raw_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val info_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val error_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val debug_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val sexp : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val string : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> string -> unit val message : Message.t -> unit val surround_s : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> (unit -> 'a Deferred.t) -> 'a Deferred.t val surroundf : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, (unit -> 'b Deferred.t) -> 'b Deferred.t) format4 -> 'a module For_testing : sig val use_test_output : ?map_output:(string -> string) -> unit -> unit end end module Make_global () : Global_intf = struct let send_errors_to_top_level_monitor e = let e = try Error.raise e with | e -> e in Monitor.send_exn Monitor.main ~backtrace:`Get e ;; let log = lazy (create_internal ~level:`Info ~output:[ Output.stderr () ] ~on_error:(`Call send_errors_to_top_level_monitor) ~time_source:None ~transform:None) ;; let level () = level (Lazy.force log) let set_level level = set_level (Lazy.force log) level let set_output output = set_output (Lazy.force log) output let get_output () = get_output (Lazy.force log) let set_on_error handler = set_on_error (Lazy.force log) handler let get_time_source () = get_time_source (Lazy.force log) let set_time_source time_source = set_time_source (Lazy.force log) time_source let get_transform () = get_transform (Lazy.force log) let set_transform transform = set_transform (Lazy.force log) transform let would_log level = would_log (Lazy.force log) level let raw ?time ?tags k = raw ?time ?tags (Lazy.force log) k let info ?time ?tags k = info ?time ?tags (Lazy.force log) k let error ?time ?tags k = error ?time ?tags (Lazy.force log) k let debug ?time ?tags k = debug ?time ?tags (Lazy.force log) k let raw_s ?time ?tags the_sexp = sexp ?time ?tags (Lazy.force log) the_sexp let debug_s ?time ?tags the_sexp = sexp ~level:`Debug ?time ?tags (Lazy.force log) the_sexp ;; let info_s ?time ?tags the_sexp = sexp ~level:`Info ?time ?tags (Lazy.force log) the_sexp ;; let error_s ?time ?tags the_sexp = sexp ~level:`Error ?time ?tags (Lazy.force log) the_sexp ;; let flushed () = flushed (Lazy.force log) let rotate () = rotate (Lazy.force log) let printf ?level ?time ?tags k = printf ?level ?time ?tags (Lazy.force log) k let sexp ?level ?time ?tags s = sexp ?level ?time ?tags (Lazy.force log) s let string ?level ?time ?tags s = string ?level ?time ?tags (Lazy.force log) s let message msg = message (Lazy.force log) msg let surround_s ?level ?time ?tags msg f = surround_s ?level ?time ?tags (Lazy.force log) msg f ;; let surroundf ?level ?time ?tags fmt = surroundf ?level ?time ?tags (Lazy.force log) fmt let set_level_via_param () = set_level_via_param_lazy log module For_testing = struct let use_test_output ?(map_output = Fn.id) () = set_output [ Output.For_testing.create ~map_output ] ;; end end module Blocking : sig module Output : sig type t val create : (Message.t -> unit) -> t val stdout : t val stderr : t end val level : unit -> Level.t val set_level : Level.t -> unit val set_output : Output.t -> unit val set_time_source : Synchronous_time_source.t -> unit val set_transform : (Message.t -> Message.t) option -> unit val raw_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val info_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val error_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val debug_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val raw : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val info : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val error : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val debug : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val sexp : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val surround_s : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> (unit -> 'a) -> 'a val surroundf : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, (unit -> 'b) -> 'b) format4 -> 'a end = struct module Output = struct type t = Message.t -> unit let create = Fn.id let write print msg = print (Message.to_write_only_text msg) let stdout = write (Core.Printf.printf "%s\n%!") let stderr = write (Core.Printf.eprintf "%s\n%!") end let level : Level.t ref = ref `Info let write = ref Output.stderr let time_source = ref default_time_source let transform = ref None let set_level l = level := l let level () = !level let set_output output = write := output let set_time_source ts = time_source := ts let set_transform f = transform := f let write msg = if Scheduler.is_running () then failwith "Log.Global.Blocking function called after scheduler started"; let msg = match !transform with | None -> msg | Some f -> f msg in !write msg ;; let would_log msg_level = (* we don't need to test for empty output here because the interface only allows one Output.t and ensures that it is always set to something. *) Level.as_or_more_verbose_than ~log_level:(level ()) ~msg_level ;; let create_message ?level ?time ?tags msg = let time_source = !time_source in Message.create ?level ?time ~time_source ?tags msg ;; let gen ?level:msg_level ?time ?tags k = ksprintf (fun msg -> if would_log msg_level then ( let msg = `String msg in write (create_message ?level:msg_level ?time ?tags msg))) k ;; let string ?level ?time ?tags s = if would_log level then write (create_message ?level ?time ?tags (`String s)) ;; let raw ?time ?tags k = gen ?time ?tags k let debug ?time ?tags k = gen ~level:`Debug ?time ?tags k let info ?time ?tags k = gen ~level:`Info ?time ?tags k let error ?time ?tags k = gen ~level:`Error ?time ?tags k let sexp ?level ?time ?tags sexp = if would_log level then write (create_message ?level ?time ?tags (`Sexp sexp)) ;; let raw_s ?time ?tags the_sexp = sexp ?time ?tags the_sexp let debug_s ?time ?tags the_sexp = sexp ~level:`Debug ?time ?tags the_sexp let info_s ?time ?tags the_sexp = sexp ~level:`Info ?time ?tags the_sexp let error_s ?time ?tags the_sexp = sexp ~level:`Error ?time ?tags the_sexp let surround_s ?level ?time ?tags msg f = surround_s_gen ?tags ~try_with:Result.try_with ~map_return:(fun x ~f -> f x) ~log_sexp:(sexp ?level ?time) ~f msg ;; let surroundf ?level ?time ?tags fmt = surroundf_gen ?tags ~try_with:Result.try_with ~map_return:(fun x ~f -> f x) ~log_string:(string ?level ?time) fmt ;; end (* Programs that want simplistic single-channel logging can open this module. It provides a global logging facility to a single output type at a single level. *) module Global = Make_global () module Reader = struct let read_from_reader format r ~pipe_w = match format with | `Sexp | `Sexp_hum -> let sexp_pipe = Reader.read_sexps r in Pipe.transfer sexp_pipe pipe_w ~f:Message.t_of_sexp >>| fun () -> Pipe.close pipe_w | `Bin_prot -> let rec loop () = Reader.read_bin_prot r Message.bin_reader_t >>= function | `Eof -> Pipe.close pipe_w; return () | `Ok msg -> Pipe.write pipe_w msg >>= loop in loop () ;; let pipe_of_reader format reader = Pipe.create_reader ~close_on_exception:false (fun pipe_w -> read_from_reader format reader ~pipe_w) ;; let pipe format filename = Pipe.create_reader ~close_on_exception:false (fun pipe_w -> Reader.with_file filename ~f:(fun reader -> read_from_reader format reader ~pipe_w)) ;; module Expert = struct let read_one format reader = match format with | `Sexp | `Sexp_hum -> let%map sexp = Reader.read_sexp reader in Reader.Read_result.map sexp ~f:Message.t_of_sexp | `Bin_prot -> Reader.read_bin_prot reader Message.bin_reader_t ;; end end module For_testing = struct let create_output = Output.For_testing.create let create ~map_output level = let output = [ create_output ~map_output ] in create_internal ~output ~level ~on_error:`Raise ~time_source:None ~transform:None ;; end module Private = struct module Message = Message end include For_external_use_only async_unix-0.15.0/src/log.mli000066400000000000000000000513501420273305200160320ustar00rootroot00000000000000(** A library for general logging. Although this module is fully Async-safe it exposes almost no Deferreds. This is partially a design choice to minimize the impact of logging in code, and partially the result of organic design (i.e., older versions of this interface did the same thing). A (limited) [Blocking] module is supplied to accommodate the portion of a program that runs outside of Async. *) open! Core open! Import module Level : sig (** Describes both the level of a log and the level of a message sent to a log. There is an ordering to levels (`Debug < `Info < `Error), and a log set to a level will never display messages at a lower log level. Messages without a level are treated as `Info. *) type t = [ `Debug | `Info (** default level *) | `Error ] [@@deriving bin_io, compare, enumerate, sexp] include Stringable with type t := t val arg : t Command.Spec.Arg_type.t val as_or_more_verbose_than : log_level:t -> msg_level:t option -> bool module Stable : sig module V1 : sig type nonrec t = t [@@deriving bin_io, sexp] end end end module Message : sig type t [@@deriving sexp_of] val create : ?level:Level.t -> ?time:Time.t -> ?time_source:Synchronous_time_source.t (** [time_source] is used to provide a default time, if none is specified *) -> ?tags:(string * string) list -> [ `String of string | `Sexp of Sexp.t ] -> t val time : t -> Time.t val message : t -> string val raw_message : t -> [ `String of string | `Sexp of Sexp.t ] val level : t -> Level.t option val set_level : t -> Level.t option -> t val tags : t -> (string * string) list val add_tags : t -> (string * string) list -> t module Stable : sig module V0 : sig (** [V0.bin_t] is the [Message.bin_t] in jane-111.18 and before *) type nonrec t = t [@@deriving bin_io, sexp] end module V2 : sig type nonrec t = t [@@deriving bin_io, sexp] end end end module Rotation : sig (** Description of boundaries for file rotation. If all fields are [None] the file will never be rotated. Any field set to [Some] will cause rotation to happen when that boundary is crossed. Multiple boundaries may be set. Log rotation always causes incrementing rotation conditions (e.g., size) to reset. The condition [keep] is special and does not follow the rules above. When a log is rotated, [keep] is examined and logs that do not fall under its instructions are deleted. This deletion takes place on rotation only, and so may not happen. The meaning of keep options are: - [`All] -- never delete - [`Newer_than span] -- delete files with a timestamp older than [Time.sub (Time.now ()) span]. This normally means keeping files that contain at least one message logged within [span]. If [span] is short enough this option can delete a just-rotated file. - [`At_least i] -- keep the [i] most recent files Log rotation does not support symlinks, and you're encouraged to avoid them in production applications. Issues with symlinks: - You can't tail symlinks without being careful (e.g., you must remember to pass [-F] to [`tail`]). - Symlinks are hard to reason about when the program crashes, especially on startup (i.e., is the symlink pointing me at the right log file?). - Atomicity is hard. - Symlinks encourage tailing, which is a bad way to communicate information. - They complicate archiving processes (the symlink must be skipped). *) type t [@@deriving sexp_of] module type Id_intf = sig type t val create : ?time_source:Synchronous_time_source.t -> Time.Zone.t -> t (** For any rotation scheme that renames logs on rotation, this defines how to do the renaming. *) val rotate_one : t -> t val to_string_opt : t -> string option val of_string_opt : string option -> t option val cmp_newest_first : t -> t -> int end val create : ?messages:int -> ?size:Byte_units.t -> ?time:Time.Ofday.t -> ?zone:Time.Zone.t -> keep:[ `All | `Newer_than of Time.Span.t | `At_least of int ] -> naming_scheme: [ `Numbered | `Timestamped | `Dated | `User_defined of (module Id_intf) ] -> unit -> t (** Sane defaults for log rotation. Writes dated log files. Files are rotated every time the day changes in the given zone (uses the machine's zone by default). If the dated log file already exists, it's appended to. Logs are never deleted. Best practice is to have an external mechanism archive old logs for long-term storage. *) val default : ?zone:Time.Zone.t -> unit -> t end module Output : sig module Format : sig type machine_readable = [ `Sexp | `Sexp_hum | `Bin_prot ] [@@deriving sexp] type t = [ machine_readable | `Text ] [@@deriving sexp] module Stable : sig module V1 : sig type nonrec t = t [@@deriving sexp] end end end type t (** [create f] returns a [t], given a function that actually performs the final output work. It is the responsibility of the write function to contain all state, and to clean up after itself when it is garbage collected (which may require a finalizer). The function should avoid modifying the contents of the queue; it's reused for each [Output.t]. The "stock" output modules support a sexp and bin_prot output format, and other output modules should make efforts to support them as well where it is meaningful/appropriate to do so. [flush] should return a deferred that is fulfilled only when all previously written messages are durable (e.g., on disk, out on the network, etc.). It is automatically called on shutdown by [Log], but isn't automatically called at any other time. It can be called manually by calling [Log.flushed t]. The [unit Deferred] returned by the function provides an opportunity for pushback if that is important. Only one batch of messages will be "in flight" at any time based on this deferred. An optional [rotate] function may be given which will be called when [Log.rotate t] is called while this output is in effect. This is useful for programs that want very precise control over rotation. If [close] is provided it will be called when the log falls out of scope. (Note that it is not called directly, even if you close a log which is using this output, because outputs are sometimes reused.) *) val create : ?rotate:(unit -> unit Deferred.t) -> ?close:(unit -> unit Deferred.t) -> flush:(unit -> unit Deferred.t) -> (Message.t Queue.t -> unit Deferred.t) -> t (** [stdout] defaults to [format=`Text] *) val stdout : ?format:Format.t -> unit -> t (** [stderr] defaults to [format=`Text] *) val stderr : ?format:Format.t -> unit -> t val writer : Format.t -> Writer.t -> t (** The [perm] argument is passed through to [Writer.open_file], and so has the default behavior described there. *) val file : ?perm:Unix.file_perm -> Format.t -> filename:string -> t val rotating_file : ?perm:Unix.file_perm -> ?time_source:Synchronous_time_source.t -> ?log_on_rotation:(unit -> Message.t list) -> Format.t -> basename:string -> Rotation.t -> t (** Returns a tail of the filenames. When [rotate] is called, the previous filename is put on the tail *) val rotating_file_with_tail : ?perm:Unix.file_perm -> ?time_source:Synchronous_time_source.t -> ?log_on_rotation:(unit -> Message.t list) -> Format.t -> basename:string -> Rotation.t -> t * string Tail.t (** [filter_to_level] wraps an output and gives you a new output which only logs messages which are as/more verbose than [level]. This functionality is intended for when you have multiple outputs being displayed in different places, and they need to be at different levels. If you have one output (or multiple outputs all at the same level), it is better to set the [Log.t]'s output directly with [set_level], which is equivalent and more efficient. *) val filter_to_level : t -> level:Level.t -> t (** See {!Log_extended} for syslog and colorized console output. *) end module Blocking : sig (** Async programs often have a non-Async portion that runs before the scheduler begins to capture command line options, do setup, read configs, etc. This module provides limited global logging functions to be used during that period. Calling these functions after the scheduler has started will raise an exception. They otherwise behave similarly to the logging functions in the Async world. There are more detailed comments for the API below near the non-blocking signatures. *) module Output : sig type t val stdout : t val stderr : t (** See {!Log_extended} for syslog and colorized console output. *) val create : (Message.t -> unit) -> t end val level : unit -> Level.t val set_level : Level.t -> unit val set_output : Output.t -> unit val set_time_source : Synchronous_time_source.t -> unit val set_transform : (Message.t -> Message.t) option -> unit val raw : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val info : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val error : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val debug : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val raw_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val info_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val error_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val debug_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val sexp : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val surround_s : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> (unit -> 'a) -> 'a val surroundf : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, (unit -> 'b) -> 'b) format4 -> 'a end type t [@@deriving sexp_of] (** An interface for singleton logs. *) module type Global_intf = sig val log : t Lazy.t val level : unit -> Level.t val set_level : Level.t -> unit val set_output : Output.t list -> unit val get_output : unit -> Output.t list val set_on_error : [ `Raise | `Call of Error.t -> unit ] -> unit val get_time_source : unit -> Synchronous_time_source.t val set_time_source : Synchronous_time_source.t -> unit val get_transform : unit -> (Message.t -> Message.t) option val set_transform : (Message.t -> Message.t) option -> unit val would_log : Level.t option -> bool val set_level_via_param : unit -> unit Command.Param.t (** Functions that operate on a given log. In this case they operate on a single log global to the module. *) val raw : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val info : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val error : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val debug : ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val flushed : unit -> unit Deferred.t val rotate : unit -> unit Deferred.t val printf : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, unit) format4 -> 'a val raw_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val info_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val error_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val debug_s : ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val sexp : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> unit val string : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> string -> unit val message : Message.t -> unit val surround_s : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> Sexp.t -> (unit -> 'a Deferred.t) -> 'a Deferred.t val surroundf : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> ('a, unit, string, (unit -> 'b Deferred.t) -> 'b Deferred.t) format4 -> 'a module For_testing : sig (** Change the output of the global log so that it only prints the bodies of messages to stdout, discarding any information about tags, levels, or timestamps. [map_output] can be used to transform messages before they make it to stdout; by default it is [Fn.id]. This is equivalent to: [Log.Global.set_output [ Log.For_testing.create_output ~map_output ]] *) val use_test_output : ?map_output:(string -> string) -> unit -> unit end end (** This functor can be called to generate "singleton" logging modules. *) module Make_global () : Global_intf (** Programs that want simplistic single-channel logging can open this module. It provides a global logging facility to a single output type at a single level. More nuanced logging can be had by using the functions that operate on a distinct [Log.t] type. *) module Global : Global_intf (** Sets the log level via a flag, if provided. *) val set_level_via_param : t -> unit Command.Param.t (** Messages sent at a level less than the current level will not be output. *) val set_level : t -> Level.t -> unit (** Returns the last level passed to [set_level], which will be the log level checked as a threshold against the level of the next message sent. *) val level : t -> Level.t (** Changes the output type of the log, which can be useful when daemonizing. The new output type will be applied to all subsequent messages. *) val set_output : t -> Output.t list -> unit val get_output : t -> Output.t list (** Changes the time source of the log, which controls the default timestamp on messages. *) val get_time_source : t -> Synchronous_time_source.t val set_time_source : t -> Synchronous_time_source.t -> unit (** Changes the [transform] function within log. This allows you to *synchronously* change things about the message at the time that they were written. The transform function *will not* be called if the initial message is of a level that would not currently be logged. The transform function *will* be called if even if there are no log outputs. *) val get_transform : t -> (Message.t -> Message.t) option val set_transform : t -> (Message.t -> Message.t) option -> unit (** If [`Raise] is given, then background errors raised by logging will be raised to the monitor that was in scope when [create] was called. Errors can be redirected anywhere by providing [`Call f]. *) val get_on_error : t -> [ `Raise | `Call of Error.t -> unit ] val set_on_error : t -> [ `Raise | `Call of Error.t -> unit ] -> unit (** Any call that writes to a log after [close] is called will raise. *) val close : t -> unit Deferred.t (** Returns true if [close] has been called. *) val is_closed : t -> bool (** Returns a [Deferred.t] that is fulfilled when the last message delivered to [t] before the call to [flushed] is out the door. *) val flushed : t -> unit Deferred.t (** Informs the current [Output]s to rotate if possible. *) val rotate : t -> unit Deferred.t (** Creates a new log. See [set_level], [set_on_error], [set_output], [set_time_source], and [set_transform] for more. *) val create : level:Level.t -> output:Output.t list -> on_error:[ `Raise | `Call of Error.t -> unit ] -> ?time_source:Synchronous_time_source.t -> ?transform:(Message.t -> Message.t) -> unit -> t (** Creates a copy of a log, which has the same settings and logs to the same outputs. *) val copy : t -> t (** Printf-like logging for messages at each log level or raw (no level) messages. Raw messages still include a timestamp. *) val raw : ?time:Time.t -> ?tags:(string * string) list -> t -> ('a, unit, string, unit) format4 -> 'a val debug : ?time:Time.t -> ?tags:(string * string) list -> t -> ('a, unit, string, unit) format4 -> 'a val info : ?time:Time.t -> ?tags:(string * string) list -> t -> ('a, unit, string, unit) format4 -> 'a val error : ?time:Time.t -> ?tags:(string * string) list -> t -> ('a, unit, string, unit) format4 -> 'a (** Generalized printf-style logging. *) val printf : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> t -> ('a, unit, string, unit) format4 -> 'a (** Sexp logging for messages at each log level or raw (no level) messages. Raw messages still include a timestamp *) val raw_s : ?time:Time.t -> ?tags:(string * string) list -> t -> Sexp.t -> unit val info_s : ?time:Time.t -> ?tags:(string * string) list -> t -> Sexp.t -> unit val error_s : ?time:Time.t -> ?tags:(string * string) list -> t -> Sexp.t -> unit val debug_s : ?time:Time.t -> ?tags:(string * string) list -> t -> Sexp.t -> unit (** Generalized sexp-style logging. *) val sexp : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> t -> Sexp.t -> unit (** Log a string directly. *) val string : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> t -> string -> unit (** Log a pre-created message. *) val message : t -> Message.t -> unit (** [surround t message f] logs [message] and a UUID once before calling [f] and again after [f] returns or raises. If [f] raises, the second message will include the exception, and [surround] itself will re-raise the exception tagged with [message]. As usual, the logging happens only if [level] exceeds the minimum level of [t]. *) val surround_s : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> t -> Sexp.t -> (unit -> 'a Deferred.t) -> 'a Deferred.t val surroundf : ?level:Level.t -> ?time:Time.t -> ?tags:(string * string) list -> t -> ('a, unit, string, (unit -> 'b Deferred.t) -> 'b Deferred.t) format4 -> 'a (** [would_log] returns true if a message at the given log level would be logged if sent immediately. This will return [false] if there are no outputs for the log, unless there is a [transform] set. *) val would_log : t -> Level.t option -> bool module Reader : sig (** [pipe format filename] returns a pipe of all the messages in the log. Errors encountered when opening or reading the file will be thrown as exceptions into the monitor current at the time [pipe] is called. *) val pipe : [< Output.Format.machine_readable ] -> string -> Message.t Pipe.Reader.t val pipe_of_reader : [< Output.Format.machine_readable ] -> Reader.t -> Message.t Pipe.Reader.t module Expert : sig (** [read_one format reader] reads a single log message from the reader, advancing the position of the reader to the next log entry. *) val read_one : [< Output.Format.machine_readable ] -> Reader.t -> Message.t Reader.Read_result.t Deferred.t end end module For_testing : sig (** [create_output ~map_output] creates a [Log.Output.t] which will print only [Message.message] to stdout, discarding any information about tags, levels, or timestamps. [map_output] will be applied to each string before printing, and is expected to be used to replace portions of output or identify which log a message came from. This function is best used with existing Log.ts, e.g. to replace Log.Global's outputs in expect tests. If you just want a full Log.t, see [create] below. *) val create_output : map_output:(string -> string) -> Output.t (** [create_log ~map_output level] creates a [Log.t] with its level set to [level] using the output returned by [create_output], and an [on_error] value of `Raise. *) val create : map_output:(string -> string) -> Level.t -> t end (**/**) module Private : sig module Message : sig type t = Message.t [@@deriving of_sexp] include Equal.S with type t := t val to_write_only_text : ?zone:Time.Zone.t -> t -> string module Stable : sig module Version : sig type t [@@deriving of_sexp] end module V0 : sig type t = Message.t [@@deriving sexp_of] end module V2 : sig type t = Message.t [@@deriving sexp_of] end end end end async_unix-0.15.0/src/process.ml000066400000000000000000000203751420273305200165610ustar00rootroot00000000000000open Core open Import module Unix = Unix_syscalls type env = Unix.env [@@deriving sexp] type t = { pid : Pid.t ; stdin : Writer.t ; stdout : Reader.t ; stderr : Reader.t ; prog : string ; args : string list ; working_dir : string option ; env : env ; wait : Unix.Exit_or_signal.t Deferred.t Lazy.t } [@@deriving fields, sexp_of] type 'a create = ?argv0:string -> ?buf_len:int -> ?env:env -> ?prog_search_path:string list -> ?stdin:string -> ?working_dir:string -> ?setpgid:Core_unix.Pgid.t -> prog:string -> args:string list -> unit -> 'a Deferred.t let create ?argv0 ?buf_len ?(env = `Extend []) ?prog_search_path ?stdin:write_to_stdin ?working_dir ?setpgid ~prog ~args () = match%map In_thread.syscall ~name:"create_process_env" (fun () -> Core_unix.create_process_env ~prog ~args ~env ?working_dir ?prog_search_path ?argv0 ?setpgid ()) with | Error exn -> Or_error.of_exn exn | Ok { pid; stdin; stdout; stderr } -> let create_fd name file_descr = Fd.create Fifo file_descr (Info.create "child process" ~here:[%here] (name, `pid pid, `prog prog, `args args) [%sexp_of: string * [ `pid of Pid.t ] * [ `prog of string ] * [ `args of string list ]]) in let stdin = let fd = create_fd "stdin" stdin in match write_to_stdin with | None -> Writer.create ?buf_len fd | Some _ -> Writer.create ?buf_len fd ~buffer_age_limit:`Unlimited ~raise_when_consumer_leaves:false in let t = { pid ; stdin ; stdout = Reader.create ?buf_len (create_fd "stdout" stdout) ; stderr = Reader.create ?buf_len (create_fd "stderr" stderr) ; prog ; args ; working_dir ; env ; wait = lazy (Unix.waitpid_prompt pid) } in (match write_to_stdin with | None -> () | Some write_to_stdin -> Writer.write t.stdin write_to_stdin); Ok t ;; let create_exn ?argv0 ?buf_len ?env ?prog_search_path ?stdin ?working_dir ?setpgid ~prog ~args () = create ?argv0 ?buf_len ?env ?prog_search_path ?stdin ?working_dir ?setpgid ~prog ~args () >>| ok_exn ;; module Lines_or_sexp = struct type t = | Lines of string list | Sexp of Sexp.t let sexp_of_t t = match t with | Lines ([] | [ "" ]) -> [%sexp ""] | Lines lines -> [%sexp (lines : string list)] | Sexp sexp -> sexp ;; let create string = try Sexp (Sexp.of_string string) with | _ -> Lines (String.split ~on:'\n' string) ;; end module Output = struct module Stable = struct module V1 = struct type t = { stdout : string ; stderr : string ; exit_status : Unix.Exit_or_signal.t } [@@deriving compare, sexp] end end include Stable.V1 let sexp_of_t t = [%message "" ~stdout:(Lines_or_sexp.create t.stdout : Lines_or_sexp.t) ~stderr:(Lines_or_sexp.create t.stderr : Lines_or_sexp.t) ~exit_status:(t.exit_status : Unix.Exit_or_signal.t)] ;; end let wait t = force t.wait let collect_output_and_wait t = let stdout = Reader.contents t.stdout in let stderr = Reader.contents t.stderr in let%bind () = Writer.close t.stdin ~force_close:(Deferred.never ()) in let%bind exit_status = wait t in let%bind stdout = stdout in let%bind stderr = stderr in return { Output.stdout; stderr; exit_status } ;; module Failure = struct let should_drop_env = function | `Extend [] | `Override [] -> true | `Extend (_ :: _) | `Override (_ :: _) | `Replace _ | `Replace_raw _ -> false ;; type t = { prog : string ; args : string list ; working_dir : string option [@sexp.option] ; env : env [@sexp_drop_if should_drop_env] ; exit_status : Unix.Exit_or_signal.error ; stdout : Lines_or_sexp.t ; stderr : Lines_or_sexp.t } [@@deriving sexp_of] end type 'a collect = ?accept_nonzero_exit:int list -> t -> 'a Deferred.t let collect_stdout_and_wait ?(accept_nonzero_exit = []) t = let%map { stdout; stderr; exit_status } = collect_output_and_wait t in match exit_status with | Ok () -> Ok stdout | Error (`Exit_non_zero n) when List.mem accept_nonzero_exit n ~equal:Int.equal -> Ok stdout | Error exit_status -> let { prog; args; working_dir; env; _ } = t in Or_error.error "Process.run failed" { Failure.prog ; args ; working_dir ; env ; exit_status ; stdout = Lines_or_sexp.create stdout ; stderr = Lines_or_sexp.create stderr } [%sexp_of: Failure.t] ;; let map_collect collect f ?accept_nonzero_exit t = let%map a = collect ?accept_nonzero_exit t in f a ;; let collect_stdout_and_wait_exn = map_collect collect_stdout_and_wait ok_exn let collect_stdout_lines_and_wait = map_collect collect_stdout_and_wait (Or_error.map ~f:String.split_lines) ;; let collect_stdout_lines_and_wait_exn = map_collect collect_stdout_lines_and_wait ok_exn type 'a run = ?accept_nonzero_exit:int list -> ?argv0:string -> ?env:env -> ?prog_search_path:string list -> ?stdin:string -> ?working_dir:string -> prog:string -> args:string list -> unit -> 'a Deferred.t let run ?accept_nonzero_exit ?argv0 ?env ?prog_search_path ?stdin ?working_dir ~prog ~args () = match%bind create ?argv0 ?env ?prog_search_path ?stdin ?working_dir ~prog ~args () with | Error _ as e -> return e | Ok t -> collect_stdout_and_wait ?accept_nonzero_exit t ;; let map_run run f ?accept_nonzero_exit ?argv0 ?env ?prog_search_path ?stdin ?working_dir ~prog ~args () = let%map a = run ?accept_nonzero_exit ?argv0 ?env ?prog_search_path ?stdin ?working_dir ~prog ~args () in f a ;; let run_exn = map_run run ok_exn let run_lines = map_run run (Or_error.map ~f:String.split_lines) let run_lines_exn = map_run run_lines ok_exn let run_expect_no_output ?accept_nonzero_exit ?argv0 ?env ?prog_search_path ?stdin ?working_dir ~prog ~args () = match%map run ?accept_nonzero_exit ?argv0 ?env ?prog_search_path ?stdin ?working_dir ~prog ~args () with | Error _ as err -> err | Ok "" -> Ok () | Ok non_empty_output -> Or_error.error "Process.run_expect_no_output: non-empty output" () (fun () -> [%sexp { prog : string; args : string list; output = (non_empty_output : string) }]) ;; let run_expect_no_output_exn = map_run run_expect_no_output ok_exn let send_signal_compat t signal = (* We don't force the lazy (and therefore we don't reap the PID) here. We only do that if the user calls [wait] explicitly. *) if Lazy.is_val t.wait && Deferred.is_determined (Lazy.force t.wait) then (* The process was reaped, so it's not safe to send signals to this pid. *) `No_such_process else ( match Signal_unix.send signal (`Pid t.pid) with | `No_such_process -> (* Normally this should not be reachable: even for a zombie process (a process that has already been terminated, but wasn't waited for), the [kill] system call returns successfully. And we know that we haven't waited for this process because otherwise [t.wait] would have been determined. However, we do expose the [pid] so the users can and do sometimes call [Unix.waitpid] on that pid, which can still lead to the race we are trying to prevent. The right fix would be to prevent users from calling [waitpid] on our pid. *) `No_such_process | `Ok -> `Ok) ;; let send_signal_compat_exn t signal = match (send_signal_compat t signal : [ `Ok | `No_such_process ]) with | `Ok -> () | `No_such_process -> failwithf "Process.send_signal_compat_exn %s pid:%s" (Signal.to_string signal) (Pid.to_string t.pid) () ;; let send_signal t signal = ignore (send_signal_compat t signal : [ `Ok | `No_such_process ]) ;; async_unix-0.15.0/src/process.mli000066400000000000000000000160711420273305200167300ustar00rootroot00000000000000(** [Async.Process] is for creating child processes of the current process, and communicating with children via their stdin, stdout, and stderr. [Async.Process] is the Async analog of [Core_unix.create_process] and related functions. *) open! Core open! Import type t [@@deriving sexp_of] (** accessors *) val pid : t -> Pid.t val stdin : t -> Writer.t val stdout : t -> Reader.t val stderr : t -> Reader.t type env = Unix.env [@@deriving sexp] (** [create ~prog ~args ()] uses [Core_unix.create_process_env] to create a child process that runs the executable [prog] with [args] as arguments. This creates pipes to communicate with the child process's [stdin], [stdout], and [stderr]. The caller is responsible for closing all these pipes. A lot of calls in the [Reader] module will close the underlying fd (e.g. iterating on [Reader.pipe]). You likely will have to explicitly call [Writer.close] on the [stdin] writer unless you call [collect_output_and_wait]. Unlike [exec], [args] should not include [prog] as the first argument. If [buf_len] is supplied, it determines the size of the reader and writer buffers used to communicate with the child process's [stdin], [stdout], and [stderr]. If [stdin] is supplied, then the writer to the child's stdin will have [~raise_when_consumer_leaves:false] and [~buffer_age_limit:`Unlimited], which makes it more robust. [env] specifies the environment of the child process. If [working_dir] is supplied, then the child process will [chdir()] there before calling [exec()]. If [argv0] is given, it is used (instead of [prog]) as the first element of the [argv] array passed to [exec]. [create] returns [Error] if it is unable to create the child process. This can happen in any number of situations (unable to fork, unable to create the pipes, unable to cd to [working_dir], unable to [exec] etc.). [create] does not return [Error] if the binary exits with non-zero exit code; instead, it returns [OK t], where [wait t] returns an [Error]. See [Core_unix.create_process_env] for more details. *) type 'a create = ?argv0:string -> ?buf_len:int -> ?env:env (** default is [`Extend []] *) -> ?prog_search_path:string list -> ?stdin:string -> ?working_dir:string -> ?setpgid:Unix.Pgid.t -> prog:string -> args:string list -> unit -> 'a Deferred.t val create : t Or_error.t create val create_exn : t create (** [wait t = Unix.waitpid (pid t)]. [wait]'s result becomes determined when the child process terminates, via exit or signal. [wait] does not touch [stdin], [stdout] or [stderr]. The caller should ensure that [stdout] and [stderr] are being drained in the background to avoid the child process blocking on a write due to pushback. See [collect_output_and_wait] for a higher-level alternative that handles this. *) val wait : t -> Unix.Exit_or_signal.t Deferred.t module Output : sig type t = { stdout : string ; stderr : string ; exit_status : Unix.Exit_or_signal.t } [@@deriving compare, sexp_of] module Stable : sig module V1 : sig type nonrec t = t [@@deriving compare, sexp] end end end (** [collect_output_and_wait t] closes [stdin t] and then begins collecting the output produced on [t]'s [stdout] and [stderr], continuing to collect output until [t] terminates and the pipes for [stdout] and [stderr] are closed. Usually when [t] terminates, the pipes are closed; however, [t] could fork other processes which survive after [t] terminates and in turn keep the pipes open -- [collect_output_and_wait] will not become determined until both pipes are closed in all descendant processes. *) val collect_output_and_wait : t -> Output.t Deferred.t (** [run] [create]s a process, feeds it [stdin] if provided, and [wait]s for it to complete. If the process exits with an acceptable status, then [run] returns its stdout. If the process exits unacceptably, then [run] returns an error indicating what went wrong that includes stdout and stderr. Acceptable statuses are zero, and any nonzero values specified in [accept_nonzero_exit]. Some care is taken so that an error displays nicely as a sexp---in particular, if the child's output can already be parsed as a sexp, then it will display as a sexp (rather than a sexp embedded in a string). Also, if the output isn't a sexp, it will be split on newlines into a list of strings, so that it displays on multiple lines rather than a single giant line with embedded "\n"'s. [run_lines] is like [run] but returns the lines of stdout as a string list, using [String.split_lines]. [run_expect_no_output] is like [run] but expects the command to produce no output, and returns an error if the command does produce output. *) type 'a run = ?accept_nonzero_exit:int list (** default is [] *) -> ?argv0:string -> ?env:env (** default is [`Extend []] *) -> ?prog_search_path:string list -> ?stdin:string -> ?working_dir:string -> prog:string -> args:string list -> unit -> 'a Deferred.t val run : string Or_error.t run val run_exn : string run val run_lines : string list Or_error.t run val run_lines_exn : string list run val run_expect_no_output : unit Or_error.t run val run_expect_no_output_exn : unit run (** [collect_stdout_and_wait] and [collect_stdout_lines_and_wait] are like [run] and [run_lines] but work from an existing process instead of creating a new one. *) type 'a collect = ?accept_nonzero_exit:int list (** default is [] *) -> t -> 'a Deferred.t val collect_stdout_and_wait : string Or_error.t collect val collect_stdout_and_wait_exn : string collect val collect_stdout_lines_and_wait : string list Or_error.t collect val collect_stdout_lines_and_wait_exn : string list collect (** Sends a signal to this process. This is safe to call concurrently with [wait t], even if the Pid is reused after the process died. If the process was already terminated, the call succeeds and silently does nothing, regardless of whether or not the process was waited for. *) val send_signal : t -> Signal.t -> unit (** Similar to [send_signal], but additionally reports if a signal was actually sent, or a process was already terminated and waited for. Note that if you never called [wait] on this process, you will always get [`Ok], which can be surprising. This function is exposed for compatibility with the code that used [Signal_unix.send]. *) val send_signal_compat : t -> Signal.t -> [ `Ok | `No_such_process ] (** Similar to [send_signal_compat], but raises an exception on [`No_such_process]. Used to migrate the code that uses [Signal_unix.send_exn]. *) val send_signal_compat_exn : t -> Signal.t -> unit (** [Lines_or_sexp] is useful for rendering a string nicely in a sexp, avoiding quoting if the string is multi-line or was produced by converting a sexp to a string. [Output.sexp_of_t] uses [Lines_or_sexp] to nicely render stdout and stderr of a child process. *) module Lines_or_sexp : sig type t [@@deriving sexp_of] val create : string -> t end async_unix-0.15.0/src/raw_fd.ml000066400000000000000000000301451420273305200163410ustar00rootroot00000000000000open Core open Import let debug = Debug.fd module File_descr = Unix.File_descr module Kind = struct type t = | Char | Fifo | File | Socket of [ `Unconnected | `Bound | `Passive | `Active ] [@@deriving sexp_of] end module State = struct (* [State] is is used to keep track of when the file descriptor is in use or being closed. Here are the allowed transitions. Open --> Close_requested --> Closed *) type t = (* [Close_requested (execution_context, do_close_syscall)] indicates that [Fd.close t] has been called, but that we haven't yet started the close() syscall, because there are still active syscalls using the file descriptor. Once there are no active syscalls, we enqueue a job to [do_close_syscall] in [execution_context]. *) | Close_requested of Execution_context.t * (unit -> unit) (* [Closed] indicates that there are no more active syscalls and we have started the close() syscall. *) | Closed (* [Open] is the initial state of a file descriptor, and the normal state when it is in use. It indicates that it has not not yet been closed. The argument is an ivar to be filled when [close] is called. *) | Open of unit Ivar.t [@@deriving sexp_of] let transition_is_allowed t t' = match t, t' with | Open _, Close_requested _ | Close_requested _, Closed -> true | _ -> false ;; let is_open = function | Open _ -> true | Close_requested _ | Closed -> false ;; end type ready_to_result = [ `Ready | `Bad_fd | `Closed | `Interrupted | `Unsupported ] [@@deriving sexp_of] module Watching = struct (* Every fd can be monitored by a file_descr_watcher for read, for write, for both, or for neither. Each fd also has its own notion, independent of the file_descr_watcher, of a [Watching.t], for both read and write that indicates the desired state of the file_descr_watcher for this fd. That desired state is maintained only in the fd while async jobs are running, and is then synchronized with the file_descr_watcher's notion, via calls to [File_descr_watcher.set], just prior to asking the file_descr_watcher to check fds for ready I/O. Initially, watching state starts as [Not_watching]. When one initially requests that the fd be monitored via [request_start_watching], the state transitions to [Watch_once] or [Watch_repeatedly]. After the file_descr_watcher detects I/O is available, the job in [Watch_repeatedly] is enqueued, or the ivar in [Watch_once] is filled and the state transitions to [Stop_requested]. Or, if one calls [request_stop_watching], the state transitions to [Stop_requested]. Finally, [Stop_requested] will transition to [Not_watching] when the desired state is synchronized with the file_descr_watcher. *) type t = | Not_watching | Watch_once of ready_to_result Ivar.t | Watch_repeatedly of Job.t * [ `Bad_fd | `Closed | `Interrupted | `Unsupported ] Ivar.t | Stop_requested [@@deriving sexp_of] let invariant t : unit = try match t with | Not_watching | Stop_requested -> () | Watch_once ivar -> assert (Ivar.is_empty ivar) | Watch_repeatedly (_, ivar) -> assert (Ivar.is_empty ivar) with | exn -> raise_s [%message "Watching.invariant failed" (exn : exn) ~watching:(t : t)] ;; end module Nonblock_status = struct (* Encodes the knowledge of the O_NONBLOCK flag of an fd. *) type t = | Blocking | Nonblocking | Unknown [@@deriving sexp_of] end module T = struct type t = { file_descr : File_descr.t ; (* [info] is for debugging info. It is mutable because it changes after [bind], [listen], or[connect]. *) mutable info : Info.t ; (* [kind] is mutable because it changes after [bind], [listen], or [connect]. *) mutable kind : Kind.t ; (* if [can_set_nonblock] is true, async will switch the underlying file descriptor into nonblocking mode any time a non-blocking operation is attempted. It can be [false] if the user explicitly tells async to avoid modifying that flag on the underlying fd, or if Async detects that the file descriptor doesn't support nonblocking I/O. *) mutable can_set_nonblock : bool ; mutable nonblock_status : Nonblock_status.t ; mutable state : State.t ; watching : Watching.t Read_write_pair.Mutable.t ; (* [watching_has_changed] is true if [watching] has changed since the last time [watching] was synchronized with the file_descr_watcher. In this case, the fd appears in the scheduler's [fds_whose_watching_has_changed] list so that it can be synchronized later. *) mutable watching_has_changed : bool ; (* [num_active_syscalls] is used to ensure that we don't call [close] on a file descriptor until there are no active system calls involving that file descriptor. This prevents races in which the OS assigns that file descriptor to a new open file, and thus a system call deals with the wrong open file. If the state of an fd is [Close_requested], then once [num_active_syscalls] drops to zero, the close() syscall will start and the state will transition to [Closed], thus preventing further system calls from using the file descriptor. [num_active_syscalls] is abused slightly to include the syscall to the file_descr_watcher to check for ready I/O. Watching for read and for write each potentially count for one active syscall. *) mutable num_active_syscalls : int ; (* [close_finished] becomes determined after the file descriptor has been closed and the underlying close() system call has finished. *) close_finished : unit Ivar.t } [@@deriving fields, sexp_of] type t_hum = t let sexp_of_t_hum { file_descr; info; kind; _ } = let file_descr = if am_running_inline_test then [%sexp "_"] else [%sexp (file_descr : File_descr.t)] in [%sexp { file_descr : Sexp.t; info : Info.t; kind : Kind.t }] ;; end include T let equal (t : t) t' = phys_equal t t' let invariant t : unit = try let check f field = f (Field.get field t) in Fields.iter ~info:ignore ~file_descr:ignore ~kind:ignore ~can_set_nonblock:ignore ~nonblock_status:ignore ~state:ignore ~watching: (check (fun watching -> Read_write_pair.iter watching ~f:Watching.invariant)) ~watching_has_changed:ignore ~num_active_syscalls: (check (fun num_active_syscalls -> assert (t.num_active_syscalls >= 0); let watching read_or_write = match Read_write_pair.get t.watching read_or_write with | Not_watching -> 0 | Stop_requested | Watch_once _ | Watch_repeatedly _ -> 1 in assert (t.num_active_syscalls >= watching `Read + watching `Write); match t.state with | Closed -> assert (num_active_syscalls = 0) | Close_requested _ | Open _ -> ())) ~close_finished: (check (fun close_finished -> match t.state with | Closed -> () | Close_requested _ -> assert (Ivar.is_empty close_finished) | Open close_started -> assert (Ivar.is_empty close_finished); assert (Ivar.is_empty close_started))) with | exn -> raise_s [%message "Fd.invariant failed" (exn : exn) ~fd:(t : t)] ;; let to_int t = File_descr.to_int t.file_descr let create ?(avoid_setting_nonblock = false) (kind : Kind.t) file_descr info = let can_set_nonblock = if avoid_setting_nonblock then false else ( match kind with (* No point in setting nonblocking for files. Unix doesn't care. *) | File -> false (* We don't use nonblocking I/O for char devices because we don't want to change the blocking status of TTYs, which would affect all processes currently attached to that TTY and even persist after this process terminates. Also, /dev/null is a char device not supported by epoll. We don't really care about doing nonblocking I/O on other character devices, e.g. /dev/random. *) | Char -> false | Fifo -> true | Socket _ -> (* All one can do on a `Bound socket is listen() to it, and we don't use listen() in a nonblocking way. `Unconnected sockets support nonblocking so we can connect() them. `Passive sockets support nonblocking so we can accept() them. `Active sockets support nonblocking so we can read() and write() them. We need the sockets to be in nonblocking mode for [`Unconnected] and [`Passive] sockets, because [accept_interruptible] and [connect_interruptible] in unix_syscalls.ml assume that such sockets are nonblocking. On the other hand, there is no such assumption about [`Active] sockets. In any case, returning [true] here makes sense. Not only is it harmless in case we don't end up using it, but this field is also not updated by socket state transitions ([Fd.Private.replace]), so its value needs to be the same across the different socket states. *) true) in let t = { info ; file_descr ; kind ; can_set_nonblock ; nonblock_status = Nonblock_status.Unknown ; state = State.Open (Ivar.create ()) ; watching = Read_write_pair.create_both Watching.Not_watching ; watching_has_changed = false ; num_active_syscalls = 0 ; close_finished = Ivar.create () } in if debug then Debug.log "Fd.create" t [%sexp_of: t]; t ;; let inc_num_active_syscalls t = match t.state with | Close_requested _ | Closed -> `Already_closed | Open _ -> t.num_active_syscalls <- t.num_active_syscalls + 1; `Ok ;; let set_state t new_state = if debug then Debug.log "Fd.set_state" (new_state, t) [%sexp_of: State.t * t]; if State.transition_is_allowed t.state new_state then t.state <- new_state else raise_s [%message "Fd.set_state attempted disallowed state transition" ~fd:(t : t) (new_state : State.t)] ;; let is_open t = State.is_open t.state let is_closed t = not (is_open t) let determine_nonblock_status t = match t.nonblock_status with | Unknown -> let flags = Core_unix.fcntl_getfl t.file_descr in let nonblock = Core_unix.Open_flags.is_subset Core_unix.Open_flags.nonblock ~of_:flags in t.nonblock_status <- (match nonblock with | false -> Blocking | true -> Nonblocking); nonblock | Nonblocking -> true | Blocking -> false ;; let supports_nonblock t = if t.can_set_nonblock then true else determine_nonblock_status t let set_nonblock_if_necessary ?(nonblocking = false) t = if nonblocking then ( match determine_nonblock_status t with | true -> () | false -> if t.can_set_nonblock then ( Unix.set_nonblock t.file_descr; t.nonblock_status <- Nonblocking) else raise_s [%message "Fd.set_nonblock_if_necessary called on fd that does not support nonblock" ~fd:(t : t)]) ;; let with_file_descr_exn ?nonblocking t f = if is_closed t then raise_s [%message "Fd.with_file_descr_exn got closed fd" ~_:(t : t)] else ( set_nonblock_if_necessary t ?nonblocking; f t.file_descr) ;; let with_file_descr ?nonblocking t f = if is_closed t then `Already_closed else ( try set_nonblock_if_necessary t ?nonblocking; `Ok (f t.file_descr) with | exn -> `Error exn) ;; let syscall ?nonblocking t f = with_file_descr t ?nonblocking (fun file_descr -> Result.ok_exn (Syscall.syscall (fun () -> f file_descr))) ;; let syscall_exn ?nonblocking t f = match syscall t f ?nonblocking with | `Ok a -> a | `Already_closed -> raise_s [%message "Fd.syscall_exn got closed fd" ~_:(t : t)] | `Error exn -> raise exn ;; let syscall_result_exn ?nonblocking t a f = if is_closed t then raise_s [%message "Fd.syscall_result_exn got closed fd" ~_:(t : t)] else ( set_nonblock_if_necessary t ?nonblocking; Syscall.syscall_result2 t.file_descr a f) ;; async_unix-0.15.0/src/raw_scheduler.ml000066400000000000000000001211651420273305200177310ustar00rootroot00000000000000open Core open Import module Fd = Raw_fd module Watching = Fd.Watching module Signal = Core.Signal module Timerfd = Linux_ext.Timerfd module Tsc = Time_stamp_counter let debug = Debug.scheduler module File_descr_watcher = struct (* A file descriptor watcher implementation + a watcher. We need the file-descr watcher as a first-class value to support choosing which file-descr watcher to use in [go_main]. We could define [t] as [Epoll of ... | Select of ...] and dispatch every call, but it is simpler to just pack the file descriptor watcher with its associated functions (OO-programming with modules...). *) module type S = sig include File_descr_watcher_intf.S val watcher : t end type t = (module S) let sexp_of_t t = let module F = (val t : S) in (* Include the backend information so we know which one it is. *) [%sexp_of: Config.File_descr_watcher.t * F.t] (F.backend, F.watcher) ;; end include Async_kernel_scheduler type t = { (* The scheduler [mutex] must be locked by all code that is manipulating scheduler data structures, which is almost all async code. The [mutex] is automatically locked in the main thread when the scheduler is first created. A [Nano_mutex] keeps track of which thread is holding the lock. This means we can detect errors in which code incorrectly accesses async from a thread not holding the lock. We do this when [detect_invalid_access_from_thread = true]. We also detect errors in which code tries to acquire the async lock while it already holds it, or releases the lock when it doesn't hold it. *) mutex : Nano_mutex.t ; mutable is_running : bool ; mutable have_called_go : bool ; (* [fds_whose_watching_has_changed] holds all fds whose watching has changed since the last time their desired state was set in the [file_descr_watcher]. *) fds_whose_watching_has_changed : Fd.t Stack.t ; file_descr_watcher : File_descr_watcher.t ; mutable time_spent_waiting_for_io : Tsc.Span.t ; (* [fd_by_descr] holds every file descriptor that Async knows about. Fds are added when they are created, and removed when they transition to [Closed]. *) fd_by_descr : Fd_by_descr.t ; (* If we are using a file descriptor watcher that does not support sub-millisecond timeout, [timerfd] contains a timerfd used to handle the next expiration. [timerfd_set_at] holds the the time at which [timerfd] is set to expire. This lets us avoid calling [Time_ns.now] and [Linux_ext.Timerfd.set_after] unless we need to change that time. *) mutable timerfd : Linux_ext.Timerfd.t option ; mutable timerfd_set_at : Time_ns.t ; (* A distinguished thread, called the "scheduler" thread, is continually looping, checking file descriptors for I/O and then running a cycle. It manages the [file_descr_watcher] and runs signal handlers. [scheduler_thread_id] is mutable because we create the scheduler before starting the scheduler running. Once we start running the scheduler, [scheduler_thread_id] is set and never changes again. *) mutable scheduler_thread_id : int ; (* The [interruptor] is used to wake up the scheduler when it is blocked on the file descriptor watcher. *) interruptor : Interruptor.t ; signal_manager : Raw_signal_manager.t ; (* The [thread_pool] is used for making blocking system calls in threads other than the scheduler thread, and for servicing [In_thread.run] requests. *) thread_pool : Thread_pool.t ; (* [handle_thread_pool_stuck] is called once per second if the thread pool is"stuck", i.e has not completed a job for one second and has no available threads. *) mutable handle_thread_pool_stuck : Thread_pool.t -> stuck_for:Time_ns.Span.t -> unit ; mutable next_tsc_calibration : Tsc.t ; kernel_scheduler : Kernel_scheduler.t ; (* [have_lock_do_cycle] is used to customize the implementation of running a cycle. E.g. in Ecaml it is set to something that causes Emacs to run a cycle. *) mutable have_lock_do_cycle : (unit -> unit) option (* configuration*) ; mutable max_inter_cycle_timeout : Max_inter_cycle_timeout.t ; mutable min_inter_cycle_timeout : Min_inter_cycle_timeout.t ; (* [initialized_at] is the call stack from when the scheduler was initialized. It's generally more confusing than useful if it's shown on crash, so we omit it from the sexp. *) initialized_at : (Backtrace.t[@sexp.opaque]) } [@@deriving fields, sexp_of] let max_num_threads t = Thread_pool.max_num_threads t.thread_pool let max_num_open_file_descrs t = Fd_by_descr.capacity t.fd_by_descr let current_execution_context t = Kernel_scheduler.current_execution_context t.kernel_scheduler ;; let with_execution_context t context ~f = Kernel_scheduler.with_execution_context t.kernel_scheduler context ~f ;; let create_fd ?avoid_setting_nonblock t kind file_descr info = let fd = Fd.create ?avoid_setting_nonblock kind file_descr info in match Fd_by_descr.add t.fd_by_descr fd with | Ok () -> fd | Error error -> let backtrace = if am_running_inline_test then None else Some (Backtrace.get ()) in raise_s [%message "Async was unable to add a file descriptor to its table of open file descriptors" (file_descr : File_descr.t) (error : Error.t) (backtrace : (Backtrace.t option[@sexp.option])) ~scheduler: (if am_running_inline_test then None else Some t : (t option[@sexp.option]))] ;; let thread_pool_cpu_affinity t = Thread_pool.cpu_affinity t.thread_pool let lock t = (* The following debug message is outside the lock, and so there can be races between multiple threads printing this message. *) if debug then Debug.log_string "waiting on lock"; Nano_mutex.lock_exn t.mutex ;; let try_lock t = match Nano_mutex.try_lock_exn t.mutex with | `Acquired -> true | `Not_acquired -> false ;; let unlock t = if debug then Debug.log_string "lock released"; Nano_mutex.unlock_exn t.mutex ;; let with_lock t f = lock t; protect ~f ~finally:(fun () -> unlock t) ;; let am_holding_lock t = Nano_mutex.current_thread_has_lock t.mutex type the_one_and_only = | Not_ready_to_initialize | Ready_to_initialize of (unit -> t) | Initialized of t (* We use a mutex to protect creation of the one-and-only scheduler in the event that multiple threads attempt to call [the_one_and_only] simultaneously, which can happen in programs that are using [Thread_safe.run_in_async]. *) let mutex_for_initializing_the_one_and_only_ref = Nano_mutex.create () let the_one_and_only_ref : the_one_and_only ref = ref Not_ready_to_initialize let is_ready_to_initialize () = match !the_one_and_only_ref with | Not_ready_to_initialize | Initialized _ -> false | Ready_to_initialize _ -> true ;; let is_initialized () = match !the_one_and_only_ref with | Initialized _ -> true | Not_ready_to_initialize | Ready_to_initialize _ -> false ;; (* Handling the uncommon cases in this function allows [the_one_and_only] to be inlined. The presence of a string constant keeps this function from being inlined. *) let the_one_and_only_uncommon_case () = Nano_mutex.critical_section mutex_for_initializing_the_one_and_only_ref ~f:(fun () -> match !the_one_and_only_ref with | Initialized t -> t | Not_ready_to_initialize -> raise_s [%message "Async the_one_and_only not ready to initialize"] | Ready_to_initialize f -> let t = f () in the_one_and_only_ref := Initialized t; t) ;; let the_one_and_only () = match !the_one_and_only_ref with | Initialized t -> t | Not_ready_to_initialize | Ready_to_initialize _ -> the_one_and_only_uncommon_case () ;; let current_thread_id () = Core_thread.(id (self ())) (* OCaml runtime happens to assign the thread id of [0] to the main thread (the initial thread that starts the program). *) let is_main_thread () = current_thread_id () = 0 let remove_fd t fd = Fd_by_descr.remove t.fd_by_descr fd let maybe_start_closing_fd t (fd : Fd.t) = if fd.num_active_syscalls = 0 then ( match fd.state with | Closed | Open _ -> () | Close_requested (execution_context, do_close_syscall) -> (* We must remove the fd now and not after the close has finished. If we waited until after the close had finished, then the fd might have already been reused by the OS and replaced. *) remove_fd t fd; Fd.set_state fd Closed; Kernel_scheduler.enqueue t.kernel_scheduler execution_context do_close_syscall ()) ;; let dec_num_active_syscalls_fd t (fd : Fd.t) = fd.num_active_syscalls <- fd.num_active_syscalls - 1; maybe_start_closing_fd t fd ;; let invariant t : unit = try let check invariant field = invariant (Field.get field t) in Fields.iter ~mutex:ignore ~have_lock_do_cycle:ignore ~is_running:ignore ~have_called_go:ignore ~fds_whose_watching_has_changed: (check (fun fds_whose_watching_has_changed -> Stack.iter fds_whose_watching_has_changed ~f:(fun (fd : Fd.t) -> assert fd.watching_has_changed; match Fd_by_descr.find t.fd_by_descr fd.file_descr with | None -> assert false | Some fd' -> assert (phys_equal fd fd')))) ~file_descr_watcher: (check (fun file_descr_watcher -> let module F = (val file_descr_watcher : File_descr_watcher.S) in F.invariant F.watcher; F.iter F.watcher ~f:(fun file_descr _ -> try match Fd_by_descr.find t.fd_by_descr file_descr with | None -> raise_s [%message "missing from fd_by_descr"] | Some fd -> assert (Fd.num_active_syscalls fd > 0) with | exn -> raise_s [%message "fd problem" (exn : exn) (file_descr : File_descr.t)]))) ~time_spent_waiting_for_io:ignore ~fd_by_descr: (check (fun fd_by_descr -> Fd_by_descr.invariant fd_by_descr; Fd_by_descr.iter fd_by_descr ~f:(fun fd -> if fd.watching_has_changed then assert ( Stack.exists t.fds_whose_watching_has_changed ~f:(fun fd' -> phys_equal fd fd'))))) ~timerfd:ignore ~timerfd_set_at:ignore ~scheduler_thread_id:ignore ~interruptor:(check Interruptor.invariant) ~signal_manager:(check Raw_signal_manager.invariant) ~thread_pool:(check Thread_pool.invariant) ~handle_thread_pool_stuck:ignore ~next_tsc_calibration:ignore ~kernel_scheduler:(check Kernel_scheduler.invariant) ~max_inter_cycle_timeout:ignore ~min_inter_cycle_timeout: (check (fun min_inter_cycle_timeout -> assert ( Time_ns.Span.( <= ) (Min_inter_cycle_timeout.raw min_inter_cycle_timeout) (Max_inter_cycle_timeout.raw t.max_inter_cycle_timeout)))) ~initialized_at:ignore with | exn -> raise_s [%message "Scheduler.invariant failed" (exn : exn) ~scheduler:(t : t)] ;; let update_check_access t do_check = Kernel_scheduler.set_check_access t.kernel_scheduler (if not do_check then None else Some (fun () -> if not (am_holding_lock t) then ( Debug.log "attempt to access Async from thread not holding the Async lock" (Backtrace.get (), t, Time.now ()) [%sexp_of: Backtrace.t * t * Time.t]; exit 1))) ;; (* Try to create a timerfd. It returns [None] if [Core] is not built with timerfd support or if it is not available on the current system. *) let try_create_timerfd () = match Timerfd.create with | Error _ -> None | Ok create -> let clock = Timerfd.Clock.realtime in (try Some (create clock ~flags:Timerfd.Flags.(nonblock + cloexec)) with | Unix.Unix_error (ENOSYS, _, _) -> (* Kernel too old. *) None | Unix.Unix_error (EINVAL, _, _) -> (* Flags are only supported with Linux >= 2.6.27, try without them. *) let timerfd = create clock in Unix.set_close_on_exec (timerfd : Timerfd.t :> Unix.File_descr.t); Unix.set_nonblock (timerfd : Timerfd.t :> Unix.File_descr.t); Some timerfd) ;; let default_handle_thread_pool_stuck thread_pool ~stuck_for = if Time_ns.Span.( >= ) stuck_for Config.report_thread_pool_stuck_for then ( let should_abort = Time_ns.Span.( >= ) stuck_for Config.abort_after_thread_pool_stuck_for in let text = "Async's thread pool is stuck" in let text = if should_abort then text else sprintf "%s, and will raise an exception in %s" text (Time_ns.Span.to_short_string (Time_ns.Span.( - ) Config.abort_after_thread_pool_stuck_for stuck_for)) in let message = [%message "" ~_:(if am_running_test then Time_ns.epoch else Time_ns.now () : Time_ns.t) text ~stuck_for:(Time_ns.Span.to_short_string stuck_for : string) ~num_threads_created:(Thread_pool.num_threads thread_pool : int) ~max_num_threads:(Thread_pool.max_num_threads thread_pool : int) ~last_thread_creation_failure: (Thread_pool.last_thread_creation_failure thread_pool : (Sexp.t option[@sexp.option]))] in if should_abort then Monitor.send_exn Monitor.main (Error.to_exn (Error.create_s message)) else Core.Debug.eprint_s message) ;; let detect_stuck_thread_pool t = let is_stuck = ref false in let became_stuck_at = ref Time_ns.epoch in let stuck_num_work_completed = ref 0 in Clock.every (sec 1.) ~continue_on_error:false (fun () -> if not (Thread_pool.has_unstarted_work t.thread_pool) then is_stuck := false else ( let now = Time_ns.now () in let num_work_completed = Thread_pool.num_work_completed t.thread_pool in if !is_stuck && num_work_completed = !stuck_num_work_completed then t.handle_thread_pool_stuck t.thread_pool ~stuck_for:(Time_ns.diff now !became_stuck_at) else ( is_stuck := true; became_stuck_at := now; stuck_num_work_completed := num_work_completed))) ;; let thread_pool_has_unfinished_work t = Thread_pool.unfinished_work t.thread_pool <> 0 let thread_safe_wakeup_scheduler t = Interruptor.thread_safe_interrupt t.interruptor let i_am_the_scheduler t = current_thread_id () = t.scheduler_thread_id let set_fd_desired_watching t (fd : Fd.t) read_or_write desired = Read_write_pair.set fd.watching read_or_write desired; if not fd.watching_has_changed then ( fd.watching_has_changed <- true; Stack.push t.fds_whose_watching_has_changed fd) ;; let give_up_on_watching t fd read_or_write (watching : Watching.t) = if Debug.file_descr_watcher then Debug.log "give_up_on_watching" (read_or_write, fd, t) [%sexp_of: Read_write_pair.Key.t * Fd.t * t]; match watching with | Stop_requested | Not_watching -> () | Watch_once ready_to -> Ivar.fill ready_to `Unsupported; set_fd_desired_watching t fd read_or_write Stop_requested | Watch_repeatedly (job, finished) -> Kernel_scheduler.free_job t.kernel_scheduler job; Ivar.fill finished `Unsupported; set_fd_desired_watching t fd read_or_write Stop_requested ;; let request_start_watching t fd read_or_write watching = if Debug.file_descr_watcher then Debug.log "request_start_watching" (read_or_write, fd, t) [%sexp_of: Read_write_pair.Key.t * Fd.t * t]; let result = match Read_write_pair.get fd.watching read_or_write with | Watch_once _ | Watch_repeatedly _ -> `Already_watching | Stop_requested -> (* We don't [inc_num_active_syscalls] in this case, because we already did when we transitioned from [Not_watching] to [Watching]. Also, it is possible that [fd] was closed since we transitioned to [Stop_requested], in which case we don't want to [start_watching]; we want to report that it was closed and leave it [Stop_requested] so the the file-descr-watcher will stop watching it and we can actually close it. *) if Fd.is_closed fd then `Already_closed else `Watching | Not_watching -> (match Fd.inc_num_active_syscalls fd with | `Already_closed -> `Already_closed | `Ok -> `Watching) in (match result with | `Already_closed | `Already_watching -> () | `Watching -> set_fd_desired_watching t fd read_or_write watching; if not (i_am_the_scheduler t) then thread_safe_wakeup_scheduler t); result ;; let request_stop_watching t fd read_or_write value = if Debug.file_descr_watcher then Debug.log "request_stop_watching" (read_or_write, value, fd, t) [%sexp_of: Read_write_pair.Key.t * Fd.ready_to_result * Fd.t * t]; match Read_write_pair.get fd.watching read_or_write with | Stop_requested | Not_watching -> () | Watch_once ready_to -> Ivar.fill ready_to value; set_fd_desired_watching t fd read_or_write Stop_requested; if not (i_am_the_scheduler t) then thread_safe_wakeup_scheduler t | Watch_repeatedly (job, finished) -> (match value with | `Ready -> Kernel_scheduler.enqueue_job t.kernel_scheduler job ~free_job:false | (`Closed | `Bad_fd | `Interrupted | `Unsupported) as value -> Kernel_scheduler.free_job t.kernel_scheduler job; Ivar.fill finished value; set_fd_desired_watching t fd read_or_write Stop_requested; if not (i_am_the_scheduler t) then thread_safe_wakeup_scheduler t) ;; let[@cold] post_check_got_timerfd file_descr = raise_s [%message "File_descr_watcher returned the timerfd as ready to be written to" (file_descr : File_descr.t)] ;; let[@cold] post_check_invalid_fd file_descr = raise_s [%message "File_descr_watcher returned unknown file descr" (file_descr : File_descr.t)] ;; let post_check_handle_fd t file_descr read_or_write value = if Fd_by_descr.mem t.fd_by_descr file_descr then ( let fd = Fd_by_descr.find_exn t.fd_by_descr file_descr in request_stop_watching t fd read_or_write value) else ( match t.timerfd with | Some tfd when File_descr.equal file_descr (tfd :> Unix.File_descr.t) -> (match read_or_write with | `Read -> (* We don't need to actually call [read] since we are using the edge-triggered behavior. *) () | `Write -> post_check_got_timerfd file_descr) | _ -> post_check_invalid_fd file_descr) ;; let create ~mutex ?(thread_pool_cpu_affinity = Config.thread_pool_cpu_affinity) ?(file_descr_watcher = Config.file_descr_watcher) ?(max_num_open_file_descrs = Config.max_num_open_file_descrs) ?(max_num_threads = Config.max_num_threads) () = if debug then Debug.log_string "creating scheduler"; let thread_pool = ok_exn (Thread_pool.create () ~cpu_affinity:thread_pool_cpu_affinity ~max_num_threads:(Max_num_threads.raw max_num_threads)) in let num_file_descrs = Max_num_open_file_descrs.raw max_num_open_file_descrs in let fd_by_descr = Fd_by_descr.create ~num_file_descrs in let create_fd kind file_descr info = let fd = Fd.create kind file_descr info in ok_exn (Fd_by_descr.add fd_by_descr fd); fd in let interruptor = Interruptor.create ~create_fd in let t_ref = ref None in (* set below, after [t] is defined *) let handle_fd read_or_write ready_or_bad_fd file_descr = match !t_ref with | None -> assert false | Some t -> post_check_handle_fd t file_descr read_or_write ready_or_bad_fd in let handle_fd_read_ready = handle_fd `Read `Ready in let handle_fd_read_bad = handle_fd `Read `Bad_fd in let handle_fd_write_ready = handle_fd `Write `Ready in let handle_fd_write_bad = handle_fd `Write `Bad_fd in let file_descr_watcher, timerfd = match file_descr_watcher with | Select -> let watcher = Select_file_descr_watcher.create ~num_file_descrs ~handle_fd_read_ready ~handle_fd_read_bad ~handle_fd_write_ready ~handle_fd_write_bad in let module W = struct include Select_file_descr_watcher let watcher = watcher end in (module W : File_descr_watcher.S), None | Epoll | Epoll_if_timerfd -> let timerfd = match try_create_timerfd () with | None -> raise_s [%message {|Async refuses to run using epoll on a system that doesn't support timer FDs, since Async will be unable to timeout with sub-millisecond precision.|}] | Some timerfd -> timerfd in let watcher = Epoll_file_descr_watcher.create ~num_file_descrs ~timerfd ~handle_fd_read_ready ~handle_fd_write_ready in let module W = struct include Epoll_file_descr_watcher let watcher = watcher end in (module W : File_descr_watcher.S), Some timerfd in let kernel_scheduler = Kernel_scheduler.t () in let t = { mutex ; is_running = false ; have_called_go = false ; fds_whose_watching_has_changed = Stack.create () ; file_descr_watcher ; time_spent_waiting_for_io = Tsc.Span.of_int_exn 0 ; fd_by_descr ; timerfd ; timerfd_set_at = Time_ns.max_value_for_1us_rounding ; scheduler_thread_id = -1 (* set when [be_the_scheduler] is called *) ; interruptor ; signal_manager = Raw_signal_manager.create ~thread_safe_notify_signal_delivered:(fun () -> Interruptor.thread_safe_interrupt interruptor) ; thread_pool ; handle_thread_pool_stuck = default_handle_thread_pool_stuck ; next_tsc_calibration = Tsc.now () ; kernel_scheduler ; have_lock_do_cycle = None ; max_inter_cycle_timeout = Config.max_inter_cycle_timeout ; min_inter_cycle_timeout = Config.min_inter_cycle_timeout ; initialized_at = Backtrace.get () } in t_ref := Some t; detect_stuck_thread_pool t; update_check_access t Config.detect_invalid_access_from_thread; t ;; let init ~take_the_lock = let mutex = Nano_mutex.create () in if take_the_lock then (* We create a mutex that's initially locked by the main thread to support the case when the user does async stuff at the top level before calling [Scheduler.go]. This lock makes sure that async jobs don't run until [Scheduler.go] is called. That could happen, e.g. by creating a reader that does a read system call in another (true) thread. The scheduler remains locked until the scheduler unlocks it. *) Nano_mutex.lock_exn mutex; the_one_and_only_ref := Ready_to_initialize (fun () -> create ~mutex ()) ;; let () = init ~take_the_lock:true let reset_in_forked_process ~take_the_lock = (match !the_one_and_only_ref with | Not_ready_to_initialize | Ready_to_initialize _ -> () | Initialized { file_descr_watcher; timerfd; _ } -> let module F = (val file_descr_watcher : File_descr_watcher.S) in F.reset_in_forked_process F.watcher; (match timerfd with | None -> () | Some tfd -> Unix.close (tfd :> Unix.File_descr.t))); Kernel_scheduler.reset_in_forked_process (); init ~take_the_lock ;; let reset_in_forked_process_without_taking_lock () = reset_in_forked_process ~take_the_lock:false ;; let reset_in_forked_process () = reset_in_forked_process ~take_the_lock:true (* [thread_safe_reset] shuts down Async, exiting the scheduler thread, freeing up all Async resources (file descriptors, threads), and resetting Async global state, so that one can recreate a new Async scheduler afterwards. [thread_safe_reset] blocks until the shutdown is complete; it must be called from outside Async, e.g. the main thread. *) let thread_safe_reset () = match !the_one_and_only_ref with | Not_ready_to_initialize | Ready_to_initialize _ -> () | Initialized t -> assert (not (am_holding_lock t)); Thread_pool.finished_with t.thread_pool; Thread_pool.block_until_finished t.thread_pool; (* We now schedule a job that, when it runs, exits the scheduler thread. We then wait for that job to run. We acquire the Async lock so that we can schedule the job, but release it before we block, so that the scheduler can acquire it. *) let scheduler_thread_finished = Thread_safe_ivar.create () in with_lock t (fun () -> schedule (fun () -> Thread_safe_ivar.fill scheduler_thread_finished (); Thread.exit ())); Thread_safe_ivar.read scheduler_thread_finished; reset_in_forked_process () ;; let make_async_unusable () = reset_in_forked_process (); Kernel_scheduler.make_async_unusable (); the_one_and_only_ref := Ready_to_initialize (fun () -> raise_s [%sexp "Async is unusable due to [Scheduler.make_async_unusable]"]) ;; let thread_safe_enqueue_external_job t f = Kernel_scheduler.thread_safe_enqueue_external_job t.kernel_scheduler f ;; let have_lock_do_cycle t = if debug then Debug.log "have_lock_do_cycle" t [%sexp_of: t]; match t.have_lock_do_cycle with | Some f -> f () | None -> Kernel_scheduler.run_cycle t.kernel_scheduler; (* If we are not the scheduler, wake it up so it can process any remaining jobs, clock events, or an unhandled exception. *) if not (i_am_the_scheduler t) then thread_safe_wakeup_scheduler t ;; let[@cold] log_sync_changed_fds_to_file_descr_watcher t file_descr desired = let module F = (val t.file_descr_watcher : File_descr_watcher.S) in Debug.log "File_descr_watcher.set" (file_descr, desired, F.watcher) [%sexp_of: File_descr.t * bool Read_write_pair.t * F.t] ;; let[@cold] sync_changed_fd_failed t fd desired exn = let bt = Backtrace.Exn.most_recent () in raise_s [%message "sync_changed_fds_to_file_descr_watcher unable to set fd" (desired : bool Read_write_pair.t) (fd : Fd.t) (exn : exn) (bt : Backtrace.t) ~scheduler:(t : t)] ;; let sync_changed_fds_to_file_descr_watcher t = (* We efficiently do nothing if nothing has changed, avoiding even the definition of [module F], which can have some cost. *) if not (Stack.is_empty t.fds_whose_watching_has_changed) then let module F = (val t.file_descr_watcher : File_descr_watcher.S) in while not (Stack.is_empty t.fds_whose_watching_has_changed) do let fd = Stack.pop_exn t.fds_whose_watching_has_changed in fd.watching_has_changed <- false; let desired = Read_write_pair.map fd.watching ~f:(fun watching -> match watching with | Watch_once _ | Watch_repeatedly _ -> true | Not_watching | Stop_requested -> false) in if Debug.file_descr_watcher then log_sync_changed_fds_to_file_descr_watcher t fd.file_descr desired; match try F.set F.watcher fd.file_descr desired with | exn -> sync_changed_fd_failed t fd desired exn with | `Unsupported -> Read_write_pair.iteri fd.watching ~f:(give_up_on_watching t fd) | `Ok -> (* We modify Async's data structures after calling [F.set], so that the error message produced by [sync_changed_fd_failed] displays them as they were before the call. *) Read_write_pair.iteri fd.watching ~f:(fun read_or_write watching -> match watching with | Watch_once _ | Watch_repeatedly _ | Not_watching -> () | Stop_requested -> Read_write_pair.set fd.watching read_or_write Not_watching; dec_num_active_syscalls_fd t fd) done ;; let maybe_calibrate_tsc t = if Lazy.is_val Tsc.calibrator then ( let now = Tsc.now () in if Tsc.( >= ) now t.next_tsc_calibration then ( let calibrator = force Tsc.calibrator in Tsc.Calibrator.calibrate calibrator; t.next_tsc_calibration <- Tsc.add now (Tsc.Span.of_ns (Int63.of_int 1_000_000_000) ~calibrator))) ;; let create_job ?execution_context t f x = let execution_context = match execution_context with | Some e -> e | None -> current_execution_context t in Kernel_scheduler.create_job t.kernel_scheduler execution_context f x ;; let dump_core_on_job_delay () = match Config.dump_core_on_job_delay with | Do_not_watch -> () | Watch { dump_if_delayed_by; how_to_dump } -> Dump_core_on_job_delay.start_watching ~dump_if_delayed_by:(Time_ns.Span.to_span_float_round_nearest dump_if_delayed_by) ~how_to_dump ;; let init t = dump_core_on_job_delay (); Kernel_scheduler.set_thread_safe_external_job_hook t.kernel_scheduler (fun () -> thread_safe_wakeup_scheduler t); t.scheduler_thread_id <- current_thread_id (); (* We handle [Signal.pipe] so that write() calls on a closed pipe/socket get EPIPE but the process doesn't die due to an unhandled SIGPIPE. *) Raw_signal_manager.manage t.signal_manager Signal.pipe; let interruptor_finished = Ivar.create () in let interruptor_read_fd = Interruptor.read_fd t.interruptor in let problem_with_interruptor () = raise_s [%message "can not watch interruptor" (interruptor_read_fd : Fd.t) ~scheduler:(t : t)] in (match request_start_watching t interruptor_read_fd `Read (Watch_repeatedly ( Kernel_scheduler.create_job t.kernel_scheduler Execution_context.main Fn.ignore () , interruptor_finished )) with | `Already_watching | `Watching -> () | `Unsupported | `Already_closed -> problem_with_interruptor ()); upon (Ivar.read interruptor_finished) (fun _ -> problem_with_interruptor ()) ;; let fds_may_produce_events t = let interruptor_fd = Interruptor.read_fd t.interruptor in Fd_by_descr.exists t.fd_by_descr ~f:(fun fd -> (* Jobs created by the interruptor don't do anything, so we don't need to count them as something that can drive progress. When interruptor is involved, the progress is driven by other modules (e.g. the thread_pool). The caller should inspect those directly. We don't need a similar special-case for [timerfd] because that's never added to [fd_by_descr], in the first place. *) (not (Fd.equal fd interruptor_fd)) && Read_write_pair.exists (Fd.watching fd) ~f:(fun watching -> match (watching : Fd.Watching.t) with | Not_watching -> false (* Stop_requested will enqueue a single job, so we have jobs to do still at this point. *) | Watch_once _ | Watch_repeatedly _ | Stop_requested -> true)) ;; (* We avoid allocation in [check_file_descr_watcher], since it is called every time in the scheduler loop. *) let check_file_descr_watcher t ~timeout span_or_unit = let module F = (val t.file_descr_watcher : File_descr_watcher.S) in if Debug.file_descr_watcher then Debug.log "File_descr_watcher.pre_check" t [%sexp_of: t]; let pre = F.pre_check F.watcher in unlock t; (* We yield so that other OCaml threads (especially thread-pool threads) get a chance to run. This is a good point to yield, because we do not hold the Async lock, which allows other threads to acquire it. [Thread.yield] only yields if other OCaml threads are waiting to acquire the OCaml lock, and is fast if not. As of OCaml 4.07, [Thread.yield] on Linux calls [nanosleep], which causes the Linux scheduler to actually switch to other threads. *) Thread.yield (); if Debug.file_descr_watcher then Debug.log "File_descr_watcher.thread_safe_check" (File_descr_watcher_intf.Timeout.variant_of timeout span_or_unit, t) [%sexp_of: [ `Immediately | `After of Time_ns.Span.t ] * t]; let before = Tsc.now () in let check_result = F.thread_safe_check F.watcher pre timeout span_or_unit in let after = Tsc.now () in t.time_spent_waiting_for_io <- Tsc.Span.( + ) t.time_spent_waiting_for_io (Tsc.diff after before); lock t; (* We call [Interruptor.clear] after [thread_safe_check] and before any of the processing that needs to happen in response to [thread_safe_interrupt]. That way, even if [Interruptor.clear] clears out an interrupt that hasn't been serviced yet, the interrupt will still be serviced by the immediately following processing. *) Interruptor.clear t.interruptor; if Debug.file_descr_watcher then Debug.log "File_descr_watcher.post_check" (check_result, t) [%sexp_of: F.Check_result.t * t]; F.post_check F.watcher check_result ;; (* We compute the timeout as the last thing before [check_file_descr_watcher], because we want to make sure the timeout is zero if there are any scheduled jobs. The code is structured to avoid calling [Time_ns.now] and [Linux_ext.Timerfd.set_*] if possible. In particular, we only call [Time_ns.now] if we need to compute the timeout-after span. And we only call [Linux_ext.Timerfd.set_after] if the time that we want it to fire is different than the time it is already set to fire. *) let compute_timeout_and_check_file_descr_watcher t = let min_inter_cycle_timeout = (t.min_inter_cycle_timeout :> Time_ns.Span.t) in let max_inter_cycle_timeout = (t.max_inter_cycle_timeout :> Time_ns.Span.t) in let file_descr_watcher_timeout = match t.timerfd with | None -> (* Since there is no timerfd, use the file descriptor watcher timeout. *) if Kernel_scheduler.can_run_a_job t.kernel_scheduler then min_inter_cycle_timeout else if not (Kernel_scheduler.has_upcoming_event t.kernel_scheduler) then max_inter_cycle_timeout else ( let next_event_at = Kernel_scheduler.next_upcoming_event_exn t.kernel_scheduler in Time_ns.Span.min max_inter_cycle_timeout (Time_ns.Span.max min_inter_cycle_timeout (Time_ns.diff next_event_at (Time_ns.now ())))) | Some timerfd -> (* Set [timerfd] to fire if necessary, taking into account [can_run_a_job], [min_inter_cycle_timeout], and [next_event_at]. *) let have_min_inter_cycle_timeout = Time_ns.Span.( > ) min_inter_cycle_timeout Time_ns.Span.zero in if Kernel_scheduler.can_run_a_job t.kernel_scheduler then if not have_min_inter_cycle_timeout then Time_ns.Span.zero else ( t.timerfd_set_at <- Time_ns.max_value_for_1us_rounding; Linux_ext.Timerfd.set_after timerfd min_inter_cycle_timeout; max_inter_cycle_timeout) else if not (Kernel_scheduler.has_upcoming_event t.kernel_scheduler) then max_inter_cycle_timeout else ( let next_event_at = Kernel_scheduler.next_upcoming_event_exn t.kernel_scheduler in let set_timerfd_at = if not have_min_inter_cycle_timeout then next_event_at else Time_ns.max next_event_at (Time_ns.add (Time_ns.now ()) min_inter_cycle_timeout) in if not (Time_ns.equal t.timerfd_set_at set_timerfd_at) then ( t.timerfd_set_at <- set_timerfd_at; Linux_ext.Timerfd.set_at timerfd set_timerfd_at); max_inter_cycle_timeout) in if Time_ns.Span.( <= ) file_descr_watcher_timeout Time_ns.Span.zero then check_file_descr_watcher t ~timeout:Immediately () else check_file_descr_watcher t ~timeout:After file_descr_watcher_timeout ;; let one_iter t = maybe_calibrate_tsc t; sync_changed_fds_to_file_descr_watcher t; compute_timeout_and_check_file_descr_watcher t; if debug then Debug.log_string "handling delivered signals"; Raw_signal_manager.handle_delivered t.signal_manager; have_lock_do_cycle t ;; let be_the_scheduler ?(raise_unhandled_exn = false) t = init t; let rec loop () = (* At this point, we have the lock. *) if Kernel_scheduler.check_invariants t.kernel_scheduler then invariant t; match Kernel_scheduler.uncaught_exn t.kernel_scheduler with | Some error -> unlock t; error | None -> one_iter t; loop () in let error_kind, error = try `User_uncaught, loop () with | exn -> `Async_uncaught, Error.create "bug in async scheduler" (exn, t) [%sexp_of: exn * t] in if raise_unhandled_exn then Error.raise error else ( (* One reason to run [do_at_exit] handlers before printing out the error message is that it helps curses applications bring the terminal in a good state, otherwise the error message might get corrupted. Also, the OCaml top-level uncaught exception handler does the same. *) (try Caml.do_at_exit () with | _ -> ()); (match error_kind with | `User_uncaught -> (* Don't use Debug.log, to avoid redundant error (task_id in particular) *) eprintf !"%{Sexp#hum}\n%!" [%sexp (Time_ns.now () : Time_ns.t), (error : Error.t)] | `Async_uncaught -> Debug.log "unhandled exception in Async scheduler" error [%sexp_of: Error.t]; Debug.log_string "dumping core"; Dump_core_on_job_delay.dump_core ()); Unix.exit_immediately 1) ;; let add_finalizer t heap_block f = Kernel_scheduler.add_finalizer t.kernel_scheduler heap_block f ;; let add_finalizer_exn t x f = add_finalizer t (Heap_block.create_exn x) (fun heap_block -> f (Heap_block.value heap_block)) ;; let set_task_id () = Async_kernel_config.task_id := fun () -> let pid = Unix.getpid () in let thread_id = Thread.id (Thread.self ()) in [%sexp_of: [ `pid of Pid.t ] * [ `thread_id of int ]] (`pid pid, `thread_id thread_id) ;; let go ?raise_unhandled_exn () = if debug then Debug.log_string "Scheduler.go"; set_task_id (); let t = the_one_and_only () in (* [go] can be called from a thread other than the main thread, for example in programs that reset scheduler after fork, so in some cases it must acquire the lock if the thread has not already done so. *) if not (am_holding_lock t) then lock t; if t.have_called_go then raise_s [%message "cannot Scheduler.go more than once"]; t.have_called_go <- true; if not t.is_running then ( t.is_running <- true; be_the_scheduler t ?raise_unhandled_exn) else ( unlock t; (* We wakeup the scheduler so it can respond to whatever async changes this thread made. *) thread_safe_wakeup_scheduler t; (* Since the scheduler is already running, so we just pause forever. *) Time.pause_forever ()) ;; let go_main ?raise_unhandled_exn ?file_descr_watcher ?max_num_open_file_descrs ?max_num_threads ~main () = (match !the_one_and_only_ref with | Not_ready_to_initialize | Ready_to_initialize _ -> () | Initialized { initialized_at; _ } -> raise_s [%message "Async was initialized prior to [Scheduler.go_main]" (initialized_at : Backtrace.t)]); let max_num_open_file_descrs = Option.map max_num_open_file_descrs ~f:Max_num_open_file_descrs.create_exn in let max_num_threads = Option.map max_num_threads ~f:Max_num_threads.create_exn in let mutex = Nano_mutex.create () in Nano_mutex.lock_exn mutex; the_one_and_only_ref := Ready_to_initialize (fun () -> create ~mutex ?file_descr_watcher ?max_num_open_file_descrs ?max_num_threads ()); Deferred.upon (return ()) main; go ?raise_unhandled_exn () ;; let is_running () = if is_ready_to_initialize () then false else (the_one_and_only ()).is_running ;; let report_long_cycle_times ?(cutoff = sec 1.) () = Stream.iter (long_cycles ~at_least:(cutoff |> Time_ns.Span.of_span_float_round_nearest)) ~f:(fun span -> eprintf "%s\n%!" (Error.to_string_hum (Error.create "long async cycle" span [%sexp_of: Time_ns.Span.t]))) ;; let set_check_invariants bool = Kernel_scheduler.(set_check_invariants (t ()) bool) let set_detect_invalid_access_from_thread bool = update_check_access (the_one_and_only ()) bool ;; let set_max_inter_cycle_timeout span = (the_one_and_only ()).max_inter_cycle_timeout <- Max_inter_cycle_timeout.create_exn (Time_ns.Span.of_span_float_round_nearest span) ;; type 'b folder = { folder : 'a. 'b -> t -> (t, 'a) Field.t -> 'b } let t () = the_one_and_only () let fold_fields (type a) ~init folder : a = let t = t () in let f ac field = folder.folder ac t field in Fields.fold ~init ~mutex:f ~is_running:f ~have_called_go:f ~fds_whose_watching_has_changed:f ~file_descr_watcher:f ~time_spent_waiting_for_io:f ~fd_by_descr:f ~timerfd:f ~timerfd_set_at:f ~scheduler_thread_id:f ~interruptor:f ~signal_manager:f ~thread_pool:f ~handle_thread_pool_stuck:f ~next_tsc_calibration:f ~kernel_scheduler:f ~have_lock_do_cycle:f ~max_inter_cycle_timeout:f ~min_inter_cycle_timeout:f ~initialized_at:f ;; let handle_thread_pool_stuck f = let t = t () in let kernel_scheduler = t.kernel_scheduler in let execution_context = Kernel_scheduler.current_execution_context kernel_scheduler in t.handle_thread_pool_stuck <- (fun _ ~stuck_for -> Kernel_scheduler.enqueue kernel_scheduler execution_context (fun () -> f ~stuck_for) ()) ;; async_unix-0.15.0/src/raw_signal_manager.ml000066400000000000000000000041601420273305200207150ustar00rootroot00000000000000open Core module Signal = Core.Signal module Handlers = struct type t = { bag : ((Signal.t -> unit)[@sexp.opaque]) Bag.t } [@@deriving sexp_of] let create () = { bag = Bag.create () } let add t handler = Bag.add t.bag handler let remove t handler_elt = Bag.remove t.bag handler_elt let deliver t signal = Bag.iter t.bag ~f:(fun handler -> try handler signal with | exn -> raise_s [%message "signal handler unexpectedly raised" (exn : exn)]) ;; end type delivered = (Signal.t * Handlers.t) Thread_safe_queue.t type t = { handlers_by_signal : Handlers.t Signal.Table.t ; delivered : (delivered[@sexp.opaque]) ; thread_safe_notify_signal_delivered : unit -> unit } [@@deriving sexp_of] let invariant _ = () let create ~thread_safe_notify_signal_delivered = { handlers_by_signal = Signal.Table.create () ; delivered = Thread_safe_queue.create () ; thread_safe_notify_signal_delivered } ;; let is_managing t signal = Hashtbl.mem t.handlers_by_signal signal module Handler = struct type t = T of (Handlers.t * (Signal.t -> unit) Bag.Elt.t) list end type handler = Handler.t let get_handlers t signal = Hashtbl.find_or_add t.handlers_by_signal signal ~default:(fun () -> let handlers = Handlers.create () in Signal.Expert.handle signal (fun _ -> (* Everything in this function body must be thread safe, since it is running in an OCaml signal handler. *) Thread_safe_queue.enqueue t.delivered (signal, handlers); t.thread_safe_notify_signal_delivered ()); handlers) ;; let manage t signal = ignore (get_handlers t signal : Handlers.t) let install_handler t signals handler = Handler.T (List.map signals ~f:(fun signal -> let handlers = get_handlers t signal in handlers, Handlers.add handlers handler)) ;; let remove_handler _t (Handler.T handler) = List.iter handler ~f:(fun (handlers, handler_elt) -> Handlers.remove handlers handler_elt) ;; let handle_delivered t = while Thread_safe_queue.length t.delivered > 0 do let signal, handlers = Thread_safe_queue.dequeue_exn t.delivered in Handlers.deliver handlers signal done ;; async_unix-0.15.0/src/reader.ml000066400000000000000000000014341420273305200163400ustar00rootroot00000000000000open Core open Import include Reader0 module Writer = Writer0 let of_pipe info pipe_r = let%map `Reader reader_fd, `Writer writer_fd = Unix.pipe info in let reader = create reader_fd in let writer = Writer.create ~buffer_age_limit:`Unlimited ~raise_when_consumer_leaves:false writer_fd in if false then Debug.log "Reader.of_pipe" (pipe_r, reader, writer) [%sexp_of: string Pipe.Reader.t * t * Writer.t]; don't_wait_for (let%bind () = Writer.transfer writer pipe_r ~stop:(close_finished reader) (fun s -> Writer.write writer s) in Writer.close writer); reader ;; module For_testing = struct let of_string ?(info = Info.of_string "reader of string contents for tests") str = of_pipe info (Pipe.singleton str) ;; end async_unix-0.15.0/src/reader.mli000066400000000000000000000432151420273305200165140ustar00rootroot00000000000000(** [Reader] is Async's main API for buffered input from a file descriptor. It is the analog of {{!Stdio.In_channel}[Stdio.In_channel]}. Each reader has an internal buffer, which is filled via [read()] system calls when data is needed to satisfy a [Reader.read*] call. Each of the read functions returns a deferred that will become determined when the read completes. It is an error to have two simultaneous reads. That is, if you call a read function, you should not call another read function until the first one completes. If the file descriptor underlying a reader is closed, the reader will return EOF (after all the buffered bytes have been read). Any [Reader.read*] call could, rather than determine its result, send an exception to the monitor in effect when [read] was called. Such exceptions can be handled in the usual way by using [try_with], e.g.: {[ try_with (fun () -> Reader.read reader ...) ]} *) open! Core open! Import module Read_result : sig type 'a t = [ `Ok of 'a | `Eof ] [@@deriving bin_io, sexp] include Monad.S with type 'a t := 'a t end module Id : Unique_id type t [@@deriving sexp_of] include Invariant.S with type t := t (** Overall IO statistics for all readers. *) val io_stats : Io_stats.t (** Returns time of the most recent [read] system call that returned data. *) val last_read_time : t -> Time.t (** [stdin] is a reader for file descriptor 0. It is lazy because we don't want to create it in all programs that happen to link with Async. *) val stdin : t Lazy.t (** [open_file file] opens [file] for reading and returns a reader reading from it. This may raise an exception for the typical reasons that an [open(2)] system call may fail. If it does raise, it's guaranteed to be a [Unix_error] variant. *) val open_file : ?buf_len:int -> string -> t Deferred.t (** [transfer t pipe_w] transfers data from [t] into [pipe_w] one chunk at a time (whatever is read from the underlying file descriptor without post-processing). The result becomes determined after reaching EOF on [t] and the final bytes have been transferred, or if [pipe_w] is closed. This function will normally not be needed (see [pipe]). *) val transfer : t -> string Pipe.Writer.t -> unit Deferred.t (** [pipe t] returns the reader end of a pipe that will continually be filled with chunks of data from the underlying [Reader.t]. When the reader reaches EOF or the pipe is closed, [pipe] closes the reader, and then after the reader close is finished, closes the pipe. *) val pipe : t -> string Pipe.Reader.t (** [of_pipe info pipe_r] returns a reader [t] that receives all the data from [pipe_r]. If [pipe_r] is closed, [t] will see an EOF (but will not be automatically closed). If [t] is closed, then [pipe_r] will stop being drained. [of_pipe] is implemented by shuttling bytes from [pipe_r] to the write-end of a Unix pipe, with [t] being attached to the read end of the Unix pipe. *) val of_pipe : Info.t -> string Pipe.Reader.t -> t Deferred.t (** [create ~buf_len fd] creates a new reader that is reading from [fd]. *) val create : ?buf_len:int -> Fd.t -> t val of_in_channel : In_channel.t -> Fd.Kind.t -> t (** [with_file file f] opens [file], creates a reader with it, and passes the reader to [f]. It closes the reader when the result of [f] becomes determined, and returns [f]'s result. This may raise an exception for the typical reasons that an [open(2)] system call may fail. If it does raise before [f] is called, it's guaranteed to be a [Unix_error] variant. {b Note:} You need to be careful that all your IO is done when the deferred you return becomes determined. If for example you use [with_file] and call [lines], make sure you return a deferred that becomes determined when the EOF is reached on the pipe, not when you get the pipe (because you get it straight away). [exclusive = true] uses a filesystem lock to try and make sure that the file is not read while it's being modified. This is an advisory lock, which means that the writer must be cooperating by taking a relevant lock when writing (see [Writer.with_file]). This is unrelated and should not be confused with the [O_EXCL] flag in [open] systemcall. Note that the implementation uses [Unix.lockf], which has known pitfalls. It's recommended that you avoid the [exclusive] flag in favor of using a library dedicated to dealing with file locks where the pitfalls can be documented in detail. *) val with_file : ?buf_len:int -> ?exclusive:bool (** default is [false] *) -> string -> f:(t -> 'a Deferred.t) -> 'a Deferred.t (** [close t] prevents further use of [t] and closes [t]'s underlying file descriptor. The result of [close] becomes determined once the underlying file descriptor has been closed. It is an error to call other operations on [t] after [close t] has been called, except that calls of [close] subsequent to the original call to [close] will return the same deferred as the original call. [close_finished t] becomes determined after [t]'s underlying file descriptor has been closed, i.e., it is the same as the result of [close]. [close_finished] differs from [close] in that it does not have the side effect of initiating a close. [is_closed t] returns [true] iff [close t] has been called. [with_close t ~f] runs [f ()], and closes [t] after [f] finishes or raises. *) val close : t -> unit Deferred.t val close_finished : t -> unit Deferred.t val is_closed : t -> bool val with_close : t -> f:(unit -> 'a Deferred.t) -> 'a Deferred.t (** [id] returns a name for this reader that is unique across all instances of the reader module. *) val id : t -> Id.t (** [fd] returns the [Fd.t] used to create this reader. *) val fd : t -> Fd.t (** [read t ?pos ?len buf] reads up to [len] bytes into [buf], blocking until some data is available or EOF is reached. The resulting [i] satisfies [0 < i <= len]. *) val read : t -> ?pos:int -> ?len:int -> Bytes.t -> int Read_result.t Deferred.t (** [peek t ~len] peeks exactly [len] bytes from [t]'s buffer. It blocks until [len] bytes are available or EOF is reached. *) val peek : t -> len:int -> string Read_result.t Deferred.t (** Reports how many bytes of data are currently in the reader's buffer. *) val bytes_available : t -> int (** Consumes data from the reader's buffer without performing any additional I/O. *) val read_available : t -> ?pos:int -> ?len:int -> Bytes.t -> int (** Reads up to [len] bytes from the reader's buffer without consuming it and without performing any additional I/O. *) val peek_available : t -> len:int -> string (** [drain t] reads and ignores all data from [t] until it hits EOF, and then closes [t]. *) val drain : t -> unit Deferred.t type 'a read_one_chunk_at_a_time_result = [ `Eof | `Stopped of 'a (** [`Eof_with_unconsumed_data s] means that [handle_chunk] returned [`Consumed (c, _)] and left data in the reader's buffer (i.e., [c < len]), and that the reader reached EOF without reading any more data into the buffer; hence the data in the buffer was never consumed (and never will be, since the reader is at EOF). *) | `Eof_with_unconsumed_data of string ] [@@deriving sexp_of] type 'a handle_chunk_result = [ `Stop of 'a (** [`Stop a] means that [handle_chunk] consumed all [len] bytes, and that [read_one_chunk_at_a_time] should stop reading and return [`Stopped a]. *) | `Stop_consumed of 'a * int (** [`Stop_consumed (a, n)] means that [handle_chunk] consumed [n] bytes, and that [read_one_chunk_at_a_time] should stop reading and return [`Stopped a]. *) | `Continue (** [`Continue] means that [handle_chunk] has consumed all [len] bytes. *) | `Consumed of int * [ `Need of int | `Need_unknown ] (** [`Consumed (c, need)] means that [c] bytes were consumed and [need] says how many bytes are needed (including the data remaining in the buffer after the [c] were already consumed). It is an error if [c < 0 || c > len]. For [`Need n], it is an error if [n < 0 || c + n <= len]. *) ] [@@deriving sexp_of] (** [read_one_chunk_at_a_time t ~handle_chunk] reads into [t]'s internal buffer, and whenever bytes are available, applies [handle_chunk] to them. It waits to read again until the deferred returned by [handle_chunk] becomes determined. If [handle_chunk] returns [`Consumed], then [read_one_chunk_at_a_time] will wait for additional data to arrive before calling [handle_chunk] again. Thus, [handle_chunk] should consume as much as possible. [read_one_chunk_at_a_time] continues reading until it reaches [`Eof] or [handle_chunk] returns [`Stop] or [`Stop_consumed]. In the case of [`Stop] and [`Stop_consumed], one may read from [t] after [read_one_chunk_at_a_time] returns. *) val read_one_chunk_at_a_time : t -> handle_chunk:(Bigstring.t -> pos:int -> len:int -> 'a handle_chunk_result Deferred.t) -> 'a read_one_chunk_at_a_time_result Deferred.t (** [`Stop a] or [`Continue] respects the usual [Iobuf] semantics where data up to the [Iobuf.Lo_bound] is considered consumed. *) type 'a handle_iobuf_result = [ `Stop of 'a | `Continue ] [@@deriving sexp_of] (** [read_one_iobuf_at_a_time] is like [read_one_chunk_at_a_time], except that the user-supplied [handle_chunk] function receives its data in an [Iobuf.t], and uses the [Iobuf] position to communicate how much data was consumed. [read_one_iobuf_at_a_time] is implemented as a wrapper around [read_one_chunk_at_a_time]. *) val read_one_iobuf_at_a_time : t -> handle_chunk:((read_write, Iobuf.seek) Iobuf.t -> 'a handle_iobuf_result Deferred.t) -> 'a read_one_chunk_at_a_time_result Deferred.t (** [read_substring t ss] reads up to [Substring.length ss] bytes into [ss], blocking until some data is available or EOF is reached. The resulting [i] satisfies [0 < i <= Substring.length ss]. *) val read_substring : t -> Substring.t -> int Read_result.t Deferred.t val read_bigsubstring : t -> Bigsubstring.t -> int Read_result.t Deferred.t val read_char : t -> char Read_result.t Deferred.t (** [really_read t buf ?pos ?len] reads until it fills [len] bytes of [buf] starting at [pos], or runs out of input. In the former case it returns [`Ok]. In the latter, it returns [`Eof n] where [n] is the number of bytes that were read before end of input, and [0 <= n < String.length ss]. *) val really_read : t -> ?pos:int -> ?len:int -> Bytes.t -> [ `Ok | `Eof of int ] Deferred.t val really_read_substring : t -> Substring.t -> [ `Ok | `Eof of int (** [0 <= i < Substring.length ss] *) ] Deferred.t val really_read_bigsubstring : t -> Bigsubstring.t -> [ `Ok | `Eof of int (** [0 <= i < Substring.length ss] *) ] Deferred.t (** [read_until t pred ~keep_delim] reads until it hits a delimiter [c] such that: - if [pred = `Char c'] then [c = c'] - if [pred = `Pred p] then [p c] [`Char c'] is equivalent to [`Pred (fun c -> c = c')] but the underlying implementation is more efficient, in particular it will not call a function on every input character. [read_until] returns a freshly-allocated string consisting of all the characters read and optionally including the delimiter as per [keep_delim]. *) val read_until : t -> [ `Pred of char -> bool | `Char of char ] -> keep_delim:bool -> [ `Ok of string | `Eof_without_delim of string | `Eof ] Deferred.t (** [read_until_bounded] is just like [read_until], except you have the option of specifying a maximum number of chars to read (not including the separator). When [`Max_exceeded str] is returned, the length of [str] will be equal to [max + 1]. *) val read_until_bounded : t -> [ `Pred of char -> bool | `Char of char ] -> keep_delim:bool -> max:int -> [ `Ok of string | `Eof_without_delim of string | `Eof | `Max_exceeded of string ] Deferred.t (** [read_line t] reads up to and including the next newline ([\n]) character (or [\r\n]) and returns a freshly-allocated string containing everything up to but not including the newline character. If [read_line] encounters EOF before the newline char then everything read up to but not including EOF will be returned as a line. *) val read_line : t -> string Read_result.t Deferred.t (** [really_read_line ~wait_time t] reads up to and including the next newline ([\n]) character and returns an optional, freshly-allocated string containing everything up to but not including the newline character. If [really_read_line] encounters EOF before the newline char, then a time span of [wait_time] will be used before the input operation is retried. If the descriptor is closed, [None] will be returned. *) val really_read_line : wait_time:Time.Span.t -> t -> string option Deferred.t type 'a read = ?parse_pos:Sexp.Parse_pos.t -> 'a (** [read_sexp t] reads the next sexp. *) val read_sexp : (t -> Sexp.t Read_result.t Deferred.t) read (** [read_sexps t] reads all the sexps and returns them as a pipe. When the reader reaches EOF or the pipe is closed, [read_sexps] closes the reader, and then after the reader close is finished, closes the pipe. *) val read_sexps : (t -> Sexp.t Pipe.Reader.t) read val read_annotated_sexps : (t -> Sexp.Annotated.t Pipe.Reader.t) read (** [read_bin_prot ?max_len t bp_reader] reads the next binary protocol message using binary protocol reader [bp_reader]. The format is the "size-prefixed binary protocol", in which the length of the data is prefixed as a 64-bit integer to the data. This is the format that [Writer.write_bin_prot] writes. For higher performance, consider [Unpack_sequence.unpack_bin_prot_from_reader]. *) val read_bin_prot : ?max_len:int -> t -> 'a Bin_prot.Type_class.reader -> 'a Read_result.t Deferred.t (** Similar to [read_bin_prot], but doesn't consume any bytes from [t]. *) val peek_bin_prot : ?max_len:int -> t -> 'a Bin_prot.Type_class.reader -> 'a Read_result.t Deferred.t (** [read_marshal_raw] reads and returns a buffer containing one marshaled value, but doesn't unmarshal it. You can just call [Marshal.from_string] on the string, and cast it to the desired type (preferably the actual type). Similar to [Marshal.from_channel], but suffers from the String-length limitation (16MB) on 32-bit platforms. *) val read_marshal_raw : t -> Bytes.t Read_result.t Deferred.t (** [read_marshal] is like [read_marshal_raw], but unmarshals the value after reading it. *) val read_marshal : t -> _ Read_result.t Deferred.t (** [recv] returns a string that was written with [Writer.send]. *) val recv : t -> Bytes.t Read_result.t Deferred.t (** [read_all t read_one] returns a pipe that receives all values read from [t] by repeatedly using [read_one t]. When the reader reaches EOF, it closes the reader, and then after the reader close is finished, closes the pipe. *) val read_all : t -> (t -> 'a Read_result.t Deferred.t) -> 'a Pipe.Reader.t (** [lseek t offset ~mode] clears [t]'s buffer and calls [Unix.lseek] on [t]'s file descriptor. The [`Cur] mode is not exposed because seeking relative to the current position of the file descriptor is not the same as seeking relative to the current position of the reader. *) val lseek : t -> int64 -> mode:[< `Set | `End ] -> int64 Deferred.t (** [ltell t] returns the file position of [t] from the perspective of a consumer of [t]. It uses [Unix.lseek] to find the file position of [t]'s underlying file descriptor, and then subtracts the number of bytes in [t]'s buffer that have been read from the OS but not from [t]. *) val ltell : t -> int64 Deferred.t (** [lines t] reads all the lines from [t] and puts them in the pipe, one line per pipe element. The lines do not contain the trailing newline. When the reader reaches EOF or the pipe is closed, [lines] closes the reader, and then after the reader close is finished, closes the pipe. *) val lines : t -> string Pipe.Reader.t (** [contents t] returns the string corresponding to the full contents (up to EOF) of the reader. [contents] closes [t] before returning the string.*) val contents : t -> string Deferred.t (** [file_contents file] returns the string with the full contents of the file. *) val file_contents : string -> string Deferred.t (** [file_lines file] returns a list of the lines in the file. The lines do not contain the trailing newline. *) val file_lines : string -> string list Deferred.t (** [load_sexp file conv] loads a sexp from [file] and converts it to a value using [conv]. This function provides an accurate error location if [convert] raises [Of_sexp_error]. [load_sexps] is similar, but converts a sequence of sexps. *) type ('sexp, 'a, 'b) load = ?exclusive:bool (** default is [false] *) -> string -> ('sexp -> 'a) -> 'b Deferred.t val load_sexp : (Sexp.t, 'a, 'a Or_error.t) load val load_sexp_exn : (Sexp.t, 'a, 'a) load val load_sexps : (Sexp.t, 'a, 'a list Or_error.t) load val load_sexps_exn : (Sexp.t, 'a, 'a list) load val load_annotated_sexp : (Sexp.Annotated.t, 'a, 'a Or_error.t) load val load_annotated_sexp_exn : (Sexp.Annotated.t, 'a, 'a) load val load_annotated_sexps : (Sexp.Annotated.t, 'a, 'a list Or_error.t) load val load_annotated_sexps_exn : (Sexp.Annotated.t, 'a, 'a list) load type ('a, 'b) load_bin_prot = ?exclusive:bool (** default is [false] *) -> ?max_len:int -> string -> 'a Bin_prot.Type_class.reader -> 'b Deferred.t val load_bin_prot : ('a, 'a Or_error.t) load_bin_prot val load_bin_prot_exn : ('a, 'a) load_bin_prot module For_testing : sig (** [of_string str], when read, will have contents equal to [str]. *) val of_string : ?info:Info.t -> string -> t Deferred.t end async_unix-0.15.0/src/reader0.ml000066400000000000000000001335001420273305200164200ustar00rootroot00000000000000open Core open Import module Scheduler = Raw_scheduler module Unix = Unix_syscalls module Id = Unique_id.Int63 () module Read_result = struct module Z = struct type 'a t = [ `Ok of 'a | `Eof ] [@@deriving bin_io, sexp] let bind a ~f = match a with | `Ok a -> f a | `Eof -> `Eof ;; let map a ~f = match a with | `Ok a -> `Ok (f a) | `Eof -> `Eof ;; let map = `Custom map let return a = `Ok a end include Z include Monad.Make (Z) end (* We put everything in module [Internal] and then expose just the functions we want later. This reminds us to wrap functions with [do_read], which we do to prevent multiple simultaneous active uses of a reader. *) module Internal = struct module State = struct type t = [ `Not_in_use | `In_use | `Closed ] [@@deriving sexp] end module Open_flags = Unix.Open_flags type open_flags = [ `Already_closed | `Ok of Open_flags.t | `Error of exn ] [@@deriving sexp_of] type t = { fd : Fd.t ; id : Id.t ; (* [buf] holds data read by the reader from the OS, but not yet read by user code. When [t] is closed, [buf] is set to the empty buffer. So, we must make sure in any code that accesses [buf] that [t] has not been closed. In particular, after any deferred operation, we must check whether [t] has been closed while we were waiting. *) mutable buf : Bigstring.t ; (* [close_may_destroy_buf] indicates whether a call to [close] can immediately destroy [buf]. [close_may_destroy_buf] is usually [`Yes], except when we're in the middle of a system call in another thread that refers to [buf], in which case it is [`Not_now] and [close] can't destroy [buf], and we must wait until that system call finishes before doing so. [`Not_ever] is used for [read_one_chunk_at_a_time], which exposes[buf] to client code, which may in turn hold on to it (e.g. via [Bigstring.sub_shared]), and thus it is not safe to ever destroy it. *) mutable close_may_destroy_buf : [ `Yes | `Not_now | `Not_ever ] ; (* [pos] is the first byte of data in [buf] to b be read by user code. *) mutable pos : int ; (* [available] is how many bytes in [buf] are available to be read by user code. *) mutable available : int ; (* [`Closed] means that [close t] has been called. [`In_use] means there is some user call extant that is waiting for data from the reader. *) mutable state : State.t ; close_finished : unit Ivar.t ; mutable last_read_time : Time.t ; (* [open_flags] is the open-file-descriptor bits of [fd]. *) open_flags : open_flags } [@@deriving fields] let sexp_of_t t = [%sexp (t.fd : Fd.t_hum)] type t_internals = t let sexp_of_t_internals { available ; buf = _ ; close_finished ; close_may_destroy_buf ; id ; fd ; last_read_time ; open_flags ; pos ; state } = let unless_testing x = Option.some_if (not am_running_inline_test) x in [%sexp { id = (id |> unless_testing : (Id.t option[@sexp.option])) ; state : State.t ; available : int ; pos : int ; open_flags = (open_flags |> unless_testing : (open_flags option[@sexp.option])) ; last_read_time = (last_read_time |> unless_testing : (Time.t option[@sexp.option])) ; close_may_destroy_buf : [ `Yes | `Not_now | `Not_ever ] ; close_finished : unit Ivar.t ; fd = (fd |> unless_testing : (Fd.t option[@sexp.option])) }] ;; let io_stats = Io_stats.create () let invariant t : unit = assert (0 <= t.pos); assert (0 <= t.available); assert (t.pos + t.available <= Bigstring.length t.buf) ;; let create ?buf_len fd = let buf_len = match buf_len with | None -> (match Fd.kind fd with | Char | File -> 32 * 1024 | Fifo | Socket _ -> 128 * 1024) | Some buf_len -> if buf_len > 0 then buf_len else raise_s [%message "Reader.create got non positive buf_len" (buf_len : int) (fd : Fd.t)] in let open_flags = (* Even though [fcntl] in general can block, [fcntl_getfl] simply reads flags that are already in memory, so it does not need to be run in a separate thread. *) Fd.syscall fd (fun file_descr -> Core_unix.fcntl_getfl file_descr) in { fd ; id = Id.create () ; buf = Bigstring.create buf_len ; close_may_destroy_buf = `Yes ; pos = 0 ; available = 0 ; state = `Not_in_use ; close_finished = Ivar.create () ; last_read_time = Scheduler.cycle_start () ; open_flags } ;; let of_in_channel ic kind = create (Fd.of_in_channel ic kind) let open_file ?buf_len file = let%map fd = Unix.openfile file ~mode:[ `Rdonly ] ~perm:0o000 in create fd ?buf_len ;; let stdin = lazy (create (Fd.stdin ())) let close_finished t = Ivar.read t.close_finished let is_closed t = match t.state with | `Closed -> true | `Not_in_use | `In_use -> false ;; let empty_buf = Bigstring.create 0 let destroy t = (* Calling [unsafe_destroy] on [t]'s bigstrings rather than waiting for finalizers to free them makes their space immediately available for reuse by C's malloc. *) Bigstring.unsafe_destroy t.buf; t.buf <- empty_buf ;; let close t = (match t.state with | `Closed -> () | `Not_in_use | `In_use -> t.state <- `Closed; upon (Unix.close t.fd) (fun () -> Ivar.fill t.close_finished ()); t.pos <- 0; t.available <- 0; (match t.close_may_destroy_buf with | `Yes -> destroy t | `Not_now | `Not_ever -> ())); close_finished t ;; let with_close t ~f = Monitor.protect ~run: `Schedule ~rest:`Log f ~finally:(fun () -> close t) ;; let with_reader_exclusive t f = let%bind () = Unix.lockf t.fd Shared in Monitor.protect ~run: `Schedule ~rest:`Log f ~finally:(fun () -> if not (Fd.is_closed t.fd) then Unix.unlockf t.fd; return ()) ;; let with_file ?buf_len ?(exclusive = false) file ~f = let%bind t = open_file ?buf_len file in with_close t ~f:(fun () -> if exclusive then with_reader_exclusive t (fun () -> f t) else f t) ;; (* [get_data t] attempts to read data into [t.buf]. If the read gets data, [get_data] returns [`Ok], otherwise it returns [`Eof]. *) let get_data t : [ `Ok | `Eof ] Deferred.t = Deferred.create (fun result -> let eof () = Ivar.fill result `Eof in match t.state, t.open_flags with | `Not_in_use, _ -> assert false | `Closed, _ | _, `Already_closed -> eof () | `In_use, ((`Error _ | `Ok _) as open_flags) -> let can_read_fd = match open_flags with | `Error _ -> false | `Ok open_flags -> Unix.Open_flags.can_read open_flags in if not can_read_fd then raise_s [%message "not allowed to read due to file-descriptor flags" (open_flags : open_flags) ~reader:(t : t)]; let ebadf () = (* If the file descriptor has been closed, we will get EBADF from a syscall. If someone closed the [Fd.t] using [Fd.close], then that is fine. But if the underlying file descriptor got closed in some other way, then something is likely wrong, so we raise. *) raise_s [%message "reader file descriptor was unexpectedly closed" ~reader:(t : t)] in let finish res handle = match res with | `Already_closed -> eof () | `Error exn -> (match exn with | Bigstring_unix.IOError (0, End_of_file) | Unix.Unix_error ( ( ECONNRESET | EHOSTUNREACH | ENETDOWN | ENETRESET | ENETUNREACH (* When using OpenOnload, read() can return EPIPE if a TCP connection is established and then immediately closed. *) | EPIPE | ETIMEDOUT ) , _ , _ ) -> eof () | Unix.Unix_error (EBADF, _, _) -> ebadf () | _ -> handle exn) | `Ok (bytes_read, read_time) -> Io_stats.update io_stats ~kind:(Fd.kind t.fd) ~bytes:(Int63.of_int bytes_read); if bytes_read = 0 then eof () else ( t.pos <- 0; t.available <- t.available + bytes_read; t.last_read_time <- read_time; Ivar.fill result `Ok) in let buf = t.buf in if t.available > 0 && t.pos > 0 then ( Bigstring.blit ~src:buf ~src_pos:t.pos ~dst:buf ~dst_pos:0 ~len:t.available; t.pos <- 0); let pos = t.available in let len = Bigstring.length buf - pos in if not (Fd.supports_nonblock t.fd) then ( (match t.close_may_destroy_buf with | `Yes -> t.close_may_destroy_buf <- `Not_now | `Not_now | `Not_ever -> ()); Fd.syscall_in_thread t.fd ~name:"read" (fun file_descr -> let res = Bigstring_unix.read file_descr buf ~pos ~len in res, Time.now ()) >>> fun res -> (match t.close_may_destroy_buf with | `Not_now -> t.close_may_destroy_buf <- `Yes | `Yes | `Not_ever -> ()); match t.state with | `Not_in_use -> assert false | `In_use -> finish res raise | `Closed -> (* If we're here, somebody [close]d the reader while we were making the system call. [close] couldn't [destroy], so we need to. *) destroy t; eof ()) else ( let rec loop () = (* Force the async cycle to end between reads, allowing others to run. *) Fd.ready_to t.fd `Read >>> function | `Bad_fd -> ebadf () | `Closed -> eof () | `Ready -> (* There is a race between the [ready_to] becoming determined and someone [close]ing [t]. It is possible to get [`Ready] and then by the time we get here, [t] is closed. *) (match t.state with | `Not_in_use -> assert false | `Closed -> eof () | `In_use -> finish (Fd.syscall t.fd ~nonblocking:true (fun file_descr -> let res = Unix.Syscall_result.Int.ok_or_unix_error_exn (Bigstring_unix.read_assume_fd_is_nonblocking file_descr buf ~pos ~len) ~syscall_name:"read" in res, Scheduler.cycle_start ())) (function (* Since [t.fd] is ready, we should never see EWOULDBLOCK or EAGAIN. But we don't trust the OS. So, in case it does, we just try again. *) | Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _) -> loop () | exn -> raise exn)) in loop ())) ;; let ensure_buf_len t ~at_least = let buf_len = Bigstring.length t.buf in if buf_len < at_least then ( let new_buf = Bigstring.create (Int.max at_least (2 * Bigstring.length t.buf)) in if t.available > 0 then Bigstring.blit ~src:t.buf ~src_pos:t.pos ~len:t.available ~dst:new_buf ~dst_pos:0; t.buf <- new_buf; t.pos <- 0); assert (Bigstring.length t.buf >= at_least) ;; (* [get_data_until] calls [get_data] to read into [t.buf] until [t.available >= available_at_least], or until it reaches EOF. It returns [`Ok] if [t.available >= available_at_least], and [`Eof] if not. *) let get_data_until t ~available_at_least = if t.available >= available_at_least then return `Ok else ( ensure_buf_len t ~at_least:available_at_least; if t.pos > 0 then ( Bigstring.blit ~src:t.buf ~src_pos:t.pos ~dst:t.buf ~dst_pos:0 ~len:t.available; t.pos <- 0); let rec loop () = let%bind result = get_data t in if t.available >= available_at_least then return `Ok else ( match result with | `Eof -> return (`Eof t.available) | `Ok -> loop ()) in loop ()) ;; (* [with_nonempty_buffer t f] waits for [t.buf] to have data, and then returns [f `Ok]. If no data can be read, then [with_nonempty_buffer] returns [f `Eof]. [with_nonempty_buffer] must be called with [t.state] as [`Closed] or [`In_use]. It guarantees that if [f `Ok] is called, that [t.state = `In_use]. *) let with_nonempty_buffer (type a) t (f : [ `Ok | `Eof ] -> a) : a Deferred.t = match t.state with | `Not_in_use -> assert false | `Closed -> return (f `Eof) | `In_use -> if t.available > 0 then return (f `Ok) else ( let%map ok_or_eof = get_data t in match t.state with | `Not_in_use -> assert false | `Closed -> f `Eof | `In_use -> f ok_or_eof) ;; (* [with_nonempty_buffer' t f] is an optimized version of [don't_wait_for (with_nonempty_buffer t f)]. With [force_refill = true], [with_nonempty_buffer'] will do a read, whether or not there is already data available in [t.buf]. *) let with_nonempty_buffer' ?(force_refill = false) t (f : [ `Ok | `Eof ] -> unit) : unit = match t.state with | `Not_in_use -> assert false | `Closed -> f `Eof | `In_use -> if (not force_refill) && t.available > 0 then f `Ok else get_data t >>> fun ok_or_eof -> (match t.state with | `Not_in_use -> assert false | `Closed -> f `Eof | `In_use -> f ok_or_eof) ;; let consume t amount = assert (0 <= amount && amount <= t.available); t.pos <- t.pos + amount; t.available <- t.available - amount ;; type 'a handle_chunk_result = [ `Stop of 'a | `Stop_consumed of 'a * int | `Continue | `Consumed of int * [ `Need of int | `Need_unknown ] ] [@@deriving sexp_of] type 'a read_one_chunk_at_a_time_result = [ `Eof | `Stopped of 'a | `Eof_with_unconsumed_data of string ] [@@deriving sexp_of] type consumed = [ `Consumed of int * [ `Need of int | `Need_unknown ] ] [@@deriving sexp_of] let read_one_chunk_at_a_time t ~handle_chunk = t.close_may_destroy_buf <- `Not_ever; Deferred.create (fun final_result -> let rec loop ~force_refill = with_nonempty_buffer' t ~force_refill (function | `Eof -> let result = if t.available > 0 then `Eof_with_unconsumed_data (Bigstring.to_string t.buf ~pos:t.pos ~len:t.available) else `Eof in Ivar.fill final_result result | `Ok -> let len = t.available in let continue z = match t.state with | `Not_in_use -> assert false | `Closed -> Ivar.fill final_result `Eof | `In_use -> (match z with | `Stop a -> consume t len; Ivar.fill final_result (`Stopped a) | `Stop_consumed (a, consumed) -> consume t consumed; Ivar.fill final_result (`Stopped a) | `Continue -> consume t len; loop ~force_refill:true | `Consumed (consumed, need) as c -> if consumed < 0 || consumed > len || match need with | `Need_unknown -> false | `Need need -> need < 0 || consumed + need <= len then raise_s [%message "handle_chunk returned invalid `Consumed" ~_:(c : consumed) (len : int) ~reader:(t : t)]; consume t consumed; let buf_len = Bigstring.length t.buf in let new_len = match need with | `Need_unknown -> if t.available = buf_len (* The buffer is full and the client doesn't know how much to expect: double the buffer size. *) then buf_len * 2 else buf_len | `Need need -> if need > buf_len then Int.max need (buf_len * 2) else buf_len in if new_len < 0 then raise_s [%message "read_one_chunk_at_a_time got overflow in buffer len" ~reader:(t : t_internals)]; (* Grow the internal buffer if needed. *) if new_len > buf_len then ( let new_buf = Bigstring.create new_len in if t.available > 0 then Bigstring.blit ~src:t.buf ~src_pos:t.pos ~len:t.available ~dst:new_buf ~dst_pos:0; t.buf <- new_buf; t.pos <- 0); loop ~force_refill:true) in let deferred = handle_chunk t.buf ~pos:t.pos ~len in (match Deferred.peek deferred with | None -> deferred >>> continue | Some result -> continue result)) in loop ~force_refill:false) ;; type 'a handle_iobuf_result = [ `Stop of 'a | `Continue ] [@@deriving sexp_of] let read_one_iobuf_at_a_time t ~handle_chunk = let iobuf = Iobuf.of_bigstring t.buf in read_one_chunk_at_a_time t ~handle_chunk:(fun bstr ~pos ~len -> Iobuf.Expert.reinitialize_of_bigstring iobuf bstr ~pos ~len; let%map handle_result = handle_chunk iobuf in if Iobuf.is_empty iobuf (* [is_empty] implies all data was consumed *) then (handle_result :> _ handle_chunk_result) else ( let consumed = len - Iobuf.length iobuf in match handle_result with | `Continue -> `Consumed (consumed, `Need_unknown) | `Stop a -> `Stop_consumed (a, consumed))) ;; module Read (S : Substring_intf.S) (Name : sig val name : string end) = struct let read_available t s = let len = Int.min t.available (S.length s) in S.blit_from_bigstring s ~src:t.buf ~src_pos:t.pos ~len; consume t len; len ;; let read t s = if S.length s = 0 then invalid_argf "Reader.read_%s with empty string" Name.name (); with_nonempty_buffer t (function | `Ok -> `Ok (read_available t s) | `Eof -> `Eof) ;; let really_read t s = Deferred.create (fun result -> let rec loop s amount_read = if S.length s = 0 then Ivar.fill result `Ok else read t s >>> function | `Eof -> Ivar.fill result (`Eof amount_read) | `Ok len -> loop (S.drop_prefix s len) (amount_read + len) in loop s 0) ;; end module Read_substring = Read (Substring) (struct let name = "substring" end) let read_substring_available = Read_substring.read_available let read_substring = Read_substring.read let really_read_substring = Read_substring.really_read module Read_bigsubstring = Read (Bigsubstring) (struct let name = "bigsubstring" end) let read_bigsubstring = Read_bigsubstring.read let really_read_bigsubstring = Read_bigsubstring.really_read let really_read_bigstring t bigstring = really_read_bigsubstring t (Bigsubstring.create bigstring) ;; let peek_available t ~len = Bigstring.to_string t.buf ~pos:t.pos ~len:(Int.min len t.available) ;; let peek t ~len = match%map get_data_until t ~available_at_least:len with | `Eof (_ : int) -> assert (t.available < len); `Eof | `Ok -> assert (t.available >= len); `Ok (Bigstring.to_string t.buf ~pos:t.pos ~len) ;; let read_available t ?pos ?len s = read_substring_available t (Substring.create s ?pos ?len) ;; let read t ?pos ?len s = read_substring t (Substring.create s ?pos ?len) let really_read t ?pos ?len s = really_read_substring t (Substring.create s ?pos ?len) let read_char t = with_nonempty_buffer t (function | `Eof -> `Eof | `Ok -> let c = t.buf.{t.pos} in consume t 1; `Ok c) ;; let first_char t p ~available = let limit = t.pos + available in let buf = t.buf in match p with | `Pred p -> let rec loop pos = if pos = limit then None else if p buf.{pos} then Some pos else loop (pos + 1) in (* [p] is supplied by the user and may raise, so we wrap [loop] in a [try_with]. We put the [try_with] here rather than around the call to [p] to avoid per-character try-with overhead. *) Or_error.try_with (fun () -> loop t.pos) | `Char ch -> let rec loop pos = if pos = limit then None else if Char.O.(ch = buf.{pos}) then Some pos else loop (pos + 1) in Ok (loop t.pos) ;; let read_until_gen t p ~keep_delim ~max k = let rec loop ac total = with_nonempty_buffer' t (function | `Eof -> k (Ok (if List.is_empty ac then `Eof else `Eof_without_delim (Bigsubstring.concat_string (List.rev ac)))) | `Ok -> let concat_helper ss lst = Bigsubstring.concat_string (List.rev_append lst [ ss ]) in let available, need_more_bytes_to_exceed_max = match max with | None -> t.available, true | Some max -> if t.available < max - total + 1 then t.available, true else max - total + 1, false in (match first_char t p ~available with | Error _ as e -> k e | Ok None -> (match need_more_bytes_to_exceed_max with | false -> let amount_consumed = available in let len = amount_consumed in let ss = Bigsubstring.create t.buf ~pos:t.pos ~len in consume t amount_consumed; let res = concat_helper ss ac in k (Ok (`Max_exceeded res)) | true -> let len = t.available in let total = total + len in let ss = Bigsubstring.create t.buf ~pos:t.pos ~len in t.buf <- Bigstring.create (Bigstring.length t.buf); t.pos <- 0; t.available <- 0; loop (ss :: ac) total) | Ok (Some pos) -> let amount_consumed = pos + 1 - t.pos in let len = if keep_delim then amount_consumed else amount_consumed - 1 in let ss = Bigsubstring.create t.buf ~pos:t.pos ~len in consume t amount_consumed; let res = concat_helper ss ac in k (Ok (`Ok res)))) in loop [] 0 ;; let read_until t pred ~keep_delim k = read_until_gen t pred ~keep_delim ~max:None (function | Error _ as x -> k x | Ok (`Max_exceeded _) -> assert false (* impossible - no maximum set *) | Ok (`Eof | `Eof_without_delim _ | `Ok _) as x -> k x) ;; let line_delimiter_pred = `Char '\n' let read_line_gen t k = read_until t line_delimiter_pred ~keep_delim:false (function | Error _ -> (* Impossible, since we supplied a [`Char] predicate. *) assert false | Ok ((`Eof | `Eof_without_delim _) as x) -> k x | Ok (`Ok line) -> k (`Ok (let len = String.length line in if len >= 1 && Char.O.(line.[len - 1] = '\r') then String.sub line ~pos:0 ~len:(len - 1) else line))) ;; let read_line t = Deferred.create (fun result -> read_line_gen t (fun z -> Ivar.fill result (match z with | `Eof_without_delim str -> `Ok str | (`Ok _ | `Eof) as x -> x))) ;; let really_read_line ~wait_time t = Deferred.create (fun result -> let fill_result = function | [] -> Ivar.fill result None | ac -> Ivar.fill result (Some (String.concat (List.rev ac))) in let rec continue ac = match t.state with | `Not_in_use -> assert false | `Closed -> fill_result ac | `In_use -> Clock.after wait_time >>> fun () -> loop ac and loop ac = read_line_gen t (function | `Eof -> continue ac | `Eof_without_delim str -> continue (str :: ac) | `Ok line -> fill_result (line :: ac)) in loop []) ;; let space = Bigstring.of_string " " type 'sexp sexp_kind = | Plain : Sexp.t sexp_kind | Annotated : Sexp.Annotated.t sexp_kind let gen_read_sexp (type sexp) ?parse_pos t ~(sexp_kind : sexp sexp_kind) k = let rec loop parse_fun = with_nonempty_buffer' t (function | `Eof -> (* The sexp parser doesn't know that a token ends at EOF, so we add a space to be sure. *) (match Or_error.try_with (fun () -> parse_fun ~pos:0 ~len:1 space) with | Error _ as e -> k e | Ok (Sexp.Done (sexp, parse_pos)) -> k (Ok (`Ok (sexp, parse_pos))) | Ok (Cont (Parsing_toplevel_whitespace, _)) -> k (Ok `Eof) | Ok (Cont ( ( Parsing_atom | Parsing_list | Parsing_nested_whitespace | Parsing_sexp_comment | Parsing_block_comment ) , _ )) -> raise_s [%message "Reader.read_sexp got unexpected eof" ~reader:(t : t)]) | `Ok -> (match Or_error.try_with (fun () -> parse_fun ~pos:t.pos ~len:t.available t.buf) with | Error _ as e -> k e | Ok (Done (sexp, parse_pos)) -> consume t (parse_pos.buf_pos - t.pos); k (Ok (`Ok (sexp, parse_pos))) | Ok (Cont (_, parse_fun)) -> t.available <- 0; loop parse_fun)) in let parse ~pos ~len buf : (_, sexp) Sexp.parse_result = (* [parse_pos] will be threaded through the entire reading process by the sexplib code. Every occurrence of [parse_pos] above will be identical to the [parse_pos] defined here. *) let parse_pos = match parse_pos with | None -> Sexp.Parse_pos.create ~buf_pos:pos () | Some parse_pos -> Sexp.Parse_pos.with_buf_pos parse_pos pos in match sexp_kind with | Plain -> Sexp.parse_bigstring ?parse_pos:(Some parse_pos) ?len:(Some len) buf | Annotated -> Sexp.Annotated.parse_bigstring ?parse_pos:(Some parse_pos) ?len:(Some len) buf in loop parse ;; type 'a read = ?parse_pos:Sexp.Parse_pos.t -> 'a let gen_read_sexps ?parse_pos t ~sexp_kind = let pipe_r, pipe_w = Pipe.create () in let finished = Deferred.create (fun result -> let rec loop parse_pos = gen_read_sexp t ~sexp_kind ?parse_pos (function | Error error -> Error.raise error | Ok `Eof -> Ivar.fill result () | Ok (`Ok (sexp, parse_pos)) -> if Pipe.is_closed pipe_w then Ivar.fill result () else Pipe.write pipe_w sexp >>> fun () -> loop (Some parse_pos)) in loop parse_pos) in upon finished (fun () -> close t >>> fun () -> Pipe.close pipe_w); pipe_r ;; let read_sexps ?parse_pos t = gen_read_sexps t ~sexp_kind:Plain ?parse_pos let read_annotated_sexps ?parse_pos t = gen_read_sexps t ~sexp_kind:Annotated ?parse_pos module Peek_or_read = struct type t = | Peek | Read [@@deriving sexp_of] let to_string = Sexplib.Conv.string_of__of__sexp_of [%sexp_of: t] end let peek_or_read_bin_prot ?(max_len = 100 * 1024 * 1024) t ~(peek_or_read : Peek_or_read.t) (bin_prot_reader : _ Bin_prot.Type_class.reader) k = let error f = ksprintf (fun msg () -> k (Or_error.error "Reader.read_bin_prot" (msg, t) [%sexp_of: string * t])) f in let handle_eof n = if n = 0 then k (Ok `Eof) else error "got Eof with %d bytes left over" n () in get_data_until t ~available_at_least:Bin_prot.Utils.size_header_length >>> function | `Eof n -> handle_eof n | `Ok -> (match t.state with | `Not_in_use -> assert false | `Closed -> error "Reader.read_bin_prot got closed reader" () | `In_use -> let pos = t.pos in let pos_ref = ref pos in (match Or_error.try_with (fun () -> Bin_prot.Utils.bin_read_size_header t.buf ~pos_ref) with | Error _ as e -> k e | Ok len -> if !pos_ref - pos <> Bin_prot.Utils.size_header_length then error "pos_ref <> len, (%d <> %d)" (!pos_ref - pos) Bin_prot.Utils.size_header_length (); if len > max_len then error "max read length exceeded: %d > %d" len max_len (); if len < 0 then error "negative length %d" len (); let need = Bin_prot.Utils.size_header_length + len in get_data_until t ~available_at_least:need >>> (function | `Eof n -> handle_eof n | `Ok -> (match t.state with | `Not_in_use -> assert false | `Closed -> error "Reader.read_bin_prot got closed reader" () | `In_use -> let pos = t.pos + Bin_prot.Utils.size_header_length in pos_ref := pos; (match Or_error.try_with (fun () -> bin_prot_reader.read t.buf ~pos_ref) with | Error _ as e -> k e | Ok v -> if !pos_ref - pos <> len then error "pos_ref <> len, (%d <> %d)" (!pos_ref - pos) len (); (match peek_or_read with | Peek -> () | Read -> consume t need); k (Ok (`Ok v))))))) ;; let read_marshal_raw t = let eofn n = if n = 0 then `Eof else raise_s [%message "Reader.read_marshal got EOF with bytes remaining" ~_:(n : int)] in let header = Bytes.create Marshal.header_size in match%bind really_read t header with | `Eof n -> return (eofn n) | `Ok -> let len = Marshal.data_size header 0 in let buf = Bytes.create (len + Marshal.header_size) in Bytes.blit ~src:header ~dst:buf ~src_pos:0 ~dst_pos:0 ~len:Marshal.header_size; let sub = Substring.create buf ~pos:Marshal.header_size ~len in (match%map really_read_substring t sub with | `Eof n -> eofn n | `Ok -> `Ok buf) ;; let read_marshal t = match%map read_marshal_raw t with | `Eof -> `Eof | `Ok buf -> `Ok (Marshal.from_bytes buf 0) ;; let read_all t read_one = let pipe_r, pipe_w = Pipe.create () in let finished = Deferred.repeat_until_finished () (fun () -> match%bind read_one t with | `Eof -> return (`Finished ()) | `Ok one -> if Pipe.is_closed pipe_w then return (`Finished ()) else ( let%map () = Pipe.write pipe_w one in `Repeat ())) in upon finished (fun () -> close t >>> fun () -> Pipe.close pipe_w); pipe_r ;; let lines t = read_all t read_line let contents t = let buf = Buffer.create 1024 in let sbuf = Bytes.create 1024 in let%bind () = Deferred.repeat_until_finished () (fun () -> match%map read t sbuf with | `Eof -> `Finished () | `Ok l -> Buffer.add_subbytes buf sbuf ~pos:0 ~len:l; `Repeat ()) in let%map () = close t in Buffer.contents buf ;; let recv t = Deferred.create (fun i -> read_line t >>> function | `Eof -> Ivar.fill i `Eof | `Ok length_str -> (match try Ok (int_of_string length_str) with | _ -> Error () with | Error () -> raise_s [%message "Reader.recv got strange length" (length_str : string) ~reader:(t : t)] | Ok length -> let buf = Bytes.create length in really_read t buf >>> (function | `Eof _ -> raise_s [%message "Reader.recv got unexpected EOF"] | `Ok -> Ivar.fill i (`Ok buf)))) ;; let transfer t pipe_w = Deferred.create (fun finished -> don't_wait_for (let%map () = Pipe.closed pipe_w in Ivar.fill_if_empty finished ()); let rec loop () = with_nonempty_buffer' t (function | `Eof -> Ivar.fill_if_empty finished () | `Ok -> if not (Pipe.is_closed pipe_w) then ( let pos = t.pos in let len = t.available in consume t len; Pipe.write pipe_w (Bigstring.to_string t.buf ~pos ~len) >>> loop)) in loop ()) ;; end open Internal (* We now expose all the functions in the mli. For functions that access a reader in a deferred manner, we enclude code to dynamically ensure that there aren't simultaneous reads. *) type nonrec t = t [@@deriving sexp_of] type nonrec 'a handle_chunk_result = 'a handle_chunk_result [@@deriving sexp_of] type nonrec 'a handle_iobuf_result = 'a handle_iobuf_result [@@deriving sexp_of] type nonrec 'a read_one_chunk_at_a_time_result = 'a read_one_chunk_at_a_time_result [@@deriving sexp_of] type nonrec 'a read = 'a read let close = close let close_finished = close_finished let create = create let fd = fd let id = id let invariant = invariant let io_stats = io_stats let is_closed = is_closed let last_read_time = last_read_time let of_in_channel = of_in_channel let open_file = open_file let stdin = stdin let with_close = with_close let with_file = with_file let use t = let error reason = raise_s [%message "can not read from reader" (reason : string) ~reader:(t : t)] in match t.state with | `Closed -> error "closed" | `In_use -> error "in use" | `Not_in_use -> t.state <- `In_use ;; let finished_read t = match t.state with | `Closed -> () (* [f ()] closed it. Leave it closed. *) | `Not_in_use -> assert false (* we're using it *) | `In_use -> t.state <- `Not_in_use ;; let do_read_now t f = use t; let x = f () in finished_read t; x ;; let bytes_available t = do_read_now t (fun () -> t.available) let peek_available t ~len = do_read_now t (fun () -> peek_available t ~len) let read_available t ?pos ?len s = do_read_now t (fun () -> read_available t ?pos ?len s) let do_read t f = use t; let%map x = f () in finished_read t; x ;; let peek t ~len = if len < 0 then raise_s [%message "[Reader.peek] got negative len" (len : int)]; do_read t (fun () -> peek t ~len) ;; let read t ?pos ?len s = do_read t (fun () -> read t ?pos ?len s) let read_char t = do_read t (fun () -> read_char t) let read_substring t s = do_read t (fun () -> read_substring t s) let read_bigsubstring t s = do_read t (fun () -> read_bigsubstring t s) let read_one_chunk_at_a_time t ~handle_chunk = do_read t (fun () -> read_one_chunk_at_a_time t ~handle_chunk) ;; let read_one_iobuf_at_a_time t ~handle_chunk = do_read t (fun () -> read_one_iobuf_at_a_time t ~handle_chunk) ;; let really_read t ?pos ?len s = do_read t (fun () -> really_read t ?pos ?len s) let really_read_substring t s = do_read t (fun () -> really_read_substring t s) let really_read_bigsubstring t s = do_read t (fun () -> really_read_bigsubstring t s) let read_line t = do_read t (fun () -> read_line t) let really_read_line ~wait_time t = do_read t (fun () -> really_read_line ~wait_time t) (* [do_read_k] takes a [read_k] function that takes a continuation expecting an [Or_error.t]. It uses this to do a read returning a deferred. This allows it to call [finished_read] before continuing, in the event that the result is an error. *) let do_read_k (type r r') t (read_k : (r Or_error.t -> unit) -> unit) (make_result : r -> r') : r' Deferred.t = use t; Deferred.create (fun result -> read_k (fun r -> finished_read t; Ivar.fill result (make_result (ok_exn r)))) ;; let read_until t p ~keep_delim = do_read_k t (read_until t p ~keep_delim) Fn.id let read_until_bounded t p ~keep_delim ~max = do_read_k t (read_until_gen t p ~keep_delim ~max:(Some max)) Fn.id ;; let read_sexp ?parse_pos t = do_read_k t (gen_read_sexp t ~sexp_kind:Plain ?parse_pos) (function | `Eof -> `Eof | `Ok (sexp, _) -> `Ok sexp) ;; let read_sexps ?parse_pos t = use t; read_sexps ?parse_pos t ;; let read_annotated_sexps ?parse_pos t = use t; read_annotated_sexps ?parse_pos t ;; let peek_or_read_bin_prot ?max_len t reader ~peek_or_read = do_read_k t (peek_or_read_bin_prot ?max_len t reader ~peek_or_read) Fn.id ;; let peek_bin_prot ?max_len t reader = peek_or_read_bin_prot ?max_len t reader ~peek_or_read:Peek ;; let read_bin_prot ?max_len t reader = peek_or_read_bin_prot ?max_len t reader ~peek_or_read:Read ;; let read_marshal_raw t = do_read t (fun () -> read_marshal_raw t) let read_marshal t = do_read t (fun () -> read_marshal t) let recv t = do_read t (fun () -> recv t) (* [read_all] does not call [use t], because [read_one] will do so each time it is using [t]. *) let read_all t read_one = read_all t read_one let lines t = use t; lines t ;; let contents t = do_read t (fun () -> contents t) let file_contents file = with_file file ~f:contents let file_lines file = let%bind t = open_file file in Pipe.to_list (lines t) ;; let transfer t = use t; transfer t ;; let lseek t offset ~mode = do_read t (fun () -> t.pos <- 0; t.available <- 0; Unix_syscalls.lseek t.fd offset ~mode) ;; let ltell t = do_read t (fun () -> let%map fd_offset = Unix_syscalls.lseek t.fd Int64.zero ~mode:`Cur in Int64.( - ) fd_offset (Int64.of_int t.available)) ;; let get_error (type a sexp) ~file ~(sexp_kind : sexp sexp_kind) ~(a_of_sexp : sexp -> a) (annotated_sexp : Sexp.Annotated.t) = try ignore (a_of_sexp (match sexp_kind with | Plain -> (Sexp.Annotated.get_sexp annotated_sexp : sexp) | Annotated -> (annotated_sexp : sexp)) : a); Ok () with | exn -> let unexpected_error () = error "Reader.load_sexp error" (file, exn) [%sexp_of: string * exn] in (match exn with | Of_sexp_error (exc, bad_sexp) -> (match Sexp.Annotated.find_sexp annotated_sexp bad_sexp with | None -> unexpected_error () | Some bad_annotated_sexp -> (match Sexp.Annotated.get_conv_exn ~file ~exc bad_annotated_sexp with | Of_sexp_error (Sexp.Annotated.Conv_exn (pos, exn), sexp) -> (* The error produced by [get_conv_exn] already has the file position, so we don't wrap with a redundant error message. *) Or_error.error "invalid sexp" (pos, exn, "in", sexp) [%sexp_of: string * exn * string * Sexp.t] | _ -> unexpected_error ())) | _ -> unexpected_error ()) ;; let gen_load_exn (type sexp a) ?exclusive ~(sexp_kind : sexp sexp_kind) ~file (convert : sexp list -> a) (get_error : Sexp.Annotated.t list -> Error.t) : a Deferred.t = let may_load_file_multiple_times = ref false in let load ~sexp_kind = match%map Monitor.try_with ~run: `Schedule ~rest:`Log ~extract_exn:true (fun () -> with_file ?exclusive file ~f:(fun t -> (may_load_file_multiple_times := (* Although [file] typically is of kind [Fd.Kind.File], it may also have other kinds. We can only load it multiple times if it has kind [File]. *) match Fd.kind (fd t) with | File -> true | Char | Fifo | Socket _ -> false); use t; Pipe.to_list (gen_read_sexps t ~sexp_kind))) with | Ok sexps -> sexps | Error exn -> (match exn with | Sexp.Parse_error { err_msg; parse_state; _ } -> (* This code reformats the [Parse_error] produced by sexplib to be more readable. *) let parse_pos = match parse_state with | `Sexp { parse_pos; _ } | `Annot { parse_pos; _ } -> parse_pos in Error.raise (Error.create "syntax error when parsing sexp" (sprintf "%s:%d:%d" file parse_pos.text_line parse_pos.text_char, err_msg) [%sexp_of: string * string]) | _ -> raise exn) in let%bind sexps = load ~sexp_kind in try return (convert sexps) with | Of_sexp_error (exn, _bad_subsexp) -> if !may_load_file_multiple_times then ( let%bind sexps = load ~sexp_kind:Annotated in Error.raise (get_error sexps)) else raise_s [%message "invalid sexp (failed to determine location information)" (file : string) (exn : exn)] | exn -> raise_s [%message "Reader.load_sexp(s) error" (file : string) (exn : exn)] ;; type ('sexp, 'a, 'b) load = ?exclusive:bool -> string -> ('sexp -> 'a) -> 'b Deferred.t let get_load_result_exn = function | `Result x -> x | `Error (exn, _sexp) -> raise exn ;; let gen_load_sexp_exn (type a sexp) ?exclusive ~(sexp_kind : sexp sexp_kind) ~file ~(a_of_sexp : sexp -> a) () = let multiple sexps = Error.create "Reader.load_sexp requires one sexp but got" (List.length sexps, file) [%sexp_of: int * string] in gen_load_exn ?exclusive ~file ~sexp_kind (fun sexps -> match sexps with | [ sexp ] -> a_of_sexp sexp | _ -> Error.raise (multiple sexps)) (fun annot_sexps -> match annot_sexps with | [ annot_sexp ] -> (match get_error ~file ~sexp_kind ~a_of_sexp annot_sexp with | Error e -> e | Ok () -> Error.create "conversion of annotated sexp unexpectedly succeeded" (Sexp.Annotated.get_sexp annot_sexp) [%sexp_of: Sexp.t]) | _ -> multiple annot_sexps) ;; let load_sexp_exn ?exclusive file a_of_sexp = gen_load_sexp_exn ?exclusive ~sexp_kind:Plain ~file ~a_of_sexp () ;; let load_annotated_sexp_exn ?exclusive file a_of_sexp = gen_load_sexp_exn ?exclusive ~sexp_kind:Annotated ~file ~a_of_sexp () ;; let gen_load_sexp ?exclusive ~sexp_kind ~file ~a_of_sexp () = Deferred.Or_error.try_with ~run:`Schedule ~rest:`Log ~extract_exn:true (gen_load_sexp_exn ?exclusive ~sexp_kind ~file ~a_of_sexp) ;; let load_sexp ?exclusive file a_of_sexp = gen_load_sexp ?exclusive ~sexp_kind:Plain ~file ~a_of_sexp () ;; let load_annotated_sexp ?exclusive file a_of_sexp = gen_load_sexp ?exclusive ~sexp_kind:Annotated ~file ~a_of_sexp () ;; let gen_load_sexps_exn (type a sexp) ?exclusive ~(sexp_kind : sexp sexp_kind) ~file ~(a_of_sexp : sexp -> a) () = gen_load_exn ?exclusive ~file ~sexp_kind (fun sexps -> List.map sexps ~f:a_of_sexp) (fun annot_sexps -> Error.of_list (List.filter_map annot_sexps ~f:(fun annot_sexp -> match get_error ~file ~sexp_kind ~a_of_sexp annot_sexp with | Ok _ -> None | Error error -> Some error))) ;; let load_sexps_exn ?exclusive file a_of_sexp = gen_load_sexps_exn ?exclusive ~sexp_kind:Plain ~file ~a_of_sexp () ;; let load_annotated_sexps_exn ?exclusive file a_of_sexp = gen_load_sexps_exn ?exclusive ~sexp_kind:Annotated ~file ~a_of_sexp () ;; let gen_load_sexps ?exclusive ~sexp_kind ~file ~a_of_sexp () = Deferred.Or_error.try_with ~run:`Schedule ~rest:`Log ~extract_exn:true (gen_load_sexps_exn ?exclusive ~sexp_kind ~file ~a_of_sexp) ;; let load_sexps ?exclusive file a_of_sexp = gen_load_sexps ?exclusive ~sexp_kind:Plain ~file ~a_of_sexp () ;; let load_annotated_sexps ?exclusive file a_of_sexp = gen_load_sexps ?exclusive ~sexp_kind:Annotated ~file ~a_of_sexp () ;; let pipe t = let pipe_r, pipe_w = Pipe.create () in upon (transfer t pipe_w) (fun () -> close t >>> fun () -> Pipe.close pipe_w); pipe_r ;; let drain t = match%bind read_one_chunk_at_a_time t ~handle_chunk:(fun _bigstring ~pos:_ ~len:_ -> return `Continue) with | `Stopped _ | `Eof_with_unconsumed_data _ -> assert false | `Eof -> close t ;; type ('a, 'b) load_bin_prot = ?exclusive:bool -> ?max_len:int -> string -> 'a Bin_prot.Type_class.reader -> 'b Deferred.t let load_bin_prot ?exclusive ?max_len file bin_reader = match%map Monitor.try_with_or_error ~rest:`Log ~name:"Reader.load_bin_prot" (fun () -> with_file ?exclusive file ~f:(fun t -> read_bin_prot ?max_len t bin_reader)) with | Ok (`Ok v) -> Ok v | Ok `Eof -> Or_error.error_string "Reader.load_bin_prot got unexpected eof" | Error _ as result -> result ;; let load_bin_prot_exn ?exclusive ?max_len file bin_reader = load_bin_prot ?exclusive ?max_len file bin_reader >>| ok_exn ;; async_unix-0.15.0/src/require_explicit_time_source.ml000066400000000000000000000003261420273305200230500ustar00rootroot00000000000000open! Core open! Import include Require_explicit_time_source_intf include From_kernel module Scheduler = Scheduler module Time = Time_unix module Time_ns = Time_ns_unix module Clock = Clock module Date = Core.Date async_unix-0.15.0/src/require_explicit_time_source.mli000066400000000000000000000005341420273305200232220ustar00rootroot00000000000000(** Deprecates functions that use wall-clock time, so that code must be explicit about what time source is used. Idiomatic usage is: {[ open! Require_explicit_time_source ]} or, in an import.ml: {[include Require_explicit_time_source]} *) include Require_explicit_time_source_intf.Require_explicit_time_source (** @open *) async_unix-0.15.0/src/require_explicit_time_source_intf.ml000066400000000000000000000031561420273305200240740ustar00rootroot00000000000000(** Deprecates functions that use wall-clock time, so that code must be explicit about what time source is used. Idiomatic usage is: {[ open! Require_explicit_time_source ]} or, in an import.ml: {[ include Require_explicit_time_source ]} *) open! Core open! Import module From_kernel = Async_kernel_require_explicit_time_source module type Require_explicit_time_source = sig include module type of struct include From_kernel end module Scheduler : sig include module type of struct include Scheduler end val cycle_start : unit -> Time.t [@@deprecated "[since 2016-02] Use [Time_source]"] end module Date : sig include module type of struct include Core.Date end val today : zone:Time.Zone.t -> t [@@deprecated "[since 2019-05] Use [Time_source]"] end module Time : sig include module type of struct include Time_unix end module Ofday : sig include module type of struct include Ofday end val now : zone:Zone.t -> t [@@deprecated "[since 2019-05] Use [Time_source]"] end val now : unit -> t [@@deprecated "[since 2016-02] Use [Time_source]"] end module Time_ns : sig include module type of struct include Time_ns_unix end module Ofday : sig include module type of struct include Ofday end val now : zone:Time.Zone.t -> t [@@deprecated "[since 2019-05] Use [Time_source]"] end val now : unit -> t [@@deprecated "[since 2016-02] Use [Time_source]"] end module Clock : Async_kernel.Clock_ns.Clock_deprecated with module Time := Time end async_unix-0.15.0/src/scheduler.ml000066400000000000000000000025301420273305200170520ustar00rootroot00000000000000(* [Raw_scheduler] is distinct from [Scheduler], because the former exposes some things that are used internally within Async that are not exposed in scheduler.mli. Also, it breaks a cyclic dependency [Raw_scheduler -> Log -> Scheduler]. *) open! Core open! Import include Raw_scheduler let current_execution_context = Async_kernel_scheduler.current_execution_context let time_spent_waiting_for_io () = let t = t () in t.time_spent_waiting_for_io |> Tsc.Span.to_ns ~calibrator:(force Time_stamp_counter.calibrator) |> Time_ns.Span.of_int63_ns ;; let set_min_inter_cycle_timeout min_inter_cycle_timeout = let t = t () in if Time_ns.Span.( > ) min_inter_cycle_timeout (t.max_inter_cycle_timeout :> Time_ns.Span.t) then Error.raise ([%message "min_inter_cycle_timeout too large" (min_inter_cycle_timeout : Time_ns.Span.t) (t.max_inter_cycle_timeout : Max_inter_cycle_timeout.t)] |> [%of_sexp: Error.t]); t.min_inter_cycle_timeout <- Min_inter_cycle_timeout.create_exn min_inter_cycle_timeout ;; let max_num_open_file_descrs () = max_num_open_file_descrs (t ()) let fds_may_produce_events () = fds_may_produce_events (t ()) let thread_pool_has_unfinished_work () = thread_pool_has_unfinished_work (t ()) let max_num_threads () = max_num_threads (t ()) let _ = current_execution_context async_unix-0.15.0/src/scheduler.mli000066400000000000000000000167441420273305200172370ustar00rootroot00000000000000(** Dispatches and monitors Async processes. The threading model is as follows. Only one thread runs Async code at a time. This is enforced by a single lock in Async's scheduler data structure. There are any number of threads running code without holding the lock that get data from the outside world and want to affect the Async world. They do this by calling [Thread_safe.run_in_async*], which acquires the lock, does a computation (e.g., fills an ivar), and then runs a "cycle" of Async computations. *) open! Core open! Import type t = Raw_scheduler.t [@@deriving sexp_of] include module type of struct include Async_kernel_scheduler end (** [t ()] returns the Async scheduler. If the scheduler hasn't been created yet, this will create it and acquire the Async lock. *) val t : unit -> t (** Accessors *) val max_num_open_file_descrs : unit -> int val max_num_threads : unit -> int (** [go ?raise_unhandled_exn ()] passes control to Async, at which point Async starts running handlers, one by one without interruption, until there are no more handlers to run. When Async is out of handlers, it blocks until the outside world schedules more of them. Because of this, Async programs do not exit until [shutdown] is called. [go ()] calls [handle_signal Sys.sigpipe], which causes the SIGPIPE signal to be ignored. Low-level syscalls (e.g., write) still raise EPIPE. If any Async job raises an unhandled exception that is not handled by any monitor, Async execution ceases. Then, by default, Async pretty prints the exception, and exits with status 1. If you don't want this, pass [~raise_unhandled_exn:true], which will cause the unhandled exception to be raised to the caller of [go ()]. *) val go : ?raise_unhandled_exn:bool (** default is [false] *) -> unit -> never_returns (** [go_main] is like [go], except that you supply a [main] function that will be run to initialize the Async computation, and that [go_main] will fail if any Async has been used prior to [go_main] being called. Moreover it allows you to configure more static options of the scheduler. *) val go_main : ?raise_unhandled_exn:bool (** default is [false] *) -> ?file_descr_watcher:Config.File_descr_watcher.t (** default is [Config] *) -> ?max_num_open_file_descrs:int (** default is [Config] *) -> ?max_num_threads:int (** default is [Config] *) -> main:(unit -> unit) -> unit -> never_returns (** [report_long_cycle_times ?cutoff ()] sets up something that will print a warning to stderr whenever there is an Async cycle that is too long, as specified by [cutoff], whose default is 1s. *) val report_long_cycle_times : ?cutoff:Time.Span.t -> unit -> unit (** [is_running ()] returns true if the scheduler has been started. *) val is_running : unit -> bool (** [set_max_inter_cycle_timeout span] sets the maximum amount of time the scheduler will remain blocked (on epoll or select) between cycles. *) val set_max_inter_cycle_timeout : Time.Span.t -> unit (** [set_check_invariants do_check] sets whether Async should check invariants of its internal data structures. [set_check_invariants true] can substantially slow down your program. *) val set_check_invariants : bool -> unit (** [set_detect_invalid_access_from_thread do_check] sets whether Async routines should check if they are being accessed from some thread other than the thread currently holding the Async lock, which is not allowed and can lead to very confusing behavior. *) val set_detect_invalid_access_from_thread : bool -> unit type 'b folder = { folder : 'a. 'b -> t -> (t, 'a) Field.t -> 'b } (** [fold_fields ~init folder] folds [folder] over each field in the scheduler. The fields themselves are not exposed -- [folder] must be a polymorphic function that can work on any field. So, it's only useful for generic operations, e.g., getting the size of each field. *) val fold_fields : init:'b -> 'b folder -> 'b val is_ready_to_initialize : unit -> bool val is_initialized : unit -> bool (** If a process that has already created, but not started, the Async scheduler would like to fork, and would like the child to have a clean Async, i.e., not inherit any of the Async work that was done in the parent, it can call [reset_in_forked_process] at the start of execution in the child process. After that, the child can do Async stuff and then start the Async scheduler. *) val reset_in_forked_process : unit -> unit (** [reset_in_forked_process_without_taking_lock] is similar to [reset_in_forked_process], with the difference that async lock is not taken by the calling thread. This means it's not safe to do Async stuff unless you obtain the lock first, usually by calling functions from the [Thread_safe] module. *) val reset_in_forked_process_without_taking_lock : unit -> unit (** [make_async_unusable ()] makes subsequent attempts to use the Async scheduler raise. One use case for [make_async_unusable] is if you fork from a process already running the Async scheduler, and want to run non-Async OCaml code in the child process, with the guarantee that the child process does not use Async. *) val make_async_unusable : unit -> unit (** [handle_thread_pool_stuck f] causes [f] to run whenever Async detects its thread pool is stuck (i.e., hasn't completed a job for over a second and has work waiting to start). Async checks every second. By default, if the thread pool has been stuck for less than 60s, Async will [eprintf] a message. If more than 60s, Async will send an exception to the main monitor, which will abort the program unless there is a custom handler for the main monitor. Calling [handle_thread_pool_stuck] replaces whatever behavior was previously there. *) val handle_thread_pool_stuck : (stuck_for:Time_ns.Span.t -> unit) -> unit val default_handle_thread_pool_stuck : Thread_pool.t -> stuck_for:Time_ns.Span.t -> unit (** [time_spent_waiting_for_io ()] returns the amount of time that the Async scheduler has spent in calls to [epoll_wait] (or [select]) since the start of the program. *) val time_spent_waiting_for_io : unit -> Time_ns.Span.t (** [set_min_inter_cycle_timeout] sets the minimum timeout that the scheduler will pass to the OS when it checks for I/O between cycles. The minimum is zero by default. Setting it to a nonzero value is used to increase thread fairness between the scheduler and other threads. A plausible setting is 10us. This can also be set via the [ASYNC_CONFIG] environment variable. *) val set_min_inter_cycle_timeout : Time_ns.Span.t -> unit (** Returns true if any user-created fds are registered with the file descriptor watcher. The intended use case for this function (together with [thread_pool_has_unfinished_work]) is approximate deadlock detection, so that a test can crash when it runs out of things to do. *) val fds_may_produce_events : unit -> bool (** Returns true if any of the threads in the thread pool are in use. Note that this value can change from [true] to [false] "suddenly" (from a separate thread) when a thread pool thread finishes. However, the work items submitted to the thread pool by [In_thread.run] enqueue their result as an [external_job] before finishing. So if you observe [thread_pool_has_unfinished_work () = false] and then confirm that there are no external jobs in the scheduler, then you know you didn't miss any thead pool work. *) val thread_pool_has_unfinished_work : unit -> bool async_unix-0.15.0/src/select_file_descr_watcher.ml000066400000000000000000000076641420273305200222640ustar00rootroot00000000000000open Core open Import open File_descr_watcher_intf open Read_write_pair.Export module Table = Bounded_int_table type t = { descr_tables : (File_descr.t, unit) Table.t Read_write_pair.t ; handle_fd_read_ready : File_descr.t -> unit ; handle_fd_read_bad : File_descr.t -> unit ; handle_fd_write_ready : File_descr.t -> unit ; handle_fd_write_bad : File_descr.t -> unit } [@@deriving sexp_of] let backend = Config.File_descr_watcher.Select let invariant t : unit = try Read_write_pair.iter t.descr_tables ~f:(Table.invariant ignore ignore) with | exn -> raise_s [%message "Select_file_descr_watcher.invariant failed" (exn : exn) ~select_file_descr_watcher:(t : t)] ;; type 'a additional_create_args = handle_fd_read_bad:(File_descr.t -> unit) -> handle_fd_write_bad:(File_descr.t -> unit) -> 'a let create ~handle_fd_read_bad ~handle_fd_write_bad ~num_file_descrs ~handle_fd_read_ready ~handle_fd_write_ready = { descr_tables = Read_write_pair.create_fn (fun () -> Table.create ~num_keys:num_file_descrs ~key_to_int:File_descr.to_int ~sexp_of_key:File_descr.sexp_of_t ()) ; handle_fd_read_ready ; handle_fd_read_bad ; handle_fd_write_ready ; handle_fd_write_bad } ;; let reset_in_forked_process _ = () let iter t ~f = Read_write_pair.iteri t.descr_tables ~f:(fun read_or_write table -> Table.iteri table ~f:(fun ~key ~data:_ -> f key read_or_write)) ;; module Pre = struct type t = File_descr.t list Read_write_pair.t [@@deriving sexp_of] end let set t file_descr desired = Read_write_pair.iteri t.descr_tables ~f:(fun read_or_write table -> if Read_write_pair.get desired read_or_write then Table.set table ~key:file_descr ~data:() else Table.remove table file_descr); `Ok ;; let pre_check t = Read_write_pair.map t.descr_tables ~f:Table.keys module Check_result = struct type t = { pre : Pre.t ; select_result : (Unix.Select_fds.t, exn) Result.t } [@@deriving sexp_of] end let thread_safe_check (type a) (_ : t) (pre : Pre.t) (timeout : a Timeout.t) (span : a) = let timeout = match timeout with | Immediately -> `Immediately (* Wait no longer than one second, which avoids any weirdness due to feeding large timeouts to select. *) | After -> `After (Time_ns.Span.min span Time_ns.Span.second) in { Check_result.pre ; select_result = Result.try_with (fun () -> Unix.select ~read:pre.read ~write:pre.write ~except:[] ~timeout ()) } ;; let post_check t ({ Check_result.pre; select_result } as check_result) = try match select_result with (* We think 514 should be treated like EINTR. *) | Error (Unix.Unix_error ((EINTR | EUNKNOWNERR 514), _, _)) -> () | Ok { read; write; except } -> assert (List.is_empty except); List.iter write ~f:t.handle_fd_write_ready; List.iter read ~f:t.handle_fd_read_ready | Error (Unix.Unix_error (EBADF, _, _)) -> let bad read_or_write = let fds = match read_or_write with | `Read -> pre.read | `Write -> pre.write in List.fold fds ~init:[] ~f:(fun ac file_descr -> match Syscall.syscall (fun () -> ignore (Unix.fstat file_descr : Unix.stats)) with | Ok () -> ac | Error (Unix.Unix_error (EBADF, _, _)) -> file_descr :: ac | Error exn -> raise_s [%message "fstat raised unexpected exn" (file_descr : File_descr.t) (exn : exn)]) in List.iter (bad `Write) ~f:t.handle_fd_write_bad; List.iter (bad `Read) ~f:t.handle_fd_read_bad | Error exn -> raise_s [%message "select raised unexpected exn" ~_:(exn : exn)] with | exn -> raise_s [%message "File_descr_watcher.post_check bug" (exn : exn) (check_result : Check_result.t) ~select_file_descr_watcher:(t : t)] ;; async_unix-0.15.0/src/select_file_descr_watcher.mli000066400000000000000000000004061420273305200224200ustar00rootroot00000000000000open! Core open! Import type 'a additional_create_args = handle_fd_read_bad:(File_descr.t -> unit) -> handle_fd_write_bad:(File_descr.t -> unit) -> 'a include File_descr_watcher_intf.S with type 'a additional_create_args := 'a additional_create_args async_unix-0.15.0/src/shutdown.ml000066400000000000000000000072571420273305200167620ustar00rootroot00000000000000(* Unit tests are in ../../lib_test/shutdown_tests.ml *) open Core open Import let debug = Debug.shutdown let todo = ref [] let at_shutdown f = let backtrace = Backtrace.get () in if debug then Debug.log "at_shutdown" backtrace [%sexp_of: Backtrace.t]; todo := (backtrace, f) :: !todo ;; let shutting_down_ref = ref `No let default_force_ref = ref (fun () -> Clock.after (sec 10.)) let default_force () = !default_force_ref let set_default_force force = default_force_ref := force let shutting_down () = !shutting_down_ref let is_shutting_down () = match shutting_down () with | `No -> false | `Yes _ -> true ;; (* Be careful to ensure [shutdown] doesn't raise just because stderr is closed *) let ignore_exn f = try f () with | _ -> () ;; let exit_reliably status = match (exit status : Nothing.t) with | exception exn -> ignore_exn (fun () -> Core.Debug.eprints "Caml.exit raised" exn [%sexp_of: Exn.t]); Core_unix.exit_immediately (if status = 0 then 1 else status) | _ -> . ;; let shutdown ?force status = if debug then ignore_exn (fun () -> Debug.log "shutdown" status [%sexp_of: int]); match !shutting_down_ref with | `Yes status' -> if status <> 0 && status' <> 0 && status <> status' then raise_s [%message "shutdown with inconsistent status" (status : int) (status' : int)] else if status' = 0 && status <> 0 then shutting_down_ref := `Yes status | `No -> shutting_down_ref := `Yes status; upon (Deferred.all (List.map !todo ~f:(fun (backtrace, f) -> let%map result = Monitor.try_with_or_error ~rest:`Log f in (match result with | Ok () -> () | Error error -> ignore_exn (fun () -> Core.Debug.eprints "at_shutdown function raised" (error, backtrace) [%sexp_of: Error.t * Backtrace.t])); if debug then ignore_exn (fun () -> Debug.log "one at_shutdown function finished" backtrace [%sexp_of: Backtrace.t]); result))) (fun results -> match shutting_down () with | `No -> assert false | `Yes status -> let status = match Or_error.combine_errors_unit results with | Ok () -> status | Error _ -> if status = 0 then 1 else status in exit_reliably status); let force = match force with | None -> !default_force_ref () | Some f -> f in upon force (fun () -> ignore_exn (fun () -> Debug.log_string "Shutdown forced."); exit_reliably 1) ;; let shutdown_on_unhandled_exn () = Monitor.detach_and_iter_errors Monitor.main ~f:(fun exn -> ignore_exn (fun () -> Debug.log "shutting down due to unhandled exception" exn [%sexp_of: exn]); try shutdown 1 with | _ -> (* The above [shutdown] call raises if we have already called shutdown with a different non-zero status. *) ()) ;; let exit ?force status = shutdown ?force status; Deferred.never () ;; let don't_finish_before = let proceed_with_shutdown = Ivar.create () in let num_waiting = ref 0 in let check () = if !num_waiting = 0 then Ivar.fill proceed_with_shutdown () in at_shutdown (fun () -> check (); Ivar.read proceed_with_shutdown); fun d -> match shutting_down () with | `Yes _ -> () | `No -> incr num_waiting; upon d (fun () -> decr num_waiting; match shutting_down () with | `No -> () | `Yes _ -> check ()) ;; async_unix-0.15.0/src/shutdown.mli000066400000000000000000000077571420273305200171400ustar00rootroot00000000000000(** For shutting down an Async program. *) open! Core open! Import (** [shutdown ?force status] initiates shutdown, which runs all the [at_shutdown] functions, waits for them to finish, and then exits with the supplied status. The [at_shutdown] functions can block -- one can use [~force] to forcibly exit (with status 1) if the [at_shutdown] functions do not finish in a reasonable amount of time. By default, [force] is [after (sec 10.)]. Repeated calls to [shutdown] with the same status will have no effect. Any call to [shutdown] with nonzero status will cause that to be the status that is exited with. A call to [shutdown] with different nonzero status from the original call will raise. *) val shutdown : ?force:unit Deferred.t -> int -> unit (** [shutdown_on_unhandled_exn ()] arranges things so that whenever there is an asynchronous unhandled exception, an error message is printed to stderr and [shutdown 1] is called. This is useful when one wants to ensure that [at_shutdown] handlers run when there is an unhandled exception. Calling [shutdown_on_unhandled_exn] ensures that [Scheduler.go] will not raise due to an unhandled exception, and instead that the program will exit once [at_shutdown] handlers finish. *) val shutdown_on_unhandled_exn : unit -> unit (** [exit ?force status] is [shutdown ?force status; Deferred.never ()]. We do not have an exit function that returns a non-deferred: {[ val exit : ?force:unit Deferred.t -> int -> _ ]} Such a function should not exist, for the same reason that we do not have: {[ val block : 'a Deferred.t -> 'a ]} The semantics of such an exit function would allow one to block a running Async job, and to switch to another one (to run the [at_shutdown] handlers), without expressing that switch in the type system via a [Deferred.t]. That would eliminate all the nice reasoning guarantees that Async gives about concurrent jobs. *) val exit : ?force:unit Deferred.t -> int -> _ Deferred.t (** [default_force] returns the default [force] value used by [shutdown] and [exit]. *) val default_force : unit -> unit -> unit Deferred.t (** [set_default_force f] sets the default [force] value used by [shutdown] and [exit] to [f]. Initially, the default value is [fun () -> after (sec 10.)]. A subsequent call to [shutdown] or [exit] that doesn't supply [~force] will call [f] and will force shutdown when its result becomes determined. [set_default_force] has no effect if [shutdown] or [exit] has already been called, or if the next call to [shutdown] or [exit] supplies [~force]. [set_default_force] is useful for applications that call [shutdown] indirectly via a library, yet want to modify its behavior. *) val set_default_force : (unit -> unit Deferred.t) -> unit (** [shutting_down ()] reports whether we are currently shutting down, and if so, with what status. *) val shutting_down : unit -> [ `No | `Yes of int ] val is_shutting_down : unit -> bool (** [at_shutdown f] causes [f ()] to be run when [shutdown] is called, and for [shutdown] to wait until the returned deferred finishes. If [f] raises (synchronously or asynchronously), then the exception is printed to stderr and the program exits nonzero, irrespective of the status supplied to [shutdown]. If [shutdown] has already been called, then calling [at_shutdown f] does nothing. The functions supplied to [at_shutdown] are run in parallel on shutdown. *) val at_shutdown : (unit -> unit Deferred.t) -> unit (** [don't_finish_before d] causes [shutdown] to wait until [d] becomes determined before finishing. It is like [at_shutdown (fun _ -> d)], except it is more efficient, and will not take any space once [d] is determined. There is a single [at_shutdown] shared among all deferreds supplied to [don't_finish_before]. [don't_finish_before] does not override the [force] argument passed to shutdown. *) val don't_finish_before : unit Deferred.t -> unit async_unix-0.15.0/src/signal.ml000066400000000000000000000015231420273305200163520ustar00rootroot00000000000000open Core open Import include Core.Signal let handle_default `Do_not_use_with_async = assert false let ignore `Do_not_use_with_async = assert false module Scheduler = Raw_scheduler let the_one_and_only = Scheduler.the_one_and_only let handle ?stop ts ~f = let scheduler = the_one_and_only () in let signal_manager = scheduler.signal_manager in let handler = Raw_signal_manager.install_handler signal_manager ts (unstage (Scheduler.preserve_execution_context f)) in Option.iter stop ~f:(fun stop -> upon stop (fun () -> Raw_signal_manager.remove_handler signal_manager handler)) ;; let terminating = [ alrm; hup; int; term; usr1; usr2 ] let is_managed_by_async t = let scheduler = the_one_and_only () in let signal_manager = scheduler.signal_manager in Raw_signal_manager.is_managing signal_manager t ;; async_unix-0.15.0/src/signal.mli000066400000000000000000000035551420273305200165320ustar00rootroot00000000000000(** Signal handling. *) open! Import (** To discourage use of the [Signal.Expert] module, we hide it here. People can use [Core.Signal.Expert] if they need. *) include module type of Core.Signal with type t = Core.Signal.t with module Expert := Core.Signal.Expert (** We override values from [Core.Signal] that we don't want people to use with Async. *) val handle_default : [ `Do_not_use_with_async ] -> _ val ignore : [ `Do_not_use_with_async ] -> _ (** [handle ?stop signals ~f] arranges so that whenever a signal in [signals] is delivered, [f] is called on that signal. If [f] raises, then an exception will be raised to the monitor in effect when [handle] was called. Multiple calls to [handle] with the same signal will cause all the handlers to run when that signal is delivered, not just the last handler from the last call to [handle]. The first time [handle] is called for a signal, it will install a C signal handler for it, replacing the existing C signal handler for that signal. *) val handle : ?stop:unit Deferred.t -> t list -> f:(t -> unit) -> unit (** [terminating] is a list of signals that can be supplied to [handle] and whose default behavior is to terminate the program: [alrm hup int term usr1 usr2]. Various signals whose [default_sys_behavior] is [`Terminate] are not included: {v | kill | it's not allowed to be handled | | pipe | Async already ignores this signal, since it handles EPIPE | | prof | so that we can profile things with -p | | vtalrm | it already has a handler | v} *) val terminating : t list (** [is_managed_by_async signal] returns true iff [signal] is being managed by Async, and hence its default behavior is no longer in effect. *) val is_managed_by_async : t -> bool async_unix-0.15.0/src/signal_manager.ml000066400000000000000000000003261420273305200200440ustar00rootroot00000000000000(* Although this seems pointless, separating Signal_manager (whose .mli references the Signal module) from Raw_signal_manager prevents a dependency cycle when using ocamlbuild. *) include Raw_signal_manager async_unix-0.15.0/src/signal_manager.mli000066400000000000000000000036161420273305200202220ustar00rootroot00000000000000(** A signal manager keeps track of a set of signals to be managed and the signal handlers for them. When a signal manager is managing a signal, it installs its own OCaml handler for that signal that records delivery of the signal. It then later, upon request, will deliver the signal to all its handlers. Once a signal manager starts managing a signal, it never stops. *) open! Core type t [@@deriving sexp_of] include Invariant.S with type t := t (** [create] creates and returns a signal manager [t]. Whenever a signal that [t] is managing is delivered, it will call [thread_safe_notify_signal_delivered] from within the OCaml signal handler. Therefore [thread_safe_notify_signal_delivered] must be thread safe. *) val create : thread_safe_notify_signal_delivered:(unit -> unit) -> t (** [manage t signal] causes [t] to manage [signal], thus overriding [default_sys_behavior] for that signal, and any other OCaml handler for that signal. *) val manage : t -> Signal.t -> unit (** [is_managing t signal] returns true iff [manage t signal] has been called *) val is_managing : t -> Signal.t -> bool (** [install_handler t signals f] causes [t] to manage the handling of [signals], and registers [f] to run on every signal in [signals] that is delivered. It is an error if [f] ever raises when it is called. *) type handler val install_handler : t -> Signal.t list -> (Signal.t -> unit) -> handler (** [remove_handler handler] causes the particular [handler] to no longer handle the signals it was registered to handle. The signal manager continues to manage those signals, i.e. the OCaml signal handler remains installed, whether or not they still have handlers. *) val remove_handler : t -> handler -> unit (** [handle_delivered t] runs all signal handlers on the signals that have been delivered but not yet handled. *) val handle_delivered : t -> unit async_unix-0.15.0/src/syscall.ml000066400000000000000000000020661420273305200165520ustar00rootroot00000000000000open Core open Poly module Unix = Core_unix module Syscall_result = Unix.Syscall_result let max_tries = 1000 let too_many_tries = Error.to_exn (Error.create "syscall interrupted too many times" max_tries [%sexp_of: int]) ;; let too_many_tries_error = Error too_many_tries let syscall = let rec loop f n = if n >= max_tries then too_many_tries_error else ( match f () with | x -> Ok x | exception Unix.Unix_error (EINTR, _, _) -> loop f (n + 1) | exception exn -> Error exn) in fun f -> loop f 0 ;; let is_eintr r = Syscall_result.is_error r && Syscall_result.error_exn r = EINTR let syscall_result = let rec loop a f n = if n >= max_tries then raise too_many_tries else ( let r = f a in if not (is_eintr r) then r else loop a f (n + 1)) in fun a f -> loop a f 0 ;; let syscall_result2 = let rec loop a b f n = if n >= max_tries then raise too_many_tries else ( let r = f a b in if not (is_eintr r) then r else loop a b f (n + 1)) in fun a b f -> loop a b f 0 ;; async_unix-0.15.0/src/syscall.mli000066400000000000000000000011561420273305200167220ustar00rootroot00000000000000(** Automatically retrying system calls that may be interrupted with EINTR. *) open! Core open! Import module Syscall_result = Unix.Syscall_result (** [syscall f] repeatedly calls [f] until it returns or raises an exception that isn't [Unix_error (EINTR, _, _)]. *) val syscall : (unit -> 'a) -> ('a, exn) Result.t (** [syscall_result a f] repeatedly calls [f a] until it returns a result that is not [Syscall_result.create_error EINTR]. *) val syscall_result : 'a -> ('a -> 'b Syscall_result.t) -> 'b Syscall_result.t val syscall_result2 : 'a -> 'b -> ('a -> 'b -> 'c Syscall_result.t) -> 'c Syscall_result.t async_unix-0.15.0/src/tcp.ml000066400000000000000000000673131420273305200156740ustar00rootroot00000000000000open! Core open! Import module Unix = Unix_syscalls module Socket = Unix.Socket module Where_to_connect = struct type 'addr t = { socket_type : 'addr Socket.Type.t ; remote_address : unit -> 'addr Deferred.t ; local_address : 'addr option ; info : Sexp.t } let sexp_of_t _ { info; _ } = info type inet = Socket.Address.Inet.t t [@@deriving sexp_of] type unix = Socket.Address.Unix.t t [@@deriving sexp_of] let remote_address t = t.remote_address () let create_local_address ~bind_to_address ~bind_to_port = let port = Option.value bind_to_port ~default:0 in match bind_to_address with | None -> Socket.Address.Inet.create_bind_any ~port | Some inet_addr -> Socket.Address.Inet.create ~port inet_addr ;; let of_host_and_port ?bind_to_address ?bind_to_port ({ Host_and_port.host; port } as hp) = { socket_type = Socket.Type.tcp ; remote_address = (fun () -> Unix.Inet_addr.of_string_or_getbyname host >>| fun inet_addr -> Socket.Address.Inet.create inet_addr ~port) ; local_address = Some (create_local_address ~bind_to_address ~bind_to_port) ; info = [%sexp (hp : Host_and_port.t)] } ;; let of_file file = { socket_type = Socket.Type.unix ; remote_address = (fun () -> return (Socket.Address.Unix.create file)) ; local_address = None ; info = [%sexp_of: string] file } ;; let of_inet_address ?bind_to_address ?bind_to_port address = { socket_type = Socket.Type.tcp ; remote_address = (fun () -> return address) ; local_address = Some (create_local_address ~bind_to_address ~bind_to_port) ; info = [%sexp_of: Socket.Address.Inet.t] address } ;; let of_unix_address address = { socket_type = Socket.Type.unix ; remote_address = (fun () -> return address) ; local_address = None ; info = [%sexp_of: Socket.Address.Unix.t] address } ;; end let close_sock_on_error s f = Monitor.try_with ~run:`Schedule ~rest:`Log ~name:"Tcp.close_sock_on_error" f >>| function | Ok v -> v | Error e -> (* [close] may fail, but we don't really care, since it will fail asynchronously. The error we really care about is [e], and the [raise_error] will cause the current monitor to see that. *) don't_wait_for (Unix.close (Socket.fd s)); raise e ;; let reader_writer_of_sock ?buffer_age_limit ?reader_buffer_size ?writer_buffer_size s = let fd = Socket.fd s in ( Reader.create ?buf_len:reader_buffer_size fd , Writer.create ?buffer_age_limit ?buf_len:writer_buffer_size fd ) ;; let connect_sock ?socket ?interrupt ?(timeout = sec 10.) ?time_source (where_to_connect : _ Where_to_connect.t) = let time_source = match time_source with | Some x -> Time_source.read_only x | None -> Time_source.wall_clock () in where_to_connect.remote_address () >>= fun address -> let timeout = Time_source.Event.after time_source (Time_ns.Span.of_span_float_round_nearest timeout) in let interrupt = let timeout = Time_source.Event.fired timeout >>= function | Aborted () -> Deferred.never () | Happened () -> Deferred.unit in match interrupt with | None -> timeout | Some interrupt -> Deferred.any [ interrupt; timeout ] in let connect_interruptible s = Socket.connect_interruptible s address ~interrupt in Deferred.create (fun result -> let s = match socket with | Some s -> s | None -> Socket.create where_to_connect.socket_type in close_sock_on_error s (fun () -> match where_to_connect.local_address with | None -> connect_interruptible s | Some local_interface -> Socket.bind s local_interface >>= fun s -> connect_interruptible s) >>> function | `Ok s -> Time_source.Event.abort_if_possible timeout (); Ivar.fill result s | `Interrupted -> don't_wait_for (Unix.close (Socket.fd s)); let address = Socket.Address.to_string address in (match Time_source.Event.abort timeout () with | Previously_happened () -> raise_s [%sexp "connection attempt timeout", (address : string)] | Ok | Previously_aborted () -> raise_s [%sexp "connection attempt aborted", (address : string)])) ;; type 'a with_connect_options = ?buffer_age_limit:[ `At_most of Time.Span.t | `Unlimited ] -> ?interrupt:unit Deferred.t -> ?reader_buffer_size:int -> ?writer_buffer_size:int -> ?timeout:Time.Span.t -> ?time_source:Time_source.t -> 'a let connect ?socket ?buffer_age_limit ?interrupt ?reader_buffer_size ?writer_buffer_size ?timeout ?time_source where_to_connect = connect_sock ?socket ?interrupt ?timeout ?time_source where_to_connect >>| fun s -> let r, w = reader_writer_of_sock ?buffer_age_limit ?reader_buffer_size ?writer_buffer_size s in s, r, w ;; let collect_errors writer f = let monitor = Writer.monitor writer in ignore (Monitor.detach_and_get_error_stream monitor : _ Stream.t); (* don't propagate errors up, we handle them here *) choose [ choice (Monitor.get_next_error monitor) (fun e -> Error e) ; choice (Monitor.try_with ~run: `Schedule ~rest:`Log ~name:"Tcp.collect_errors" f) Fn.id ] ;; let close_connection_via_reader_and_writer r w = let force_close_event = Clock.Event.after (sec 30.) in let force_close = Clock.Event.fired force_close_event >>= function | Aborted () -> Deferred.never () | Happened () -> Deferred.unit in Writer.close w ~force_close >>= fun () -> Clock.Event.abort_if_possible force_close_event (); Reader.close r ;; let with_connection ?buffer_age_limit ?interrupt ?reader_buffer_size ?writer_buffer_size ?timeout ?time_source where_to_connect f = connect_sock ?interrupt ?timeout ?time_source where_to_connect >>= fun socket -> let r, w = reader_writer_of_sock ?buffer_age_limit ?reader_buffer_size ?writer_buffer_size socket in let res = collect_errors w (fun () -> f socket r w) in Deferred.any [ (res >>| fun (_ : ('a, exn) Result.t) -> ()) ; Reader.close_finished r ; Writer.close_finished w ] >>= fun () -> close_connection_via_reader_and_writer r w >>= fun () -> res >>| function | Ok v -> v | Error e -> raise e ;; module Bind_to_address = struct type t = | Address of Unix.Inet_addr.t | All_addresses | Localhost [@@deriving sexp_of] end module Bind_to_port = struct type t = | On_port of int | On_port_chosen_by_os [@@deriving sexp_of] end module Where_to_listen = struct type ('address, 'listening_on) t = { socket_type : 'address Socket.Type.t ; address : 'address ; listening_on : ('address -> 'listening_on[@sexp.opaque]) } [@@deriving sexp_of, fields] type inet = (Socket.Address.Inet.t, int) t [@@deriving sexp_of] type unix = (Socket.Address.Unix.t, string) t [@@deriving sexp_of] let is_inet_witness t = Socket.Family.is_inet_witness (Socket.Type.family t.socket_type) let create ~socket_type ~address ~listening_on = { socket_type; address; listening_on } let bind_to (bind_to_address : Bind_to_address.t) (bind_to_port : Bind_to_port.t) = let port = match bind_to_port with | On_port port -> port | On_port_chosen_by_os -> 0 in let address = match bind_to_address with | All_addresses -> Socket.Address.Inet.create_bind_any ~port | Address addr -> Socket.Address.Inet.create addr ~port | Localhost -> Socket.Address.Inet.create Unix.Inet_addr.localhost ~port in { socket_type = Socket.Type.tcp ; address ; listening_on = (function | `Inet (_, port) -> port) } ;; let of_port port = bind_to All_addresses (On_port port) let of_port_chosen_by_os = bind_to All_addresses On_port_chosen_by_os let of_file path = { socket_type = Socket.Type.unix ; address = Socket.Address.Unix.create path ; listening_on = (fun _ -> path) } ;; let binding_on_port_chosen_by_os t = match t.address with | `Inet _ as inet -> Socket.Address.Inet.port inet = 0 | `Unix _ -> false ;; let max_retries_upon_addr_in_use t = match binding_on_port_chosen_by_os t with | true -> 10 | false -> 0 ;; end module Server = struct module Connection = struct type 'address t = { client_socket : ([ `Active ], 'address) Socket.t ; client_address : 'address } [@@deriving fields, sexp_of] let invariant invariant_address t = Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> let check f = Invariant.check_field t f in Fields.iter ~client_socket:ignore ~client_address:(check invariant_address)) ;; let create ~client_socket ~client_address = { client_socket; client_address } let close t = Fd.close (Socket.fd t.client_socket) end module Max_connections = struct type t = { limit : int ; time_source : Time_source.t ; listening_on : Info.t ; mutable last_logged : Time_ns.t option } let sexp_of_t t = [%sexp_of: int] t.limit let create ~limit ~time_source ~listening_on = { limit; time_source; listening_on; last_logged = None } ;; (* We make sure not to be too spammy with logs. This number was chosen pretty arbitrarily. *) let log_threshold = Time_ns.Span.of_min 1. let log_at_limit t ~now = Log.Global.error_s [%message "At limit of Tcp server [max_connections]. New connections will not be \ accepted until an existing connection is closed." ~limit:(t.limit : int) ~listening_on:(t.listening_on : Info.t)]; t.last_logged <- Some now ;; let maybe_log_at_limit t = let now = Time_source.now t.time_source in match t.last_logged with | None -> log_at_limit t ~now | Some last_logged -> if Time_ns.Span.( > ) (Time_ns.diff now last_logged) log_threshold then log_at_limit t ~now ;; end type ('address, 'listening_on) t = { socket : ([ `Passive ], 'address) Socket.t ; listening_on : 'listening_on ; on_handler_error : [ `Raise | `Ignore | `Call of 'address -> exn -> unit ] ; handle_client : 'address -> ([ `Active ], 'address) Socket.t -> (unit, exn) Result.t Deferred.t ; max_connections : Max_connections.t ; max_accepts_per_batch : int ; connections : 'address Connection.t Bag.t ; mutable accept_is_pending : bool ; mutable drop_incoming_connections : bool ; close_finished_and_handlers_determined : unit Ivar.t } [@@deriving fields, sexp_of] let num_connections t = Bag.length t.connections let listening_socket = socket type inet = (Socket.Address.Inet.t, int) t [@@deriving sexp_of] type unix = (Socket.Address.Unix.t, string) t [@@deriving sexp_of] let listening_on_address (t : (_, _) t) = Socket.getsockname t.socket let invariant t : unit = try let check f field = f (Field.get field t) in Fields.iter ~socket:ignore ~listening_on:ignore ~on_handler_error:ignore ~handle_client:ignore ~max_connections: (check (fun (max_connections : Max_connections.t) -> assert (max_connections.limit >= 1))) ~max_accepts_per_batch: (check (fun max_accepts_per_batch -> assert (max_accepts_per_batch >= 1))) ~connections: (check (fun connections -> Bag.invariant (Connection.invariant ignore) connections; let num_connections = num_connections t in assert (num_connections >= 0); assert (num_connections <= t.max_connections.limit))) ~accept_is_pending:ignore ~drop_incoming_connections:ignore ~close_finished_and_handlers_determined:ignore with | exn -> failwiths ~here:[%here] "invariant failed" (exn, t) [%sexp_of: exn * (_, _) t] ;; let fd t = Socket.fd t.socket let is_closed t = Fd.is_closed (fd t) let close_finished t = Fd.close_finished (fd t) let close_finished_and_handlers_determined t = Ivar.read t.close_finished_and_handlers_determined ;; let close ?(close_existing_connections = false) t = let fd_closed = Fd.close (fd t) in if not close_existing_connections then fd_closed else (* Connections are removed from the bag by the [maybe_accept] below, as the fds are closed. *) Deferred.all_unit (fd_closed :: List.map (Bag.to_list t.connections) ~f:Connection.close) ;; (* [maybe_accept] is a bit tricky, but the idea is to avoid calling [accept] until we have an available slot (determined by [num_connections < max_connections]). *) let rec maybe_accept t = let available_slots = t.max_connections.limit - num_connections t in if (not (is_closed t)) && available_slots > 0 && not t.accept_is_pending then ( t.accept_is_pending <- true; Socket.accept_at_most ~limit:(min t.max_accepts_per_batch available_slots) t.socket >>> fun accept_result -> t.accept_is_pending <- false; match accept_result with | `Socket_closed -> () | `Ok conns -> (* It is possible that someone called [close t] after the [accept] returned but before we got here. In that case, we just close the clients. *) if is_closed t || t.drop_incoming_connections then List.iter conns ~f:(fun (sock, _) -> don't_wait_for (Fd.close (Socket.fd sock))) else (* We first [handle_client] on all the connections, which increases [num_connections], and then call [maybe_accept] to try to accept more clients, which respects the just-increased [num_connections]. *) List.iter conns ~f:(fun (sock, addr) -> handle_client t sock addr); maybe_accept t) else if (not (is_closed t)) && available_slots = 0 then Max_connections.maybe_log_at_limit t.max_connections and handle_client t client_socket client_address = let connection = Connection.create ~client_socket ~client_address in let connections_elt = Bag.add t.connections connection in t.handle_client client_address client_socket >>> fun res -> Connection.close connection >>> fun () -> Bag.remove t.connections connections_elt; if Deferred.is_determined (close_finished t) && num_connections t = 0 then Ivar.fill_if_empty t.close_finished_and_handlers_determined (); (match res with | Ok () -> () | Error e -> (try match t.on_handler_error with | `Ignore -> () | `Raise -> raise e | `Call f -> f client_address e with | e -> don't_wait_for (close t); raise e)); maybe_accept t ;; let create_from_socket ~max_connections ?(max_accepts_per_batch = 1) ?(drop_incoming_connections = false) ~on_handler_error (where_to_listen : _ Where_to_listen.t) handle_client socket = let t = { socket ; listening_on = where_to_listen.listening_on (Socket.getsockname socket) ; on_handler_error ; handle_client ; max_connections ; max_accepts_per_batch ; connections = Bag.create () ; accept_is_pending = false ; drop_incoming_connections ; close_finished_and_handlers_determined = Ivar.create () } in (close_finished t >>> fun () -> if num_connections t = 0 then Ivar.fill_if_empty t.close_finished_and_handlers_determined ()); maybe_accept t; t ;; let get_max_connections_limit max_connections = match max_connections with | None -> 10_000 | Some max_connections -> if max_connections <= 0 then failwiths ~here:[%here] "Tcp.Server.creater got negative [max_connections]" max_connections sexp_of_int; max_connections ;; module Socket_creator : sig type 'a t constraint 'a = [< Socket.Address.t ] val create : ([ `Unconnected ], 'addr) Socket.t option -> ('addr, _) Where_to_listen.t -> 'addr t val bind_and_listen_maybe_retry : 'addr t -> f: (([ `Unconnected ], 'addr) Socket.t -> reuseaddr:bool -> ([ `Passive ], 'addr) Socket.t Deferred.t) -> ([ `Passive ], 'addr) Socket.t Deferred.t val bind_and_listen_maybe_retry' : 'addr t -> f: (([ `Unconnected ], 'addr) Socket.t -> reuseaddr:bool -> ([ `Passive ], 'addr) Socket.t) -> ([ `Passive ], 'addr) Socket.t end = struct type 'addr t = { create_socket : unit -> ([ `Unconnected ], 'addr) Socket.t ; should_set_reuseaddr : bool ; retries_upon_addr_in_use : int } let create maybe_socket where_to_listen = match maybe_socket with | Some socket -> { create_socket = Fn.const socket ; should_set_reuseaddr = false ; retries_upon_addr_in_use = 0 } | None -> { create_socket = (fun () -> Socket.create where_to_listen.Where_to_listen.socket_type) ; should_set_reuseaddr = true ; retries_upon_addr_in_use = Where_to_listen.max_retries_upon_addr_in_use where_to_listen } ;; let handle_exn t socket exn ~retries_attempted_upon_addr_in_use = don't_wait_for (Unix.close (Socket.fd socket)); match t.retries_upon_addr_in_use > retries_attempted_upon_addr_in_use, exn with | true, Unix.Unix_error (EADDRINUSE, _, _) -> `Please_retry | _, _ -> if retries_attempted_upon_addr_in_use > 0 then raise_s [%message "Failed to bind and listen to socket." (exn : Exn.t) (retries_attempted_upon_addr_in_use : int)] else raise exn ;; let rec aux_bind_and_listen_maybe_retry t ~retries_attempted_upon_addr_in_use ~f = let socket = t.create_socket () in match%bind Monitor.try_with ~extract_exn:true (fun () -> f socket ~reuseaddr:t.should_set_reuseaddr) with | Ok v -> return v | Error exn -> let `Please_retry = handle_exn t socket exn ~retries_attempted_upon_addr_in_use in aux_bind_and_listen_maybe_retry t ~retries_attempted_upon_addr_in_use:(retries_attempted_upon_addr_in_use + 1) ~f ;; let rec aux_bind_and_listen_maybe_retry' t ~retries_attempted_upon_addr_in_use ~f = let socket = t.create_socket () in try f socket ~reuseaddr:t.should_set_reuseaddr with | exn -> let `Please_retry = handle_exn t socket exn ~retries_attempted_upon_addr_in_use in aux_bind_and_listen_maybe_retry' t ~retries_attempted_upon_addr_in_use:(retries_attempted_upon_addr_in_use + 1) ~f ;; let bind_and_listen_maybe_retry = aux_bind_and_listen_maybe_retry ~retries_attempted_upon_addr_in_use:0 ;; let bind_and_listen_maybe_retry' = aux_bind_and_listen_maybe_retry' ~retries_attempted_upon_addr_in_use:0 ;; end let create_sock_non_inet_internal ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error (where_to_listen : _ Where_to_listen.t) handle_client = let time_source = match time_source with | Some x -> Time_source.read_only x | None -> Time_source.wall_clock () in let%map socket = let socket_creator = Socket_creator.create socket where_to_listen in Socket_creator.bind_and_listen_maybe_retry socket_creator ~f:(fun socket ~reuseaddr -> Socket.bind ~reuseaddr socket where_to_listen.address >>| Socket.listen ?backlog) in let max_connections = Max_connections.create ~limit:(get_max_connections_limit max_connections) ~time_source (* We must call [Fd.info] on the socket's fd after [Socket.bind] is called, otherwise the [Info.t] won't have been set yet. *) ~listening_on:(Fd.info (Socket.fd socket)) in create_from_socket ~max_connections ?max_accepts_per_batch ?drop_incoming_connections ~on_handler_error where_to_listen handle_client socket ;; let create_sock_inet_internal ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?(socket : ([ `Unconnected ], Socket.Address.Inet.t) Socket.t option) ?time_source ~on_handler_error (where_to_listen : (Socket.Address.Inet.t, 'listening_on) Where_to_listen.t) handle_client = let time_source = match time_source with | Some x -> Time_source.read_only x | None -> Time_source.wall_clock () in let socket = let socket_creator = Socket_creator.create socket where_to_listen in Socket_creator.bind_and_listen_maybe_retry' socket_creator ~f:(fun socket ~reuseaddr -> Socket.bind_inet ~reuseaddr socket where_to_listen.address |> Socket.listen ?backlog) in let max_connections = Max_connections.create ~limit:(get_max_connections_limit max_connections) ~time_source (* We must call [Fd.info] on the socket's fd after [Socket.bind_inet] is called, otherwise the [Info.t] won't have been set yet. *) ~listening_on:(Fd.info (Socket.fd socket)) in create_from_socket ~max_connections ?max_accepts_per_batch ?drop_incoming_connections ~on_handler_error where_to_listen handle_client socket ;; type ('address, 'listening_on, 'time_source_access) create_sock_async = ?max_connections:int -> ?max_accepts_per_batch:int -> ?backlog:int -> ?drop_incoming_connections:bool -> ?socket:([ `Unconnected ], 'address) Socket.t -> ?time_source:([> read ] as 'time_source_access) Time_source.T1.t -> on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] -> ('address, 'listening_on) Where_to_listen.t -> ('address -> ([ `Active ], 'address) Socket.t -> (unit, exn) Result.t Deferred.t) -> ('address, 'listening_on) t Deferred.t let create_sock_inet_internal_async : ('address, _, _) create_sock_async = fun ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client -> return (create_sock_inet_internal ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client) ;; type ('address, 'listening_on, 't) create_sock_async_no_constraint = | T : ('address, 'listening_on, 't) create_sock_async -> ('address, 'listening_on, 't) create_sock_async_no_constraint type 'address is_address_type = T : [< Socket.Address.t ] is_address_type let create_sock_internal_type_hackery : type address listening_on. is_address:address is_address_type -> is_inet:(address, [ `Inet of Unix.Inet_addr.t * int ]) Type_equal.t option -> (address, listening_on, _) create_sock_async_no_constraint = fun ~is_address ~is_inet -> match is_inet with | Some T -> T create_sock_inet_internal_async | None -> let T = is_address in T create_sock_non_inet_internal ;; let create_sock_internal : (_, _, [> read ]) create_sock_async = fun ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client -> let (T f) = create_sock_internal_type_hackery ~is_inet:(Where_to_listen.is_inet_witness where_to_listen) ~is_address:T in f ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client ;; let create_sock ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error (where_to_listen : ('address, 'listening_on) Where_to_listen.t) (handle_client : ([< Socket.Address.t ] as 'b) -> ([ `Active ], 'b) Socket.t -> unit Deferred.t) = create_sock_internal ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ~on_handler_error ?socket ?time_source where_to_listen (fun client_address client_socket -> Monitor.try_with ~run: `Schedule ~rest:`Log ~name:"Tcp.Server.create_sock" (fun () -> handle_client client_address client_socket)) ;; let create_sock_inet ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client = create_sock_inet_internal ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen (fun client_address client_socket -> Monitor.try_with ~run: `Schedule ~rest:`Log ~name:"Tcp.Server.create_sock_inet" (fun () -> handle_client client_address client_socket)) ;; let create_internal ~create_sock ?buffer_age_limit ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client = create_sock ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen (fun client_address client_socket -> let r, w = reader_writer_of_sock ?buffer_age_limit client_socket in Writer.set_raise_when_consumer_leaves w false; Deferred.any [ collect_errors w (fun () -> handle_client client_address r w) ; Writer.consumer_left w |> Deferred.ok ] >>= fun res -> close_connection_via_reader_and_writer r w >>| fun () -> res) ;; let create_inet ?buffer_age_limit ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client = create_internal ~create_sock:create_sock_inet_internal ?buffer_age_limit ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client ;; let create ?buffer_age_limit ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client = create_internal ~create_sock:create_sock_internal ?buffer_age_limit ?max_connections ?max_accepts_per_batch ?backlog ?drop_incoming_connections ?socket ?time_source ~on_handler_error where_to_listen handle_client ;; module Private = struct let fd = fd end end module Private = struct let close_connection_via_reader_and_writer = close_connection_via_reader_and_writer end async_unix-0.15.0/src/tcp.mli000066400000000000000000000361311420273305200160370ustar00rootroot00000000000000(** [Tcp] supports connection to [inet] sockets and [unix] sockets. These are two different types. We use ['a Where_to_connect.t] to specify a socket to connect to, where the ['a] identifies the type of socket. *) open! Core open! Import open! Unix_syscalls (** A [Where_to_connect] describes the socket that a tcp client should connect to. *) module Where_to_connect : sig type 'a t constraint 'a = [< Socket.Address.t ] [@@deriving sexp_of] type inet = Socket.Address.Inet.t t [@@deriving sexp_of] type unix = Socket.Address.Unix.t t [@@deriving sexp_of] val remote_address : 'a t -> 'a Deferred.t (** [bind_to_address] and [bind_to_port] can be used to bind the source IP and port of the underlying socket. This does not necessarily alter the interface used to send the data. In particular, the commonly used destination-based routing is unaffected by binding to a different address. *) val of_host_and_port : ?bind_to_address:Unix.Inet_addr.t (** default is chosen by OS *) -> ?bind_to_port:int (** default is chosen by OS *) -> Host_and_port.t -> inet val of_inet_address : ?bind_to_address:Unix.Inet_addr.t (** default is chosen by OS *) -> ?bind_to_port:int (** default is chosen by OS *) -> Socket.Address.Inet.t -> inet val of_file : string -> unix val of_unix_address : Socket.Address.Unix.t -> unix end type 'a with_connect_options = ?buffer_age_limit:[ `At_most of Time.Span.t | `Unlimited ] -> ?interrupt:unit Deferred.t -> ?reader_buffer_size:int -> ?writer_buffer_size:int -> ?timeout:Time.Span.t -> ?time_source:Time_source.t (** default is [Time_source.wall_clock ()] *) -> 'a (** [with_connection where_to_connect f] looks up [where_to_connect] (using DNS as needed), connects, then calls [f], passing the connected socket and a reader and writer for it. When the deferred returned by [f] is determined, or any exception is thrown, the socket, reader and writer are closed. The returned [Deferred.t] is fulfilled after [f] has finished processing and the file descriptor for the socket is closed. If [interrupt] is supplied, the connection attempt will be aborted if [interrupt] is fulfilled before the connection has been established. Similarly, all connection attempts have a timeout (default 10s), which can be overridden with [timeout]. It is fine for [f] to ignore the supplied socket and just use the reader and writer. The socket is there to make it convenient to call [Socket] functions. *) val with_connection : ('addr Where_to_connect.t -> (([ `Active ], 'addr) Socket.t -> Reader.t -> Writer.t -> 'a Deferred.t) -> 'a Deferred.t) with_connect_options (** [connect_sock where_to_connect] creates a socket and opens a TCP connection. To use an existing socket, supply [~socket]. Any errors in the connection will be reported to the monitor that was current when [connect_sock] was called. *) val connect_sock : ?socket:([ `Unconnected ], 'addr) Socket.t -> ?interrupt:unit Deferred.t -> ?timeout:Time.Span.t -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> 'addr Where_to_connect.t -> ([ `Active ], 'addr) Socket.t Deferred.t (** [connect where_to_connect] is a convenience wrapper around [connect_sock] that returns the socket, and a reader and writer for the socket. The reader and writer share a file descriptor, and so closing one will affect the other by closing its underlying [fd]. In particular, closing the reader before closing the writer will cause the writer to subsequently raise an exception when it attempts to flush internally-buffered bytes to the OS, due to a closed [fd]. You should close the [Writer] first to avoid this problem. If possible, use [with_connection], which automatically handles closing. It is fine to ignore the returned socket and just use the reader and writer. The socket is there to make it convenient to call [Socket] functions. *) val connect : ?socket:([ `Unconnected ], 'addr) Socket.t -> ('addr Where_to_connect.t -> (([ `Active ], 'addr) Socket.t * Reader.t * Writer.t) Deferred.t) with_connect_options module Bind_to_address : sig type t = | Address of Unix.Inet_addr.t | All_addresses | Localhost (** equivalent to [Address Unix.Inet_addr.localhost] *) [@@deriving sexp_of] end module Bind_to_port : sig type t = | On_port of int | On_port_chosen_by_os [@@deriving sexp_of] end (** A [Where_to_listen] describes the socket that a tcp server should listen on. *) module Where_to_listen : sig type ('address, 'listening_on) t constraint 'address = [< Socket.Address.t ] [@@deriving sexp_of] type inet = (Socket.Address.Inet.t, int) t [@@deriving sexp_of] type unix = (Socket.Address.Unix.t, string) t [@@deriving sexp_of] val create : socket_type:'address Socket.Type.t -> address:'address -> listening_on:('address -> 'listening_on) -> ('address, 'listening_on) t val address : ('address, _) t -> 'address (** Listen on the specified port on the specified addresses. *) val bind_to : Bind_to_address.t -> Bind_to_port.t -> inet (** [of_port port] is [bind_to All_addresses (On_port port)]. *) val of_port : int -> inet (** [of_port_chosen_by_os port] is [bind_to All_addresses On_port_chosen_by_os]. *) val of_port_chosen_by_os : inet (** Listen on a unix domain socket using the specified path. *) val of_file : string -> unix end (** A [Server.t] represents a TCP server listening on a socket. *) module Server : sig type ('address, 'listening_on) t constraint 'address = [< Socket.Address.t ] [@@deriving sexp_of] type inet = (Socket.Address.Inet.t, int) t [@@deriving sexp_of] type unix = (Socket.Address.Unix.t, string) t [@@deriving sexp_of] val invariant : (_, _) t -> unit val listening_on : (_, 'listening_on) t -> 'listening_on val listening_on_address : ('address, _) t -> 'address (** [close t] starts closing the listening socket, and returns a deferred that becomes determined after [Fd.close_finished fd] on the socket's [fd]. It is guaranteed that [t]'s client handler will never be called after [close t]. It is ok to call [close] multiple times on the same [t]; calls subsequent to the initial call will have no effect, but will return the same deferred as the original call. With [~close_existing_connections:true], [close] closes the sockets of all existing connections. [close] does not (and cannot) stop the handlers handling the connections, but they will of course be unable to write to or read from the socket. The result of [close] becomes determined when all the socket file descriptors are closed and the socket's [fd] is closed. *) val close : ?close_existing_connections:bool (** default is [false] *) -> (_, _) t -> unit Deferred.t (** [close_finished] becomes determined after [Fd.close_finished fd] on the socket's [fd], i.e., the same deferred that [close] returns. [close_finished] differs from [close] in that it does not have the side effect of initiating a close. *) val close_finished : (_, _) t -> unit Deferred.t (** [is_closed t] returns [true] iff [close t] has been called. *) val is_closed : (_, _) t -> bool (** [close_finished_and_handlers_determined t] becomes determined after [close_finished t] is determined and the return of all active handlers is determined. *) val close_finished_and_handlers_determined : (_, _) t -> unit Deferred.t (** Options for server creation: [backlog] is the number of clients that can have a connection pending, as with {!Unix.listen}. Additional connections may be rejected, ignored, or enqueued anyway, depending on OS, version, and configuration. [max_connections] is the maximum number of clients that can be connected simultaneously. The server will not call [accept] unless the number of clients is less than [max_connections], although of course potential clients can have a connection pending. [max_accepts_per_batch] is the maximum number of connections that the server will retrieve per blocking {!Unix.accept} call. Servers that must handle a large number of connections tend to observe a stall in connection accept rates when under heavy load. Increasing [max_accepts_per_batch] will ameliorate this effect, increasing connection accept rates and overall throughput at the cost of increased contention for resources amongst connections. Servers that are under light load or ones that only service a small number of connections at a time should see little to no difference in behavior for different values of [max_accepts_per_branch]. [drop_incoming_connections] determines whether connections will be immediately dropped when the server is created. It can be modified later with [set_drop_incoming_connections]; see that function for a more detailed description. Supplying [socket] causes the server to use [socket] rather than create a new socket. In this usage, creation does not set [Socket.Opt.reuseaddr] to [true]; if you want that, you must set [reuseaddr] before creation. [on_handler_error] determines what happens if the handler throws an exception. If an exception is raised by on_handler_error (either explicitly via [`Raise], or in the closure passed to [`Call]) no further connections will be accepted. *) (** [create_sock where_to_listen handler] starts a server listening to a socket as specified by [where_to_listen]. It returns a server once the socket is ready to accept connections. The server calls [handler address socket] for each client that connects. If the deferred returned by [handler] is ever determined, or [handler] raises an exception, then [socket] is closed. The server will stop accepting and close the listening socket when an error handler raises (either via [`Raise] or [`Call f] where [f] raises), or if [close] is called. *) val create_sock : ?max_connections:int (** defaults to [10_000]. *) -> ?max_accepts_per_batch:int (** defaults to [1]. *) -> ?backlog:int (** defaults to [64] *) -> ?drop_incoming_connections:bool (** defaults to [false] *) -> ?socket:([ `Unconnected ], ([< Socket.Address.t ] as 'address)) Socket.t -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] -> ('address, 'listening_on) Where_to_listen.t -> ('address -> ([ `Active ], 'address) Socket.t -> unit Deferred.t) -> ('address, 'listening_on) t Deferred.t (** as [create_sock], but only supports inet sockets, not unix sockets, and returns the server immediately rather than asynchronously. *) val create_sock_inet : ?max_connections:int -> ?max_accepts_per_batch:int -> ?backlog:int -> ?drop_incoming_connections:bool (** defaults to [false] *) -> ?socket:([ `Unconnected ], Socket.Address.Inet.t) Socket.t -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> on_handler_error: [ `Call of Socket.Address.Inet.t -> exn -> unit | `Ignore | `Raise ] -> Where_to_listen.inet -> (Socket.Address.Inet.t -> ([ `Active ], Socket.Address.Inet.t) Socket.t -> unit Deferred.t) -> (Socket.Address.Inet.t, int) t (** [create where_to_listen handler] is a convenience wrapper around [create_sock] that pass a reader and writer for the client socket to the callback. If the deferred returned by [handler] is ever determined, or [handler] raises an exception, then the reader and writer are closed. [buffer_age_limit] passes on to the underlying writer option of the same name. *) val create : ?buffer_age_limit:Writer.buffer_age_limit -> ?max_connections:int (** defaults to [10_000]. *) -> ?max_accepts_per_batch:int (** defaults to [1]. *) -> ?backlog:int (** defaults to [64]. *) -> ?drop_incoming_connections:bool (** defaults to [false] *) -> ?socket:([ `Unconnected ], ([< Socket.Address.t ] as 'address)) Socket.t -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> on_handler_error:[ `Call of 'address -> exn -> unit | `Ignore | `Raise ] -> ('address, 'listening_on) Where_to_listen.t -> ('address -> Reader.t -> Writer.t -> unit Deferred.t) -> ('address, 'listening_on) t Deferred.t val create_inet : ?buffer_age_limit:Writer.buffer_age_limit -> ?max_connections:int (** defaults to [10_000]. *) -> ?max_accepts_per_batch:int (** defaults to [1]. *) -> ?backlog:int (** defaults to [64]. *) -> ?drop_incoming_connections:bool (** defaults to [false] *) -> ?socket:([ `Unconnected ], Socket.Address.Inet.t) Socket.t -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> on_handler_error: [ `Call of Socket.Address.Inet.t -> exn -> unit | `Ignore | `Raise ] -> Where_to_listen.inet -> (Socket.Address.Inet.t -> Reader.t -> Writer.t -> unit Deferred.t) -> (Socket.Address.Inet.t, int) t (** [listening_socket t] accesses the listening socket, which should be used with care. An anticipated use is with {!Async_udp.bind_to_interface_exn}. Accepting connections on the socket directly will circumvent [max_connections] and [on_handler_error], however, and is not recommended. *) val listening_socket : ('address, _) t -> ([ `Passive ], 'address) Socket.t val num_connections : (_, _) t -> int (** [set_drop_incoming_connections] configures whether each incoming connection will be immediately dropped or not. This is a hack to effectively get a "pause listening" feature. We can't reliably use [backlog] and [max_num_connections] to reject incoming connections. For example, if we reach [max_num_connections], we won't call [accept] but OS might still establish TCP connection. The client will see the connection as established but no data will be exchanged and we'd have to rely on TCP retransmit timeouts to close the connection. In many cases we would prefer to accept and then immediately close the connection. This is an intermediate solution until we do a more principled solution (but much more complicated) when we close the listening socket and then later [bind] and [listen] again when we decide to unpause the server. [drop_incoming_connections] is set to false. *) val set_drop_incoming_connections : (_, _) t -> bool -> unit (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val fd : _ t -> Fd.t end end (**/**) (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val close_connection_via_reader_and_writer : Reader.t -> Writer.t -> unit Deferred.t end async_unix-0.15.0/src/thread_safe.ml000066400000000000000000000177421420273305200173540ustar00rootroot00000000000000open Core open Import open Raw_scheduler let debug = Debug.thread_safe let run_holding_async_lock (type a b) ?(wakeup_scheduler = true) t (f : unit -> a) ~(finish : (a, exn) Result.t -> b) : b = if debug then Debug.log "run_holding_async_lock" t [%sexp_of: t]; if not (am_holding_lock t) then lock t; protect ~finally:(fun () -> if wakeup_scheduler then thread_safe_wakeup_scheduler t; unlock t) ~f:(fun () -> (* We run [f] within the [main_execution_context] so that any errors are sent to its monitor, rather than whatever random monitor happened to be in effect. *) finish (with_execution_context t Kernel_scheduler.main_execution_context ~f:(fun () -> Result.try_with f))) ;; let ensure_in_a_thread t function_ = if is_main_thread () then raise_s [%message "cannot call from the main thread" (function_ : string)]; if am_holding_lock t then raise_s [%message "cannot call while holding the async lock" (function_ : string)] ;; let run_in_async_with_optional_cycle ?wakeup_scheduler t f = if debug then Debug.log "run_in_async_with_optional_cycle" t [%sexp_of: t]; ensure_in_a_thread t "run_in_async_with_optional_cycle"; run_holding_async_lock ?wakeup_scheduler t f ~finish:(function | Error exn -> Error exn | Ok (maybe_run_a_cycle, a) -> (match maybe_run_a_cycle with | `Do_not_run_a_cycle -> () | `Run_a_cycle -> have_lock_do_cycle t); Ok a) ;; let block_on_async t f = if debug then Debug.log "block_on_async" t [%sexp_of: t]; (* We disallow calling [block_on_async] if the caller is running inside async. This can happen if one is the scheduler, or if one is in some other thread that has used, e.g. [run_in_async] to call into async and run a cycle. We do however, want to allow the main thread to call [block_on_async], in which case it should release the lock and allow the scheduler, which is running in another thread, to run. *) if i_am_the_scheduler t || (am_holding_lock t && not (is_main_thread ())) then raise_s [%message "called [block_on_async] from within async"]; (* While [block_on_async] is blocked, the Async scheduler may run and set the execution context. So we save and restore the execution context, if we're in the main thread. The restoration is necessary because subsequent code in the main thread can do operations that rely on the execution context. *) let execution_context = Kernel_scheduler.current_execution_context t.kernel_scheduler in (* Create a scheduler thread if the scheduler isn't already running. *) if not t.is_running then ( t.is_running <- true; (* Release the Async lock if necessary, so that the scheduler can acquire it. *) if am_holding_lock t then unlock t; let scheduler_ran_a_job = Thread_safe_ivar.create () in upon (return ()) (fun () -> Thread_safe_ivar.fill scheduler_ran_a_job ()); ignore (Core_thread.create ~on_uncaught_exn:`Print_to_stderr (fun () -> Exn.handle_uncaught ~exit:true (fun () -> let () = match Linux_ext.pr_set_name_first16 with | Ok f -> f "async-scheduler" | Error _ -> () in lock t; never_returns (be_the_scheduler t))) () : Core_thread.t); (* Block until the scheduler has run the above job. *) Thread_safe_ivar.read scheduler_ran_a_job); let maybe_blocked = run_holding_async_lock t (fun () -> Monitor.try_with ~run: `Schedule ~rest:`Log f ~name:"block_on_async") ~finish:(fun res -> match res with | Error exn -> `Available (Error exn) | Ok d -> (match Deferred.peek d with | Some v -> `Available v | None -> have_lock_do_cycle t; (match Deferred.peek d with | Some v -> `Available v | None -> let q = Squeue.create 1 in upon d (fun v -> Squeue.push_uncond q v); (* Squeue.pop can block, so we have to do it outside async *) `Blocked_wait_on_squeue q))) in let res = match maybe_blocked with | `Available v -> v | `Blocked_wait_on_squeue q -> (* [run_holding_async_lock] released the lock. If the scheduler wasn't already running when [block_on_async] was called, then we started it above. So, the scheduler is running, and will eventually run the job to put something on the squeue. So, it's OK to block waiting for it. *) Squeue.pop q in (* If we're the main thread, we should lock the scheduler for the rest of main, to prevent the scheduler, which is now running in another thread, from interfering with the main thread. We also restore the execution context, so that the code in the main thread will be in the same execution context as before it called [block_on_async]. The restored execution context will usually be [Execution_context.main], but need not be, if the user has done operations that adjust the current execution context, e.g. [Monitor.within]. If we're not in the main thread, the we don't need to and cannot restore the execution context, because we do not hold the Async lock. *) if is_main_thread () then ( lock t; (* While [block_on_async] is blocked, Async can run and set the execution context. So we restore the execution context, if we're in the main thread. The restoration is necessary because subsequent code in the main thread can do operations that rely on the execution context. *) Kernel_scheduler.set_execution_context t.kernel_scheduler execution_context); res ;; let block_on_async_exn t f = Result.ok_exn (block_on_async t f) let reset_scheduler t = if debug then Debug.log "reset_scheduler" t [%sexp_of: t]; if i_am_the_scheduler t || (am_holding_lock t && not (is_main_thread ())) then raise_s [%message "called [reset_scheduler] from within async"]; if am_holding_lock t then unlock t; Raw_scheduler.thread_safe_reset () ;; let run_in_async ?wakeup_scheduler t f = if debug then Debug.log "run_in_async" t [%sexp_of: t]; ensure_in_a_thread t "run_in_async"; run_holding_async_lock ?wakeup_scheduler t f ~finish:Fn.id ;; let run_in_async_exn ?wakeup_scheduler t f = Result.ok_exn (run_in_async ?wakeup_scheduler t f) ;; let run_in_async_wait t f = if debug then Debug.log "run_in_async_wait" t [%sexp_of: t]; ensure_in_a_thread t "run_in_async_wait"; block_on_async t f ;; let run_in_async_wait_exn t f = Result.ok_exn (run_in_async_wait t f) let deferred t = let ivar = if am_holding_lock t then Ivar.create () else run_holding_async_lock t Ivar.create ~finish:Result.ok_exn in let fill x = run_in_async_exn t (fun () -> Ivar.fill ivar x) in Ivar.read ivar, fill ;; let t () = the_one_and_only () let am_holding_async_lock () = am_holding_lock (t ()) let deferred () = deferred (t ()) let run_in_async_with_optional_cycle ?wakeup_scheduler f = run_in_async_with_optional_cycle ?wakeup_scheduler (t ()) f ;; let run_in_async ?wakeup_scheduler f = run_in_async ?wakeup_scheduler (t ()) f let run_in_async_exn ?wakeup_scheduler f = run_in_async_exn ?wakeup_scheduler (t ()) f let block_on_async f = block_on_async (t ()) f let block_on_async_exn f = block_on_async_exn (t ()) f let run_in_async_wait f = run_in_async_wait (t ()) f let run_in_async_wait_exn f = run_in_async_wait_exn (t ()) f let reset_scheduler () = reset_scheduler (t ()) let ok_to_drop_lock t = is_main_thread () && not (Kernel_scheduler.in_cycle t.kernel_scheduler) ;; let without_async_lock f = let t = t () in if i_am_the_scheduler t || (am_holding_lock t && not (ok_to_drop_lock t)) then raise_s [%message "called [become_helper_thread_and_block_on_async] from within async"] else if am_holding_lock t then ( unlock t; protect ~f ~finally:(fun () -> lock t)) else f () ;; async_unix-0.15.0/src/thread_safe.mli000066400000000000000000000101551420273305200175140ustar00rootroot00000000000000(** The [Thread_safe] module has functions that are safe to call from threads outside Async, such as the ones spawned by [In_thread.run]. This is in contrast with the rest of [Async] library which is generally not thread-safe. All the [Thread_safe.block*] and [Thread_safe.run*] functions wake up the Async scheduler to ensure that it continues in a timely manner with whatever jobs got started. Some functions take an optional [?wakeup_scheduler:bool] argument, which defaults to [true]. One can cause the scheduler to not be woken up by supplying [~wakeup_scheduler:false], which can reduce CPU use, but increase latency, because the scheduler may not wake up for a while to process jobs. *) open! Core open Async_kernel (** [am_holding_async_lock ()] returns true if the currently running thread is holding the Async lock. *) val am_holding_async_lock : unit -> bool (** [deferred ()] returns [(d, fill)] where [d] is a deferred that will become determined with value [v] once [fill v] is called. It is ok to call [deferred] from inside or outside Async. [fill] must be called from outside Async. *) val deferred : unit -> 'a Deferred.t * ('a -> unit) (** [run_in_async_with_optional_cycle f] acquires the Async lock and runs [f ()] while holding the lock. Depending on the result of [f], it may also run a cycle. *) val run_in_async_with_optional_cycle : ?wakeup_scheduler:bool (** default is [true] *) -> (unit -> [ `Run_a_cycle | `Do_not_run_a_cycle ] * 'a) -> ('a, exn) Result.t (** [run_in_async f] acquires the Async lock and runs [f ()] while holding the lock. It returns the result of [f ()] to the outside world. The scheduler is woken up to ensure the code that depends on [f ()] is run soon enough. [run_in_async] doesn't run a cycle. [run_in_async] does not automatically start the Async scheduler. You still need to call [Scheduler.go] elsewhere in your program. *) val run_in_async : ?wakeup_scheduler:bool (** default is [true] *) -> (unit -> 'a) -> ('a, exn) Result.t val run_in_async_exn : ?wakeup_scheduler:bool (** default is [true] *) -> (unit -> 'a) -> 'a (** [block_on_async f] runs [f ()] in the Async world and blocks until the result becomes determined. This function can be called from the main thread (before Async is started) or from a thread outside Async. [block_on_async] will run a cycle if the deferred isn't determined, in the hope that running the cycle will cause the deferred to become determined. [block_on_async] will automatically start the scheduler if it isn't already running. *) val block_on_async : (unit -> 'a Deferred.t) -> ('a, exn) Result.t val block_on_async_exn : (unit -> 'a Deferred.t) -> 'a (** [run_in_async_wait f] is like [block_on_async f], except that it must be called from a thread outside Async. Upon returning from [run_in_async_wait], it is guaranteed that the caller does not have the Async lock. *) val run_in_async_wait : (unit -> 'a Deferred.t) -> ('a, exn) Result.t val run_in_async_wait_exn : (unit -> 'a Deferred.t) -> 'a (** [reset_scheduler] stops the scheduler thread and any associated threads, and resets Async's global state to its initial state. This is useful if you need to first use Async to compute a value and then to daemonize (in which case you should [daemonize] with [~allow_threads_to_have_been_created:true]). [reset_scheduler] can be called from the main thread (before Async is started) or from a thread outside Async. [reset_scheduler] is known to be imperfect, and to have races in which there are still threads running after it returns. *) val reset_scheduler : unit -> unit (** [without_async_lock f] can not be called from async, usually because [f] is expected to block. It's safe to call it in these two circumstances: - from a separate thread that's not holding the async lock - from the main thread, even if it is holding the async lock, as long as it's not running async jobs. In the latter case the async lock is dropped for the duration of [f]. *) val without_async_lock : (unit -> 'a) -> 'a async_unix-0.15.0/src/time_source_tests.ml000066400000000000000000000022171420273305200206360ustar00rootroot00000000000000open! Core open! Import module Time_source = Async_kernel.Time_source let run_cycles_until_no_jobs_remain = Kernel_scheduler.run_cycles_until_no_jobs_remain let%bench_module "Clock.every" = (module struct let scheduler = Kernel_scheduler.t () let time_source = scheduler.time_source |> Time_source.of_synchronous let%bench "~continue-on-error:false" = let iv = Ivar.create () in let n = ref 0 in Time_source.run_repeatedly time_source ~stop:(Ivar.read iv) ~continue_on_error:false ~f:(fun () -> if !n >= 1_000 then Ivar.fill iv () else incr n; return ()) ~continue:Time_source.Continue.immediately; run_cycles_until_no_jobs_remain () ;; let%bench "~continue_on_error:true" = let iv = Ivar.create () in let n = ref 0 in Time_source.run_repeatedly time_source ~stop:(Ivar.read iv) ~continue_on_error:true ~f:(fun () -> if !n >= 1_000 then Ivar.fill iv () else incr n; return ()) ~continue:Time_source.Continue.immediately; run_cycles_until_no_jobs_remain () ;; end) ;; async_unix-0.15.0/src/time_source_tests.mli000066400000000000000000000000551420273305200210050ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) async_unix-0.15.0/src/unix_syscalls.ml000066400000000000000000001121751420273305200200030ustar00rootroot00000000000000module Async_signal = Signal open Core open Import module File_descr = Unix.File_descr module Exit = Unix.Exit module Exit_or_signal = Unix.Exit_or_signal module Exit_or_signal_or_stop = Unix.Exit_or_signal_or_stop module Syscall_result = Unix.Syscall_result module Error = Unix.Error exception Unix_error = Unix.Unix_error include Fd.Close module Open_flags = Unix.Open_flags let system s = In_thread.syscall_exn ~name:"system" (fun () -> Unix.system s) let system_exn s = let%map status = system s in if not (Result.is_ok status) then raise_s [%message "shell command failed" ~_:(s : string) (status : Exit_or_signal.t)] ;; let getpid () = Unix.getpid () let getppid () = Unix.getppid () let getppid_exn () = Unix.getppid_exn () let this_process_became_child_of_init ?(poll_delay = sec 1.) () = Deferred.create (fun i -> Clock.every poll_delay ~stop:(Ivar.read i) (fun () -> if Pid.equal (getppid_exn ()) Pid.init then Ivar.fill i ())) ;; let nice i = Unix.nice i let cores = Or_error.map Linux_ext.cores ~f:(fun cores () -> In_thread.syscall_exn ~name:"cores" cores) ;; (* basic input/output *) let convert_open_flag : _ -> Unix.open_flag = function | `Rdonly -> O_RDONLY | `Wronly -> O_WRONLY | `Rdwr -> O_RDWR | `Nonblock -> O_NONBLOCK | `Append -> O_APPEND | `Creat -> O_CREAT | `Trunc -> O_TRUNC | `Excl -> O_EXCL | `Noctty -> O_NOCTTY | `Dsync -> O_DSYNC | `Sync -> O_SYNC | `Rsync -> O_RSYNC ;; type open_flag = [ `Rdonly | `Wronly | `Rdwr | `Nonblock | `Append | `Creat | `Trunc | `Excl | `Noctty | `Dsync | `Sync | `Rsync ] type file_perm = int [@@deriving sexp, bin_io, compare] let openfile ?info ?perm file ~mode = let mode = List.map mode ~f:convert_open_flag @ [ O_CLOEXEC ] in let%bind file_descr = In_thread.syscall_exn ~name:"openfile" (fun () -> Unix.openfile ?perm file ~mode) in let%map kind = Fd.Kind.infer_using_stat file_descr in Fd.create kind file_descr (Option.value info ~default:(Info.of_string file)) ;; let fcntl_getfl fd = Fd.syscall_in_thread_exn fd ~name:"fcntl_getfl" (fun file_descr -> Unix.fcntl_getfl file_descr) ;; let fcntl_setfl fd flags = Fd.syscall_in_thread_exn fd ~name:"fcntl_setfl" (fun file_descr -> Unix.fcntl_setfl file_descr flags) ;; let lseek fd pos ~mode = let mode : Unix.seek_command = match mode with | `Set -> SEEK_SET | `Cur -> SEEK_CUR | `End -> SEEK_END in Fd.syscall_in_thread_exn fd ~name:"lseek" (fun file_descr -> Unix.lseek file_descr pos ~mode) ;; let truncate filename ~len = In_thread.syscall_exn ~name:"truncate" (fun () -> Unix.truncate filename ~len) ;; let ftruncate fd ~len = Fd.syscall_in_thread_exn fd ~name:"ftruncate" (fun file_descr -> Unix.ftruncate file_descr ~len) ;; let fsync fd = Fd.syscall_in_thread_exn fd ~name:"fsync" Unix.fsync let fdatasync fd = Fd.syscall_in_thread_exn fd ~name:"fdatasync" Unix.fdatasync let sync () = In_thread.syscall_exn ~name:"sync" Unix.sync module Lock_mode = struct type t = | Shared | Exclusive [@@deriving sexp_of] let flock_command : t -> _ = function | Shared -> Unix.Flock_command.lock_shared | Exclusive -> Unix.Flock_command.lock_exclusive ;; end let lockf ?(len = 0L) fd (lock_mode : Lock_mode.t) = let mode : Unix.lock_command = match lock_mode with | Shared -> F_RLOCK | Exclusive -> F_LOCK in Fd.syscall_in_thread_exn fd ~name:"lockf" (fun file_descr -> Unix.lockf file_descr ~mode ~len) ;; let try_lockf ?(len = 0L) fd (lock_mode : Lock_mode.t) = let mode : Unix.lock_command = match lock_mode with | Shared -> F_TRLOCK | Exclusive -> F_TLOCK in Fd.syscall_exn fd (fun file_descr -> try Unix.lockf file_descr ~mode ~len; true with | Unix_error ((EACCES | EAGAIN), _, _) -> false) ;; let test_lockf ?(len = 0L) fd = Fd.syscall_exn fd (fun file_descr -> try Unix.lockf file_descr ~mode:F_TEST ~len; true with | Unix_error ((EACCES | EAGAIN), _, _) -> false) ;; let unlockf ?(len = 0L) fd = Fd.syscall_exn fd (fun file_descr -> Unix.lockf file_descr ~mode:F_ULOCK ~len) ;; let flock fd lock_mode = let mode = Lock_mode.flock_command lock_mode in Fd.syscall_in_thread_exn fd ~name:"flock" (fun file_descr -> Unix.flock_blocking file_descr mode) ;; let try_flock fd lock_mode = let mode = Lock_mode.flock_command lock_mode in Fd.syscall_exn fd (fun file_descr -> Unix.flock file_descr mode) ;; let funlock fd = Fd.syscall_exn fd (fun file_descr -> ignore (Unix.flock file_descr Unix.Flock_command.unlock : bool)) ;; module Lock_mechanism = struct module T = struct type t = | Lockf | Flock [@@deriving compare, enumerate, sexp, variants] end let lock (t : T.t) = match t with | Lockf -> lockf ?len:None | Flock -> flock ;; include T include Sexpable.To_stringable (T) let arg_type = Command.Param.Arg_type.Export.sexp_conv T.t_of_sexp end module Lock = struct type t = { mode : Lock_mode.t ; mechanism : Lock_mechanism.t } [@@deriving sexp_of] end let with_file ?lock ?perm file ~mode ~f = (* Here we rely on closing the fd to release the lock if appropriate. In the case of flock, this will release the lock only if no other fds are pointing to the same file description in the kernel. This will only happen if [f] dups or otherwise copies the fd. The question of what happens when this function is called with a file such as [/dev/fd*] is left as an exercise to the caller. *) let doit f = let%bind fd = openfile file ~mode ?perm in Fd.with_close fd ~f in match lock with | None -> doit f | Some { Lock.mode; mechanism } -> doit (fun fd -> let%bind () = Lock_mechanism.lock mechanism fd mode in f fd) ;; (* file status *) module File_kind = struct module T = struct type t = [ `File | `Directory | `Char | `Block | `Link | `Fifo | `Socket ] [@@deriving compare, sexp, bin_io] end include T include Comparable.Make (T) let of_unix : Unix.file_kind -> _ = function | S_REG -> `File | S_DIR -> `Directory | S_CHR -> `Char | S_BLK -> `Block | S_LNK -> `Link | S_FIFO -> `Fifo | S_SOCK -> `Socket ;; end module Stats = struct type t = { dev : int ; ino : int ; kind : File_kind.t ; perm : file_perm ; nlink : int ; uid : int ; gid : int ; rdev : int ; size : int64 ; atime : Time.t ; mtime : Time.t ; ctime : Time.t } [@@deriving fields, sexp, bin_io, compare] let of_unix (u : Unix.stats) = let of_float_sec f = Time.of_span_since_epoch (Time.Span.of_sec f) in { dev = u.st_dev ; ino = u.st_ino ; kind = File_kind.of_unix u.st_kind ; perm = u.st_perm ; nlink = u.st_nlink ; uid = u.st_uid ; gid = u.st_gid ; rdev = u.st_rdev ; size = u.st_size ; atime = of_float_sec u.st_atime ; mtime = of_float_sec u.st_mtime ; ctime = of_float_sec u.st_ctime } ;; let to_string t = Sexp.to_string (sexp_of_t t) end let fstat fd = Fd.syscall_in_thread_exn fd ~name:"fstat" Unix.fstat >>| Stats.of_unix let stat filename = In_thread.syscall_exn ~name:"stat" (fun () -> Unix.stat filename) >>| Stats.of_unix ;; let lstat filename = In_thread.syscall_exn ~name:"lstat" (fun () -> Unix.lstat filename) >>| Stats.of_unix ;; (* We treat [isatty] as a blocking operation, because it acts on a file. *) let isatty fd = Fd.syscall_in_thread_exn fd ~name:"isatty" Unix.isatty (* operations on filenames *) let unlink filename = In_thread.syscall_exn ~name:"unlink" (fun () -> Unix.unlink filename) ;; let remove filename = In_thread.syscall_exn ~name:"remove" (fun () -> Unix.remove filename) ;; let rename ~src ~dst = In_thread.syscall_exn ~name:"rename" (fun () -> Unix.rename ~src ~dst) ;; let link ?force ~target ~link_name () = In_thread.syscall_exn ~name:"link" (fun () -> Unix.link ?force ~target ~link_name ()) ;; (* file permission and ownership *) let chmod filename ~perm = In_thread.syscall_exn ~name:"chmod" (fun () -> Unix.chmod filename ~perm) ;; let fchmod fd ~perm = Fd.syscall_in_thread_exn fd ~name:"fchmod" (fun file_descr -> Unix.fchmod file_descr ~perm) ;; let chown filename ~uid ~gid = In_thread.syscall_exn ~name:"chown" (fun () -> Unix.chown filename ~uid ~gid) ;; let fchown fd ~uid ~gid = Fd.syscall_in_thread_exn fd ~name:"fchown" (fun file_descr -> Unix.fchown file_descr ~uid ~gid) ;; let access filename perm = match%map Monitor.try_with ~run: `Schedule ~rest:`Log (fun () -> In_thread.syscall_exn ~name:"access" (fun () -> Unix.access filename perm)) with | Ok res -> res | Error exn -> Error (Monitor.extract_exn exn) ;; let access_exn filename perm = In_thread.syscall_exn ~name:"access" (fun () -> Unix.access_exn filename perm) ;; (* operations on file descriptors *) let set_close_on_exec fd = Fd.with_file_descr_exn fd Unix.set_close_on_exec let clear_close_on_exec fd = Fd.with_file_descr_exn fd Unix.clear_close_on_exec let mkdir ?p ?(perm = 0o777) dirname = match p with | None -> In_thread.syscall_exn ~name:"mkdir" (fun () -> Unix.mkdir dirname ~perm) | Some () -> In_thread.syscall_exn ~name:"mkdir" (fun () -> Unix.mkdir_p dirname ~perm) ;; let rmdir dirname = In_thread.syscall_exn ~name:"rmdir" (fun () -> Unix.rmdir dirname) let chdir dirname = In_thread.syscall_exn ~name:"chdir" (fun () -> Unix.chdir dirname) let chroot dirname = In_thread.syscall_exn ~name:"chroot" (fun () -> Unix.chroot dirname) let getcwd () = In_thread.syscall_exn ~name:"getcwd" (fun () -> Unix.getcwd ()) type dir_handle = Unix.dir_handle let opendir dirname = In_thread.syscall_exn ~name:"opendir" (fun () -> Unix.opendir dirname) ;; let readdir_opt handle = In_thread.syscall_exn ~name:"readdir" (fun () -> Unix.readdir_opt handle) ;; let rewinddir handle = In_thread.syscall_exn ~name:"rewinddir" (fun () -> Unix.rewinddir handle) ;; let closedir handle = In_thread.syscall_exn ~name:"closedir" (fun () -> Unix.closedir handle) ;; let pipe info = let%map reader, writer = In_thread.syscall_exn ~name:"pipe" (fun () -> Unix.pipe ~close_on_exec:true ()) in let create file_descr kind = Fd.create Fifo file_descr (Info.tag info ~tag:kind) in `Reader (create reader "reader"), `Writer (create writer "writer") ;; let mkfifo ?(perm = 0o666) name = In_thread.syscall_exn ~name:"mkfifo" (fun () -> Unix.mkfifo name ~perm) ;; (* symlinks *) let symlink ~target ~link_name = In_thread.syscall_exn ~name:"symlink" (fun () -> Unix.symlink ~target ~link_name) ;; let readlink filename = In_thread.syscall_exn ~name:"readlink" (fun () -> Unix.readlink filename) ;; let mkdtemp filename = In_thread.syscall_exn ~name:"mkdtemp" (fun () -> Unix.mkdtemp filename) ;; let mkstemp filename = let%map name, file_descr = In_thread.syscall_exn ~name:"mkstemp" (fun () -> Unix.mkstemp filename) in name, Fd.create File file_descr (Info.of_string name) ;; let getgrouplist username gid = In_thread.syscall_exn ~name:"getgrouplist" (fun () -> Unix.getgrouplist username gid) ;; type process_times = Unix.process_times = { tms_utime : float ; tms_stime : float ; tms_cutime : float ; tms_cstime : float } let times = Unix.times type tm = Unix.tm = { tm_sec : int ; tm_min : int ; tm_hour : int ; tm_mday : int ; tm_mon : int ; tm_year : int ; tm_wday : int ; tm_yday : int ; tm_isdst : bool } let time = Unix.time let gettimeofday = Unix.gettimeofday let gmtime = Unix.gmtime let localtime = Unix.localtime let mktime = Unix.mktime let utimes name ~access ~modif = In_thread.syscall_exn ~name:"utimes" (fun () -> Unix.utimes name ~access ~modif) ;; (* environment *) type env = Unix.env [@@deriving sexp] let environment = Unix.environment let getenv = Sys.getenv let getenv_exn = Sys.getenv_exn let unsafe_getenv = Sys_unix.unsafe_getenv let unsafe_getenv_exn = Sys_unix.unsafe_getenv_exn let putenv = Unix.putenv let unsetenv = Unix.unsetenv (* processes *) let fork_exec ~prog ~argv ?use_path ?env () = In_thread.run (fun () -> Unix.fork_exec ~prog ~argv ?use_path ?env ()) ;; type wait_on = Unix.wait_on [@@deriving sexp_poly] let wait_nohang = Unix.wait_nohang let wait_nohang_untraced = Unix.wait_nohang_untraced module Wait : sig val check_all : unit -> unit val do_not_handle_sigchld : unit -> unit val waitpid : Pid.t -> Exit_or_signal.t Deferred.t val wait : wait_on -> (Pid.t * Exit_or_signal.t) Deferred.t val wait_untraced : wait_on -> (Pid.t * Exit_or_signal_or_stop.t) Deferred.t end = struct module Kind = struct type (_, _) t = | Normal : (wait_on, Pid.t * Exit_or_signal.t) t | Untraced : (wait_on, Pid.t * Exit_or_signal_or_stop.t) t | Waitpid : (Pid.t, Exit_or_signal.t) t [@@deriving sexp_of] let waitpid_nohang pid = let res = wait_nohang (`Pid pid) in match res with | None -> None | Some (pid2, exit_or_signal) -> assert (Pid.( = ) pid2 pid); Some exit_or_signal ;; let wait_nohang : type q r. (q, r) t -> q -> r option = fun t wait_on -> match t with | Normal -> wait_nohang wait_on | Untraced -> wait_nohang_untraced wait_on | Waitpid -> waitpid_nohang wait_on ;; end module Wait = struct type t = | T : { kind : ('q, 'r) Kind.t ; result : ('r, exn) Result.t Ivar.t ; wait_on : 'q } -> t [@@deriving sexp_of] let check (T t) = match Kind.wait_nohang t.kind t.wait_on with | None -> false | Some x -> Ivar.fill t.result (Ok x); true | exception exn -> Ivar.fill t.result (Error exn); true ;; end let waits : Wait.t list ref = ref [] let add ~kind ~result ~wait_on = waits := T { kind; result; wait_on } :: !waits let check_all () = waits := List.filter !waits ~f:(Fn.non Wait.check) let should_handle_sigchld = ref true let am_handling_sigchld = ref false let do_not_handle_sigchld () = if !am_handling_sigchld then raise_s [%message "already handling SIGCHLD" [%here]]; should_handle_sigchld := false ;; let install_sigchld_handler_the_first_time = lazy (if !should_handle_sigchld then ( am_handling_sigchld := true; Async_signal.handle [ Signal.chld ] ~f:(fun _ -> check_all ()))) ;; let deferred_wait (type q r) (wait_on : q) ~(kind : (q, r) Kind.t) = (* We are going to install a handler for SIGCHLD that will call [wait_nohang wait_on] in the future. However, we must also call [wait_nohang wait_on] right now, in case the child already exited, and will thus never cause a SIGCHLD in the future. We must install the SIGCHLD handler first and then call [wait_nohang]. If we did [wait_nohang] first, we could miss a SIGCHLD that was delivered after calling [wait_nohang] and before installing the handler. *) Lazy.force install_sigchld_handler_the_first_time; match Kind.wait_nohang kind wait_on with | Some result -> return result | None -> Deferred.create (fun result -> add ~kind ~result ~wait_on) >>| Result.ok_exn ;; let wait wait_on = deferred_wait wait_on ~kind:Normal let wait_untraced wait_on = deferred_wait wait_on ~kind:Untraced let waitpid pid = deferred_wait pid ~kind:Waitpid end let wait = Wait.wait let wait_untraced = Wait.wait_untraced let waitpid_prompt = Wait.waitpid let waitpid = Wait.waitpid let waitpid_exn pid = let%map exit_or_signal = waitpid pid in if Result.is_error exit_or_signal then raise_s [%message "child process didn't exit with status 0" ~child_pid:(pid : Pid.t) (exit_or_signal : Exit_or_signal.t)] ;; module Inet_addr = struct include Unix.Inet_addr let of_string_or_getbyname s = match of_string s with | t -> Deferred.return t | exception _ -> In_thread.run (fun () -> of_string_or_getbyname s) ;; end module Cidr = Unix.Cidr let bind_to_interface_exn = Or_error.map Linux_ext.bind_to_interface ~f:(fun bind_to_interface fd spec -> Fd.with_file_descr_exn fd (fun file_descr -> bind_to_interface file_descr spec)) ;; module Socket = struct module Address = struct module Inet = struct type t = [ `Inet of Inet_addr.t * int ] [@@deriving bin_io, compare, hash] let to_string_internal ~show_port_in_test (`Inet (a, p)) = sprintf "%s:%s" (Inet_addr.to_string a) (if am_running_inline_test && not show_port_in_test then "PORT" else p |> Int.to_string) ;; let to_string = to_string_internal ~show_port_in_test:false let sexp_of_t t : Sexp.t = Atom (to_string t) module Blocking_sexp = struct type t = [ `Inet of Inet_addr.Blocking_sexp.t * int ] [@@deriving bin_io, compare, hash, sexp] end module Show_port_in_test = struct type t = [ `Inet of Inet_addr.t * int ] [@@deriving sexp_of] let to_string = to_string_internal ~show_port_in_test:true end let addr (`Inet (a, _)) = a let port (`Inet (_, p)) = p let to_host_and_port (`Inet (addr, port)) = Host_and_port.create ~host:(Inet_addr.to_string addr) ~port ;; let create a ~port = `Inet (a, port) let create_bind_any ~port = `Inet (Inet_addr.of_string "0.0.0.0", port) let of_sockaddr_exn : Unix.sockaddr -> _ = function | ADDR_INET (a, i) -> `Inet (a, i) | u -> raise_s [%message "Socket.Address.inet" ~_:(u : Unix.sockaddr)] ;; let to_sockaddr (`Inet (a, i)) = Unix.ADDR_INET (a, i) end module Unix = struct type t = [ `Unix of string ] [@@deriving bin_io, compare, hash, sexp] let create s = `Unix s let to_string (`Unix s) = s let of_sockaddr_exn : Unix.sockaddr -> t = function | ADDR_UNIX s -> `Unix s | u -> raise_s [%message "Socket.Address.unix" ~_:(u : Unix.sockaddr)] ;; let to_sockaddr (`Unix s) = Unix.ADDR_UNIX s end type t = [ Inet.t | Unix.t ] [@@deriving bin_io, sexp_of] module Blocking_sexp = struct type t = [ Inet.Blocking_sexp.t | Unix.t ] [@@deriving bin_io, hash, sexp] end let to_sockaddr = function | #Inet.t as t -> Inet.to_sockaddr t | #Unix.t as t -> Unix.to_sockaddr t ;; let to_string = function | `Inet _ as t -> t |> Inet.to_string | `Unix _ as t -> t |> Unix.to_string ;; end module Family = struct module Gadt = struct type _ t = | Inet : Address.Inet.t t | Unix : Address.Unix.t t let is_inet_witness : type a. a t -> (a, Address.Inet.t) Type_equal.t option = function | Inet -> Some T | Unix -> None ;; end type 'address t = { family : Unix.socket_domain ; family_gadt : 'address Gadt.t ; address_of_sockaddr_exn : Unix.sockaddr -> 'address ; sexp_of_address : 'address -> Sexp.t } constraint 'address = [< Address.t ] [@@deriving fields] let sexp_of_t _ { address_of_sockaddr_exn = _; family; family_gadt = _; sexp_of_address = _ } = [%sexp (family : Unix.socket_domain)] ;; let to_string t = match t.family with | PF_INET -> "inet" | PF_INET6 -> "inet6" | PF_UNIX -> "unix" ;; let inet = { family = PF_INET ; family_gadt = Inet ; address_of_sockaddr_exn = Address.Inet.of_sockaddr_exn ; sexp_of_address = Address.Inet.sexp_of_t } ;; let unix = { family = PF_UNIX ; family_gadt = Unix ; address_of_sockaddr_exn = Address.Unix.of_sockaddr_exn ; sexp_of_address = Address.Unix.sexp_of_t } ;; let is_inet_witness t = Gadt.is_inet_witness t.family_gadt end module Type = struct type 'a t = { family : 'a Family.t ; socket_type : Unix.socket_type } [@@deriving sexp_of] let family t = t.family let sexp_of_address t = t.family.sexp_of_address let tcp = { family = Family.inet; socket_type = SOCK_STREAM } let udp = { family = Family.inet; socket_type = SOCK_DGRAM } let unix = { family = Family.unix; socket_type = SOCK_STREAM } let unix_dgram = { family = Family.unix; socket_type = SOCK_DGRAM } let phys_same (t1 : _ t) (t2 : _ t) = phys_same t1 t2 end module For_info = struct type 'addr t = { mutable connected_to : 'addr option ; mutable bound_on : 'addr option ; mutable listening : bool ; type_ : 'addr Type.t } let create type_ = { connected_to = None; bound_on = None; listening = false; type_ } let info { connected_to; bound_on; listening; type_ } = let type_ = if Type.phys_same type_ Type.tcp then [%sexp "tcp"] else if Type.phys_same type_ Type.udp then [%sexp "udp"] else [%sexp (type_ : _ Type.t)] in let bound_on, listening_on = if listening then None, bound_on else bound_on, None in Info.create_s [%sexp { connected_to : ([< Address.t ] option[@sexp.option]) ; type_ : Sexp.t ; bound_on : ([< Address.t ] option[@sexp.option]) ; listening_on : ([< Address.t ] option[@sexp.option]) }] ;; end type 'addr t_ = { type_ : 'addr Type.t ; fd : Fd.t ; for_info : 'addr For_info.t option } type (+'state, 'addr) t = 'addr t_ constraint 'state = [< `Unconnected | `Bound | `Passive | `Active ] let sexp_of_t _ _ t = Fd.sexp_of_t t.fd let fd t = t.fd let of_fd fd type_ = { type_; fd; for_info = None } let sexp_of_address t = Type.sexp_of_address t.type_ let create (type_ : _ Type.t) = let file_descr = Unix.socket ~domain:type_.family.family ~kind:type_.socket_type ~protocol:0 ~close_on_exec:true () in let fd = Fd.create (Socket `Unconnected) file_descr (Info.create "socket" type_ [%sexp_of: _ Type.t]) in { type_; fd; for_info = Some (For_info.create type_) } ;; module Opt = struct type 'a t = { name : string ; get : File_descr.t -> 'a ; set : File_descr.t -> 'a -> unit } let to_string t = t.name let make getsockopt setsockopt name opt = { name ; get = (fun fd -> getsockopt fd opt) ; set = (fun fd a -> setsockopt fd opt a) } ;; let bool = make Unix.getsockopt Unix.setsockopt let int = make Unix.getsockopt_int Unix.setsockopt_int let optint = make Unix.getsockopt_optint Unix.setsockopt_optint let float = make Unix.getsockopt_float Unix.setsockopt_float let debug = bool "debug" SO_DEBUG let broadcast = bool "broadcast" SO_BROADCAST let reuseaddr = bool "reuseaddr" SO_REUSEADDR let keepalive = bool "keepalive" SO_KEEPALIVE let dontroute = bool "dontroute" SO_DONTROUTE let oobinline = bool "oobinline" SO_OOBINLINE let acceptconn = bool "acceptconn" SO_ACCEPTCONN let nodelay = bool "nodelay" TCP_NODELAY let sndbuf = int "sndbuf" SO_SNDBUF let rcvbuf = int "rcvbuf" SO_RCVBUF let error = int "error" SO_ERROR let typ = int "typ" SO_TYPE let rcvlowat = int "rcvlowat" SO_RCVLOWAT let sndlowat = int "sndlowat" SO_SNDLOWAT let linger = optint "linger" SO_LINGER let rcvtimeo = float "rcvtimeo" SO_RCVTIMEO let sndtimeo = float "sndtimeo" SO_SNDTIMEO (* Since there aren't socket options like SO_MCASTLOOP or SO_MCASTTTL, we wrap [Core_unix] functions to match async's socket-options interface. *) let mcast_loop = { name = "mcast_loop"; get = Unix.get_mcast_loop; set = Unix.set_mcast_loop } ;; let mcast_ttl = { name = "mcast_ttl"; get = Unix.get_mcast_ttl; set = Unix.set_mcast_ttl } ;; end let getopt t (opt : _ Opt.t) = Fd.with_file_descr_exn t.fd opt.get let setopt t (opt : _ Opt.t) a = Fd.with_file_descr_exn t.fd (fun file_descr -> opt.set file_descr a) ;; let mcast_join ?ifname ?source t address = Fd.with_file_descr_exn t.fd (fun file_descr -> Unix.mcast_join ?ifname ?source file_descr (Address.to_sockaddr address)) ;; let mcast_leave ?ifname ?source t address = Fd.with_file_descr_exn t.fd (fun file_descr -> Unix.mcast_leave ?ifname ?source file_descr (Address.to_sockaddr address)) ;; let mark_bound t address = let info = match t.for_info with | Some i -> i.bound_on <- Some address; `Set (For_info.info i) | None -> `Extend (Info.create "socket" (`bound_on address) (let sexp_of_address = sexp_of_address t in [%sexp_of: [ `bound_on of address ]])) in Fd.Private.replace t.fd (Socket `Bound) info ;; let bind ?(reuseaddr = true) t address = setopt t Opt.reuseaddr reuseaddr; set_close_on_exec t.fd; let sockaddr = Address.to_sockaddr address in let%map () = Fd.syscall_in_thread_exn t.fd ~name:"bind" (fun file_descr -> Unix.bind file_descr ~addr:sockaddr) in mark_bound t address; t ;; let bind_inet ?(reuseaddr = true) t address = setopt t Opt.reuseaddr reuseaddr; set_close_on_exec t.fd; let sockaddr = Address.to_sockaddr address in Fd.syscall_exn t.fd (fun file_descr -> Unix.bind file_descr ~addr:sockaddr); mark_bound t address; t ;; let listen ?(backlog = 64) t = let fd = t.fd in Fd.syscall_exn fd (fun file_descr -> Unix.listen file_descr ~backlog); let info = match t.for_info with | Some i -> i.listening <- true; `Set (For_info.info i) | None -> `Extend (Info.of_string "listening") in Fd.Private.replace fd (Socket `Passive) info; t ;; let turn_off_nagle (addr : Unix.sockaddr) t = match addr, t.type_.socket_type with | ADDR_INET _, SOCK_STREAM -> setopt t Opt.nodelay true | (ADDR_UNIX _ | ADDR_INET _), _ -> () ;; let accept_nonblocking t = (* We call [accept] with [~nonblocking:true] because there is no way to use [select] to guarantee that an [accept] will not block (see Stevens' book on Unix Network Programming, p422). *) match Fd.with_file_descr t.fd ~nonblocking:true (fun file_descr -> Unix.accept file_descr ~close_on_exec:true) with | `Already_closed -> `Socket_closed | `Ok (file_descr, sockaddr) -> let address = Family.address_of_sockaddr_exn t.type_.family sockaddr in let fd = Fd.create (Fd.Kind.Socket `Active) file_descr (Info.create "socket" (`listening_on (Fd.info t.fd), `client address) (let sexp_of_address = sexp_of_address t in [%sexp_of: [ `listening_on of Info.t ] * [ `client of address ]])) in let s = { fd; type_ = t.type_; for_info = None } in turn_off_nagle sockaddr s; `Ok (s, address) | `Error (Unix_error ((EAGAIN | EWOULDBLOCK | ECONNABORTED | EINTR), _, _)) -> (* If [accept] would have blocked (EAGAIN|EWOULDBLOCK) or got interrupted (EINTR), then we return [`Would_block]. If the kernel returns ECONNABORTED, this means that we first got a connection and therefore woke up in "select" (ready to read). But due to slowness (e.g. other long async jobs getting to run first) we could not call accept quickly enough, and the other side terminated the connection in the meanwhile. Though one could imagine weird client/server applications that absolutely need to know that some client aborted the connection before we could accept it, this seems quite contrived and unlikely. In virtually all cases people just want to continue waiting for a new connection. [Sys_blocked_io] cannot be raised here. This is a Unix-function, not a standard OCaml I/O-function (e.g. for reading from channels). *) `Would_block | `Error exn -> raise exn ;; let accept_interruptible t ~interrupt = Deferred.repeat_until_finished () (fun () -> match accept_nonblocking t with | (`Socket_closed | `Ok _) as x -> return (`Finished x) | `Would_block -> (match%map Fd.interruptible_ready_to t.fd `Read ~interrupt with | `Ready -> `Repeat () | `Interrupted as x -> `Finished x | `Closed -> `Finished `Socket_closed | `Bad_fd -> raise_s [%message "accept on bad file descriptor" ~_:(t.fd : Fd.t)])) ;; let accept t = match%map accept_interruptible t ~interrupt:(Fd.close_started t.fd) with | `Interrupted -> `Socket_closed | (`Socket_closed | `Ok _) as x -> x ;; let accept_at_most_interruptible t ~limit ~interrupt = if limit < 1 then raise_s [%message "[Socket.accept_at_most_interruptible] got [limit] < 1" (limit : int)]; match%map accept_interruptible t ~interrupt with | (`Socket_closed | `Interrupted) as x -> x | `Ok connection -> (* Now that we have a connection, accept without blocking as many other connections as we can, up to [limit] total connections. *) let rec loop limit connections = if limit = 0 then connections else ( match accept_nonblocking t with | `Ok connection -> loop (limit - 1) (connection :: connections) | `Socket_closed | `Would_block -> connections | exception exn -> don't_wait_for (Deferred.List.iter connections ~f:(fun (conn, _) -> Fd.close conn.fd)); raise exn) in `Ok (List.rev (loop (limit - 1) [ connection ])) ;; let accept_at_most t ~limit = match%map accept_at_most_interruptible t ~limit ~interrupt:(Fd.close_started t.fd) with | `Interrupted -> `Socket_closed | (`Socket_closed | `Ok _) as x -> x ;; let connect_interruptible t address ~interrupt = let sockaddr = Address.to_sockaddr address in turn_off_nagle sockaddr t; let success () = let info = match t.for_info with | Some i -> i.connected_to <- Some address; `Set (For_info.info i) | None -> let sexp_of_address = sexp_of_address t in `Extend (Info.create "connected to" address [%sexp_of: address]) in Fd.Private.replace t.fd (Fd.Kind.Socket `Active) info; `Ok t in (* We call [connect] with [~nonblocking:true] to initiate an asynchronous connect (see Stevens' book on Unix Network Programming, p413). Once the connect succeeds or fails, [select] on the socket will return it in the writeable set. *) match Fd.with_file_descr t.fd ~nonblocking:true (fun file_descr -> Unix.connect file_descr ~addr:sockaddr) with | `Already_closed -> raise_s [%message "close before connect" (t.fd : Fd.t)] | `Ok () -> return (success ()) | `Error (Unix_error ((EINPROGRESS | EINTR), _, _)) -> (match%map Fd.interruptible_ready_to t.fd `Write ~interrupt with | `Closed -> raise_s [%message "close during connect" (t.fd : Fd.t)] | `Bad_fd -> raise_s [%message "connect on bad file descriptor" ~_:(t.fd : Fd.t)] | `Interrupted as x -> x | `Ready -> (* We call [getsockopt] to find out whether the connect has succeed or failed. *) (match Fd.with_file_descr t.fd (fun file_descr -> Unix.getsockopt_int file_descr SO_ERROR) with | `Already_closed -> raise_s [%message "close after connect" (t.fd : Fd.t)] | `Error exn -> raise exn | `Ok err -> if err = 0 then success () else Unix.unix_error err "connect" (Address.to_string address))) | `Error e -> raise e ;; let connect t addr = match%map connect_interruptible t addr ~interrupt:(Deferred.never ()) with | `Interrupted -> assert false (* impossible *) | `Ok t -> t ;; let shutdown t mode = let mode : Unix.shutdown_command = match mode with | `Receive -> SHUTDOWN_RECEIVE | `Send -> SHUTDOWN_SEND | `Both -> SHUTDOWN_ALL in Fd.syscall_exn t.fd (fun file_descr -> Unix.shutdown file_descr ~mode) ;; let getsockname t = Family.address_of_sockaddr_exn t.type_.family (Unix.getsockname (Fd.file_descr_exn t.fd)) ;; let getpeername t = Family.address_of_sockaddr_exn t.type_.family (Unix.getpeername (Fd.file_descr_exn t.fd)) ;; let bind_to_interface_exn = Or_error.map bind_to_interface_exn ~f:(fun f t ifname -> f t.fd ifname) ;; end let socketpair () = let s1, s2 = Unix.socketpair ~domain:PF_UNIX ~kind:SOCK_STREAM ~protocol:0 ~close_on_exec:true () in let make_fd s = Fd.create (Fd.Kind.Socket `Active) s (Info.of_string "") in make_fd s1, make_fd s2 ;; module Protocol_family = Unix.Protocol_family module Host = struct type t = Unix.Host.t = { name : string ; aliases : string array ; family : Protocol_family.t ; addresses : Inet_addr.t array } let getbyname n = In_thread.syscall_exn ~name:"gethostbyname" (fun () -> Unix.Host.getbyname n) ;; let getbyname_exn n = In_thread.syscall_exn ~name:"gethostbyname" (fun () -> Unix.Host.getbyname_exn n) ;; let getbyaddr a = In_thread.syscall_exn ~name:"gethostbyaddr" (fun () -> Unix.Host.getbyaddr a) ;; let getbyaddr_exn a = In_thread.syscall_exn ~name:"gethostbyaddr" (fun () -> Unix.Host.getbyaddr_exn a) ;; let have_address_in_common = Unix.Host.have_address_in_common end type socket_domain = Unix.socket_domain = | PF_UNIX | PF_INET | PF_INET6 [@@deriving bin_io, compare, hash, sexp] type socket_type = Unix.socket_type = | SOCK_STREAM | SOCK_DGRAM | SOCK_RAW | SOCK_SEQPACKET [@@deriving bin_io, compare, hash, sexp] type sockaddr = Unix.sockaddr = | ADDR_UNIX of string | ADDR_INET of Inet_addr.t * int [@@deriving bin_io, compare, sexp_of] type sockaddr_blocking_sexp = Unix.sockaddr = | ADDR_UNIX of string | ADDR_INET of Inet_addr.Blocking_sexp.t * int [@@deriving bin_io, sexp] module Addr_info = struct type t = Unix.addr_info = { ai_family : socket_domain ; ai_socktype : socket_type ; ai_protocol : int ; ai_addr : sockaddr ; ai_canonname : string } [@@deriving bin_io, sexp_of] module Blocking_sexp = struct type t = Unix.addr_info = { ai_family : socket_domain ; ai_socktype : socket_type ; ai_protocol : int ; ai_addr : sockaddr_blocking_sexp ; ai_canonname : string } [@@deriving bin_io, sexp] end type getaddrinfo_option = Unix.getaddrinfo_option = | AI_FAMILY of socket_domain | AI_SOCKTYPE of socket_type | AI_PROTOCOL of int | AI_NUMERICHOST | AI_CANONNAME | AI_PASSIVE [@@deriving bin_io, sexp] let get ?(service = "") ~host options = In_thread.syscall_exn ~name:"getaddrinfo" (fun () -> Unix.getaddrinfo host service options) ;; end module Name_info = struct type t = Unix.name_info = { ni_hostname : string ; ni_service : string } [@@deriving bin_io, sexp] type getnameinfo_option = Unix.getnameinfo_option = | NI_NOFQDN | NI_NUMERICHOST | NI_NAMEREQD | NI_NUMERICSERV | NI_DGRAM [@@deriving sexp, bin_io] let get addr options = In_thread.syscall_exn ~name:"getnameinfo" (fun () -> Unix.getnameinfo addr options) ;; end let gethostname () = Unix.gethostname () let setuid uid = Unix.setuid uid let getuid () = Unix.getuid () let getgid () = Unix.getgid () let getegid () = Unix.getegid () let geteuid () = Unix.geteuid () module Terminal_io = struct include Unix.Terminal_io let tcgetattr fd = Fd.syscall_in_thread_exn fd ~name:"tcgetattr" (fun file_descr -> tcgetattr file_descr) ;; let tcsetattr t fd ~mode = Fd.syscall_in_thread_exn fd ~name:"tcsetattr" (fun file_descr -> tcsetattr t file_descr ~mode) ;; end module Passwd = struct type t = Unix.Passwd.t = { name : string ; passwd : string ; uid : int ; gid : int ; gecos : string ; dir : string ; shell : string } [@@deriving fields, sexp] (* The four [Unix.Passwd] functions call C functions that release the OCaml lock and do a reentrant system call. *) let getbyname n = In_thread.run (fun () -> Unix.Passwd.getbyname n) let getbyname_exn n = In_thread.run (fun () -> Unix.Passwd.getbyname_exn n) let getbyuid uid = In_thread.run (fun () -> Unix.Passwd.getbyuid uid) let getbyuid_exn uid = In_thread.run (fun () -> Unix.Passwd.getbyuid_exn uid) end module Group = struct type t = Unix.Group.t = { name : string ; passwd : string ; gid : int ; mem : string array } [@@deriving fields, sexp] (* The four [Unix.Group] functions call C functions that release the OCaml lock and do a reentrant system call. *) let getbyname n = In_thread.run (fun () -> Unix.Group.getbyname n) let getbyname_exn n = In_thread.run (fun () -> Unix.Group.getbyname_exn n) let getbygid gid = In_thread.run (fun () -> Unix.Group.getbygid gid) let getbygid_exn gid = In_thread.run (fun () -> Unix.Group.getbygid_exn gid) end let getlogin () = In_thread.syscall_exn ~name:"getlogin" (fun () -> Unix.getlogin ()) module Ifaddr = Unix.Ifaddr let getifaddrs () = In_thread.run Unix.getifaddrs let wordexp = Or_error.map Unix.wordexp ~f:(fun wordexp ?flags glob -> In_thread.syscall_exn ~name:"wordexp" (fun () -> wordexp ?flags glob)) ;; module Private = struct module Wait = Wait end async_unix-0.15.0/src/unix_syscalls.mli000066400000000000000000000664761420273305200201700ustar00rootroot00000000000000(** [Unix_syscalls] provides an interface to many of the functions in OCaml's standard Unix module. It uses a deferred in the return type of functions that would block. The idea is that in an Async program one does not use the standard Unix module, since in doing so one could accidentally block the whole program. There are also a number of cosmetic changes (e.g., polymorphic variants) and other improvements (e.g., phantom types on sockets) over the standard Unix module. *) open! Core open! Import module Syscall_result = Unix.Syscall_result module Exit = Unix.Exit module Exit_or_signal = Unix.Exit_or_signal module Exit_or_signal_or_stop = Unix.Exit_or_signal_or_stop val system : string -> Exit_or_signal.t Deferred.t val system_exn : string -> unit Deferred.t val getpid : unit -> Pid.t val getppid : unit -> Pid.t option val getppid_exn : unit -> Pid.t (** [this_process_became_child_of_init] returns a deferred that becomes determined when the current process becomes a child of [init(8)]. This is useful for determining whether one's parent has died, because in that case [init] will become one's parent. See [Linux_ext.pr_set_pdeathsig : Signal.t -> unit] for a related way to get information about parent death. [?poll_delay] controls how often to check. *) val this_process_became_child_of_init : ?poll_delay:Time.Span.t -> unit -> unit Deferred.t val nice : int -> int (** [cores ()] Returns the number of cores. *) val cores : (unit -> int Deferred.t) Or_error.t type open_flag = [ `Rdonly | `Wronly | `Rdwr | `Nonblock | `Append | `Creat | `Trunc | `Excl | `Noctty | `Dsync | `Sync | `Rsync ] type file_perm = int val openfile : ?info:Info.t -> ?perm:file_perm -> string -> mode:open_flag list -> Fd.t Deferred.t module Lock_mode : sig type t = | Shared (** Does not exclude other Shared locks, only other Exclusive locks *) | Exclusive (** Excludes other Shared and Exclusive locks *) [@@deriving sexp_of] end module Lock_mechanism : sig type t = | Lockf (** Lockf refers to the ocaml [lockf] function, which, despite the name, does not call the UNIX lockf() system call, but rather calls fcntl() with F_SETLKW. *) | Flock [@@deriving compare, enumerate, sexp] include Stringable.S with type t := t val arg_type : t Command.Arg_type.t end module Lock : sig type t = { mode : Lock_mode.t ; mechanism : Lock_mechanism.t } [@@deriving sexp_of] end (** [with_file file ~mode ~perm ~f] opens [file], and applies [f] to the resulting file descriptor. When the result of [f] becomes determined, it closes the descriptor and returns the result of [f]. If [lock] is supplied, then the file descriptor is locked before calling [f] with the specified [lock_mechanism]. Note that it is not unlocked before close, which might be significant if this file descriptor is held elsewhere (e.g., by fork() or dup()). *) val with_file : ?lock:Lock.t (** default is no lock *) -> ?perm:file_perm -> string -> mode:open_flag list -> f:(Fd.t -> 'a Deferred.t) -> 'a Deferred.t module Open_flags = Unix.Open_flags (** [fcntl_getfl] and [fcntl_setf] are deferred wrappers around the corresponding functions in [Core_unix] for accessing the open-file-descriptor table. *) val fcntl_getfl : Fd.t -> Open_flags.t Deferred.t val fcntl_setfl : Fd.t -> Open_flags.t -> unit Deferred.t include module type of Fd.Close val lseek : Fd.t -> int64 -> mode:[< `Set | `Cur | `End ] -> int64 Deferred.t val truncate : string -> len:int64 -> unit Deferred.t val ftruncate : Fd.t -> len:int64 -> unit Deferred.t val fsync : Fd.t -> unit Deferred.t val fdatasync : Fd.t -> unit Deferred.t val sync : unit -> unit Deferred.t (** [lockf fd lock_mode ?len] locks the section of the open file [fd] specified by the current file position and [len] (see man lockf). It returns when the lock has been acquired. It raises if [fd] is closed. Warning: [lockf] locks are held per-process, so taking the lock on the same file multiple times in the same process is going to break in terrible ways. Note that, despite the name, this function does not call the UNIX lockf() system call; rather it calls fcntl() with F_SETLKW *) val lockf : ?len:Int64.t -> Fd.t -> Lock_mode.t -> unit Deferred.t (** [try_lockf fd lock_mode ?len] attempts to lock the section of the open file [fd] specified by the current file position and [len] (see man lockf). It returns [true] if it acquired the lock. It raises if [fd] is closed. Note that, despite the name, this function does not call the UNIX lockf() system call; rather it calls fcntl() with F_SETLK *) val try_lockf : ?len:Int64.t -> Fd.t -> Lock_mode.t -> bool (** [test_lockf fd ?len] checks the lock on section of the open file [fd] specified by the current file position and [len]. If the section is unlocked or locked by this process, it returns true, else it returns false. It raises if [fd] is closed. Note that, despite the name, this function does not call the UNIX lockf() system call; rather it calls fcntl() with F_GETLK *) val test_lockf : ?len:Int64.t -> Fd.t -> bool (** [unlockf fd ?len] unlocks the section of the open file [fd] specified by the current file position and [len]. It raises if [fd] is closed. Note that, despite the name, this function does not call the UNIX lockf() system call; rather it calls fcntl() with F_UNLCK *) val unlockf : ?len:Int64.t -> Fd.t -> unit (** [flock fd lock_mode] locks the open file [fd] (see man 2 flock). It returns when the lock has been acquired. It raises if [fd] is closed. *) val flock : Fd.t -> Lock_mode.t -> unit Deferred.t (** [try_flock fd lock_mode] attempts to lock the open file [fd] (see man 2 flock). It returns [true] if it acquired the lock or [false] if a conflicting lock was already present. It raises if [fd] is closed. *) val try_flock : Fd.t -> Lock_mode.t -> bool (** [funlock fd] unlocks the open file [fd] (see [man 2 flock]). It raises if [fd] is closed. *) val funlock : Fd.t -> unit module File_kind : sig type t = [ `File | `Directory | `Char | `Block | `Link | `Fifo | `Socket ] [@@deriving sexp] include Comparable.S with type t := t val of_unix : Core_unix.file_kind -> t end module Stats : sig type t = { dev : int ; ino : int ; kind : File_kind.t ; perm : file_perm ; nlink : int ; uid : int ; gid : int ; rdev : int ; size : int64 ; atime : Time.t ; mtime : Time.t ; ctime : Time.t } [@@deriving fields, sexp, bin_io, compare] val of_unix : Core_unix.stats -> t val to_string : t -> string end val fstat : Fd.t -> Stats.t Deferred.t val stat : string -> Stats.t Deferred.t val lstat : string -> Stats.t Deferred.t val isatty : Fd.t -> bool Deferred.t val unlink : string -> unit Deferred.t val remove : string -> unit Deferred.t val rename : src:string -> dst:string -> unit Deferred.t val link : ?force:bool (** default is [false] *) -> target:string -> link_name:string -> unit -> unit Deferred.t val chmod : string -> perm:file_perm -> unit Deferred.t val fchmod : Fd.t -> perm:file_perm -> unit Deferred.t val chown : string -> uid:int -> gid:int -> unit Deferred.t val fchown : Fd.t -> uid:int -> gid:int -> unit Deferred.t val access : string -> [ `Read | `Write | `Exec | `Exists ] list -> (unit, exn) Result.t Deferred.t val access_exn : string -> [ `Read | `Write | `Exec | `Exists ] list -> unit Deferred.t val set_close_on_exec : Fd.t -> unit val clear_close_on_exec : Fd.t -> unit val mkdir : ?p:unit -> ?perm:file_perm -> string -> unit Deferred.t val rmdir : string -> unit Deferred.t val chdir : string -> unit Deferred.t val getcwd : unit -> string Deferred.t val chroot : string -> unit Deferred.t type dir_handle = Unix.dir_handle val opendir : string -> dir_handle Deferred.t (** [readdir_opt dir_handle] returns the next directory member, or [None] when there are no more directory members to return. *) val readdir_opt : dir_handle -> string option Deferred.t val rewinddir : dir_handle -> unit Deferred.t val closedir : dir_handle -> unit Deferred.t (** The [info] supplied to pipe is debugging information that will be included in the returned [Fd]s. *) val pipe : Info.t -> ([ `Reader of Fd.t ] * [ `Writer of Fd.t ]) Deferred.t (** Create a named pipe with the given permissions. *) val mkfifo : ?perm:file_perm (** default is [0o666] *) -> string -> unit Deferred.t val symlink : target:string -> link_name:string -> unit Deferred.t val readlink : string -> string Deferred.t (** [mkstemp prefix] creates and opens a unique temporary file with [prefix], automatically appending a suffix of six random characters to make the name unique. Unlike C's [mkstemp], [prefix] should not include six X's at the end. @raise Unix_error on errors. *) val mkstemp : string -> (string * Fd.t) Deferred.t val mkdtemp : string -> string Deferred.t val getgrouplist : string -> int -> int array Deferred.t (** Time functions. *) type process_times = Unix.process_times = { tms_utime : float (** User time for the process *) ; tms_stime : float (** System time for the process *) ; tms_cutime : float (** User time for the children processes *) ; tms_cstime : float (** System time for the children processes *) } val times : unit -> process_times type tm = Unix.tm = { tm_sec : int (** Seconds 0..59 *) ; tm_min : int (** Minutes 0..59 *) ; tm_hour : int (** Hours 0..23 *) ; tm_mday : int (** Day of month 1..31 *) ; tm_mon : int (** Month of year 0..11 *) ; tm_year : int (** Year - 1900 *) ; tm_wday : int (** Day of week (Sunday is 0) *) ; tm_yday : int (** Day of year 0..365 *) ; tm_isdst : bool (** Daylight time savings in effect *) } val time : unit -> float val gettimeofday : unit -> float val gmtime : float -> tm val localtime : float -> tm val mktime : tm -> float * tm val utimes : string -> access:float -> modif:float -> unit Deferred.t type env = Unix.env [@@deriving sexp] val environment : unit -> string array val getenv : string -> string option val getenv_exn : string -> string val unsafe_getenv : string -> string option val unsafe_getenv_exn : string -> string val putenv : key:string -> data:string -> unit val unsetenv : string -> unit (** [fork_exec ~prog ~argv ?path ?env] forks and execs [prog] with [argv], and returns the child pid. If [use_path = true] (the default) and [prog] doesn't contain a slash, then [fork_exec] searches the PATH environment variable for [prog]. If [env] is supplied, it specifies the environment when [prog] is executed. If [env] contains multiple bindings for the same variable, the last takes precedence. In the case of [`Extend], bindings in [env] take precedence over the existing environment. See {!Unix.exec}. *) val fork_exec : prog:string -> argv:string list -> ?use_path:bool (** default is [true] *) -> ?env:[ env | `Replace_raw of string list ] -> unit -> Pid.t Deferred.t type wait_on = [ `Any | `Group of Pid.t | `My_group | `Pid of Pid.t ] [@@deriving sexp] val wait : wait_on -> (Pid.t * Exit_or_signal.t) Deferred.t val wait_nohang : wait_on -> (Pid.t * Exit_or_signal.t) option val wait_untraced : wait_on -> (Pid.t * Exit_or_signal_or_stop.t) Deferred.t val wait_nohang_untraced : wait_on -> (Pid.t * Exit_or_signal_or_stop.t) option (** [waitpid pid] returns a deferred that becomes determined with the child's exit status, when the child process with process id [pid] exits. [waitpid_exn] is like [waitpid], except the result only becomes determined if the child exits with status zero; it raises if the child terminates in any other way. *) val waitpid : Pid.t -> Exit_or_signal.t Deferred.t (** Same as {!waitpid}, but guarantees that the resulting [Deferred] is determined in the same async job as the [wait] system call, so that it's safe to keep using the [pid] if the deferred is not determined. *) val waitpid_prompt : Pid.t -> Exit_or_signal.t Deferred.t val waitpid_exn : Pid.t -> unit Deferred.t module Inet_addr : sig include module type of struct include Unix.Inet_addr end (** [of_string_or_getbyname hostname] does a DNS lookup of hostname and returns the resulting IP address. *) val of_string_or_getbyname : string -> t Deferred.t end module Cidr = Core_unix.Cidr module Protocol_family : sig type t = Unix.Protocol_family.t end val socketpair : unit -> Fd.t * Fd.t module Socket : sig module Address : sig module Unix : sig type t = [ `Unix of string ] [@@deriving bin_io, sexp, compare] val create : string -> t val to_string : t -> string val to_sockaddr : t -> Core_unix.sockaddr end module Inet : sig type t = [ `Inet of Inet_addr.t * int ] [@@deriving bin_io, compare, hash, sexp_of] (** [Blocking_sexp] performs DNS lookup to resolve hostnames to IP addresses. *) module Blocking_sexp : sig type nonrec t = t [@@deriving bin_io, compare, hash, sexp_poly] end (** [Show_port_in_test] renders the port as an integer, even in tests, unlike the normal [sexp_of_t] and [to_string], which render the port as "PORT" in tests. *) module Show_port_in_test : sig type nonrec t = t [@@deriving sexp_of] val to_string : t -> string end val create : Inet_addr.t -> port:int -> t val create_bind_any : port:int -> t val addr : t -> Inet_addr.t val port : t -> int val to_string : t -> string val to_host_and_port : t -> Host_and_port.t val to_sockaddr : t -> Core_unix.sockaddr end type t = [ Inet.t | Unix.t ] [@@deriving bin_io, sexp_of] (** [Blocking_sexp] performs DNS lookup to resolve hostnames to IP addresses. *) module Blocking_sexp : sig type nonrec t = t [@@deriving bin_io, hash, sexp] end val to_string : [< t ] -> string val to_sockaddr : [< t ] -> Core_unix.sockaddr end module Family : sig type 'a t constraint 'a = [< Address.t ] val unix : Address.Unix.t t val inet : Address.Inet.t t val is_inet_witness : 'a t -> ('a, Address.Inet.t) Type_equal.t option val to_string : 'a t -> string end (** Sockets have a phantom type parameter that tracks the state of the socket in order to eliminate certain errors in which socket functions are called in the wrong order. Initially, a socket is [`Unconnected]. As various socket functions are called, they return a socket with a new phantom state. Here is a chart of the allowed state transitions. {v Unconnected ---connect--> Active | | ---bind--> Bound ---listen--> Passive ---accept---> Active | | ---connect--> Active v} *) type (+'a, 'b) t constraint 'a = [< `Unconnected | `Bound | `Passive | `Active ] constraint 'b = [< Address.t ] [@@deriving sexp_of] module Type : sig type 'a t constraint 'a = [< Address.t ] [@@deriving sexp_of] val tcp : Address.Inet.t t val udp : Address.Inet.t t val unix : Address.Unix.t t val unix_dgram : Address.Unix.t t val family : 'a t -> 'a Family.t end val create : 'addr Type.t -> ([ `Unconnected ], 'addr) t (** Calling [Fd.close] on the socket's file descriptor before {e or during} [connect] may cause [connect] to raise. *) val connect : ([< `Unconnected | `Bound ], 'addr) t -> 'addr -> ([ `Active ], 'addr) t Deferred.t val connect_interruptible : ([< `Unconnected | `Bound ], 'addr) t -> 'addr -> interrupt:unit Deferred.t -> [ `Ok of ([ `Active ], 'addr) t | `Interrupted ] Deferred.t (** [bind socket addr] sets close_on_exec for the fd of [socket]. *) val bind : ?reuseaddr:bool (** default is [true] *) -> ([ `Unconnected ], 'addr) t -> 'addr -> ([ `Bound ], 'addr) t Deferred.t (** [bind_inet socket addr] is just like [bind] but is restricted to [Inet.t] addresses and is therefore guaranteed not to block. *) val bind_inet : ?reuseaddr:bool (** default is [true] *) -> ([ `Unconnected ], Address.Inet.t) t -> Address.Inet.t -> ([ `Bound ], Address.Inet.t) t val listen : ?backlog:int (** default is 64; see {!Unix.listen} *) -> ([ `Bound ], 'addr) t -> ([ `Passive ], 'addr) t val accept : ([ `Passive ], 'addr) t -> [ `Ok of ([ `Active ], 'addr) t * 'addr | `Socket_closed ] Deferred.t val accept_interruptible : ([ `Passive ], 'addr) t -> interrupt:unit Deferred.t -> [ `Ok of ([ `Active ], 'addr) t * 'addr | `Socket_closed | `Interrupted ] Deferred.t (** [accept_at_most] is like [accept], but will return up to [limit] connections before yielding, where [limit >= 1]. [accept_at_most] first waits for one connection and then attempts to retrieve up to [limit] connections through non-blocking {!Unix.accept} calls. If a call to {!Unix.accept} would block before [limit] is reached, [accept_at_most] returns the connections retrieved thus far. Servers that must service a large number of connections tend to observe a stall in connection accept rates when under heavy load. Increasing [limit] will ameliorate this effect, and increase accept rates and overall throughput of the server at the cost of increased contention for resources amongst connections. For details, see: {v Acceptable strategies for improving web server performance Brecht, Pariag, and Gammo. USENIX ATEC '04 v} *) val accept_at_most : ([ `Passive ], 'addr) t -> limit:int -> [ `Ok of (([ `Active ], 'addr) t * 'addr) list | `Socket_closed ] Deferred.t val accept_at_most_interruptible : ([ `Passive ], 'addr) t -> limit:int -> interrupt:unit Deferred.t -> [ `Ok of (([ `Active ], 'addr) t * 'addr) list | `Socket_closed | `Interrupted ] Deferred.t val shutdown : ('a, 'addr) t -> [ `Receive | `Send | `Both ] -> unit val fd : ('a, 'addr) t -> Fd.t val of_fd : Fd.t -> 'addr Type.t -> ('a, 'addr) t val getsockname : ('a, 'addr) t -> 'addr val getpeername : ('a, 'addr) t -> 'addr module Opt : sig type 'a t val debug : bool t val broadcast : bool t val reuseaddr : bool t val keepalive : bool t val dontroute : bool t val oobinline : bool t val acceptconn : bool t val nodelay : bool t val sndbuf : int t val rcvbuf : int t val error : int t val typ : int t val rcvlowat : int t val sndlowat : int t val linger : int option t val rcvtimeo : float t val sndtimeo : float t val mcast_loop : bool t val mcast_ttl : int t val to_string : 'a t -> string end val getopt : ('a, 'addr) t -> 'c Opt.t -> 'c val setopt : ('a, 'addr) t -> 'c Opt.t -> 'c -> unit val mcast_join : ?ifname:string -> ?source:Inet_addr.t -> ('a, 'addr) t -> 'addr -> unit val mcast_leave : ?ifname:string -> ?source:Inet_addr.t -> ('a, 'addr) t -> 'addr -> unit (** [bind_to_interface_exn t (`Interface_name "eth0")] restricts messages from being received or sent on interfaces other than [eth0]. See {!Linux_ext.bind_to_interface}. Typically, one would use this function for very specific non-multicast requirements. For similar functionality when using multicast, see {!Core_unix.mcast_set_ifname}. *) val bind_to_interface_exn : (([ `Unconnected ], Address.t) t -> Linux_ext.Bound_to_interface.t -> unit) Or_error.t end val bind_to_interface_exn : (Fd.t -> Linux_ext.Bound_to_interface.t -> unit) Or_error.t module Host : sig type t = Unix.Host.t = { name : string ; aliases : string array ; family : Protocol_family.t ; addresses : Inet_addr.t array } val getbyname : string -> t option Deferred.t val getbyname_exn : string -> t Deferred.t val getbyaddr : Inet_addr.t -> t option Deferred.t val getbyaddr_exn : Inet_addr.t -> t Deferred.t val have_address_in_common : t -> t -> bool end type socket_domain = Unix.socket_domain = | PF_UNIX | PF_INET | PF_INET6 [@@deriving bin_io, compare, hash, sexp] type socket_type = Unix.socket_type = | SOCK_STREAM | SOCK_DGRAM | SOCK_RAW | SOCK_SEQPACKET [@@deriving bin_io, compare, hash, sexp] type sockaddr = Unix.sockaddr = | ADDR_UNIX of string | ADDR_INET of Inet_addr.t * int [@@deriving bin_io, compare, sexp_of] (** [sockaddr_blocking_sexp] is like [sockaddr], with [of_sexp] that performs DNS lookup to resolve [Inet_addr.t]. *) type sockaddr_blocking_sexp = sockaddr [@@deriving bin_io, sexp] module Addr_info : sig type t = Unix.addr_info = { ai_family : socket_domain ; ai_socktype : socket_type ; ai_protocol : int ; ai_addr : sockaddr ; ai_canonname : string } [@@deriving bin_io, sexp_of] (** [Blocking_sexp] performs DNS lookup to resolve hostnames to IP addresses. *) module Blocking_sexp : sig type nonrec t = t [@@deriving bin_io, sexp] end type getaddrinfo_option = Unix.getaddrinfo_option = | AI_FAMILY of socket_domain | AI_SOCKTYPE of socket_type | AI_PROTOCOL of int | AI_NUMERICHOST | AI_CANONNAME | AI_PASSIVE [@@deriving bin_io, sexp] val get : ?service:string -> host:string -> getaddrinfo_option list -> t list Deferred.t end module Name_info : sig type t = Unix.name_info = { ni_hostname : string ; ni_service : string } [@@deriving bin_io, sexp] type getnameinfo_option = Unix.getnameinfo_option = | NI_NOFQDN | NI_NUMERICHOST | NI_NAMEREQD | NI_NUMERICSERV | NI_DGRAM [@@deriving bin_io, sexp] val get : sockaddr -> getnameinfo_option list -> t Deferred.t end (** The following functions correspond to the system calls of the same names. They can't block so they don't need to return a deferred. *) val gethostname : unit -> string val getuid : unit -> int val geteuid : unit -> int val getgid : unit -> int val getegid : unit -> int val setuid : int -> unit module Error = Unix.Error exception Unix_error of Error.t * string * string module Terminal_io : sig type t = Caml_unix.terminal_io = { mutable c_ignbrk : bool (** Ignore the break condition. *) ; mutable c_brkint : bool (** Signal interrupt on break condition. *) ; mutable c_ignpar : bool (** Ignore characters with parity errors. *) ; mutable c_parmrk : bool (** Mark parity errors. *) ; mutable c_inpck : bool (** Enable parity check on input. *) ; mutable c_istrip : bool (** Strip 8th bit on input characters. *) ; mutable c_inlcr : bool (** Map NL to CR on input. *) ; mutable c_igncr : bool (** Ignore CR on input. *) ; mutable c_icrnl : bool (** Map CR to NL on input. *) ; mutable c_ixon : bool (** Recognize XON/XOFF characters on input. *) ; mutable c_ixoff : bool (** Emit XON/XOFF chars to control input flow. *) ; mutable c_opost : bool (** Enable output processing. *) ; mutable c_obaud : int (** Output baud rate (0 means close connection).*) ; mutable c_ibaud : int (** Input baud rate. *) ; mutable c_csize : int (** Number of bits per character (5-8). *) ; mutable c_cstopb : int (** Number of stop bits (1-2). *) ; mutable c_cread : bool (** Reception is enabled. *) ; mutable c_parenb : bool (** Enable parity generation and detection. *) ; mutable c_parodd : bool (** Specify odd parity instead of even. *) ; mutable c_hupcl : bool (** Hang up on last close. *) ; mutable c_clocal : bool (** Ignore modem status lines. *) ; mutable c_isig : bool (** Generate signal on INTR, QUIT, SUSP. *) ; mutable c_icanon : bool (** Enable canonical processing (line buffering and editing) *) ; mutable c_noflsh : bool (** Disable flush after INTR, QUIT, SUSP. *) ; mutable c_echo : bool (** Echo input characters. *) ; mutable c_echoe : bool (** Echo ERASE (to erase previous character). *) ; mutable c_echok : bool (** Echo KILL (to erase the current line). *) ; mutable c_echonl : bool (** Echo NL even if c_echo is not set. *) ; mutable c_vintr : char (** Interrupt character (usually ctrl-C). *) ; mutable c_vquit : char (** Quit character (usually ctrl-\ ). *) ; mutable c_verase : char (** Erase character (usually DEL or ctrl-H). *) ; mutable c_vkill : char (** Kill line character (usually ctrl-U). *) ; mutable c_veof : char (** End-of-file character (usually ctrl-D). *) ; mutable c_veol : char (** Alternate end-of-line char. (usually none). *) ; mutable c_vmin : int (** Minimum number of characters to read before the read request is satisfied. *) ; mutable c_vtime : int (** Maximum read wait (in 0.1s units). *) ; mutable c_vstart : char (** Start character (usually ctrl-Q). *) ; mutable c_vstop : char (** Stop character (usually ctrl-S). *) } type setattr_when = Caml_unix.setattr_when = | TCSANOW | TCSADRAIN | TCSAFLUSH val tcgetattr : Fd.t -> t Deferred.t val tcsetattr : t -> Fd.t -> mode:setattr_when -> unit Deferred.t end (** Structure of entries in the [passwd] database. *) module Passwd : sig type t = Core_unix.Passwd.t = { name : string ; passwd : string ; uid : int ; gid : int ; gecos : string ; dir : string ; shell : string } [@@deriving fields, sexp] val getbyname : string -> t option Deferred.t val getbyname_exn : string -> t Deferred.t val getbyuid : int -> t option Deferred.t val getbyuid_exn : int -> t Deferred.t end (** Structure of entries in the [groups] database. *) module Group : sig type t = Core_unix.Group.t = { name : string ; passwd : string ; gid : int ; mem : string array } [@@deriving fields, sexp] val getbyname : string -> t option Deferred.t val getbyname_exn : string -> t Deferred.t val getbygid : int -> t option Deferred.t val getbygid_exn : int -> t Deferred.t end module Ifaddr = Core_unix.Ifaddr (** Gets the information using the socket-based netlink interface, which can block; see https://www.infradead.org/~tgr/libnl/doc/core.html. *) val getifaddrs : unit -> Ifaddr.t list Deferred.t (** Returns the login name of the user executing the process. This returns a deferred because the username may need to be looked up in what is essentially a database elsewhere on the network (winbound user, or NIS). *) val getlogin : unit -> string Deferred.t val wordexp : (?flags:[ `No_cmd | `Show_err | `Undef ] list -> string -> string array Deferred.t) Or_error.t module Private : sig (** [Wait] exposes some internals of the implementation of [wait] and [wait_untraced]. Those functions return a deferred that becomes determined when a particular child process exits. The implementation, by default, installs a signal handler for SIGCHLD that calls [check_all], which considers all undetermined wait results, calls [wait_nohang], and fills them in if appropriate. If OCaml is being used as a plugin in some other process that is already managing signals, e.g. in Ecaml, then we can't install a signal handler. So, we expose [do_not_handle_sigchld], which the plugin should call before any call to [wait], and will prevent the SIGCHLD handler from being installed. It is then the responsibility of the plugin to call [check_all] regularly, so that child processes created by Async are reaped and the corresponding deferreds become determined. *) module Wait : sig val check_all : unit -> unit val do_not_handle_sigchld : unit -> unit end end async_unix-0.15.0/src/writer.ml000066400000000000000000000024201420273305200164060ustar00rootroot00000000000000open Core open Import include Writer0 let of_pipe ?time_source info pipe_w = let%map `Reader reader_fd, `Writer writer_fd = Unix.pipe info in let reader = Reader.create reader_fd in let writer = create ?time_source writer_fd in if Debug.writer then Debug.log "Writer.of_pipe" (pipe_w, reader, writer) [%sexp_of: string Pipe.Writer.t * Reader.t * t]; (* Shuttle bytes from [reader] to [pipe_w]. If the user calls [close writer], then [reader] will see EOF, which will cause [transfer] to complete. If [pipe_w] is closed, then [transfer] will complete. *) let closed_and_flushed_downstream = let%bind () = Reader.transfer reader pipe_w in if raise_when_consumer_leaves writer && not (is_closed writer) then Monitor.send_exn (monitor writer) (Unix.Unix_error (EPIPE, "Writer.of_pipe", Sexp.to_string (Info.sexp_of_t info))); let%map (), () = Deferred.both (Reader.close reader) (close writer) in if not (Pipe.is_closed pipe_w) then Pipe.close pipe_w in writer, `Closed_and_flushed_downstream closed_and_flushed_downstream ;; module Private = struct let set_bytes_received t i = t.bytes_received <- i let set_bytes_written t i = t.bytes_written <- i module Check_buffer_age = Check_buffer_age end async_unix-0.15.0/src/writer.mli000066400000000000000000001035671420273305200165750ustar00rootroot00000000000000(** [Writer] is Async's main API for output to a file descriptor. It is the analog of [Core.Out_channel]. Each writer has an internal buffer, to which [Writer.write*] adds data. Each writer uses an Async cooperative thread that makes [write()] system calls to move the data from the writer's buffer to an OS buffer via the file descriptor. There is no guarantee that the data sync on the other side of the writer can keep up with the rate at which you are writing. If it cannot, the OS buffer will fill up and the writer's cooperative thread will be unable to send any bytes. In that case, calls to [Writer.write*] will grow the writer's buffer without bound, as long as your program produces data. One solution to this problem is to call [Writer.flushed] and not continue until that becomes determined, which will only happen once the bytes in the writer's buffer have been successfully transferred to the OS buffer. Another solution is to check [Writer.bytes_to_write] and not produce any more data if that is beyond some bound. There are two kinds of errors that one can handle with writers. First, a writer can be [close]d, which will cause future [write]s (and other operations) to synchronously raise an exception. Second, the writer's cooperative thread can fail due to a [write()] system call failing. This will cause an exception to be sent to the writer's monitor, which will be a child of the monitor in effect when the writer is created. One can deal with such asynchronous exceptions in the usual way, by handling the stream returned by [Monitor.detach_and_get_error_stream (Writer.monitor writer)]. *) open! Core open! Import module Id : Unique_id module Line_ending : sig type t = | Dos | Unix [@@deriving sexp_of] end type t [@@deriving sexp_of] include Invariant.S with type t := t (** Overall IO statistics for all writers. *) val io_stats : Io_stats.t (** [stdout] and [stderr] are writers for file descriptors 1 and 2. They are lazy because we don't want to create them in all programs that happen to link with Async. When either [stdout] or [stderr] is created, they both are created. Furthermore, if they point to the same inode, then they will be the same writer to [Fd.stdout]. This can be confusing, because [fd (force stderr)] will be [Fd.stdout], not [Fd.stderr]. And subsequent modifications of [Fd.stderr] will have no effect on [Writer.stderr]. Unfortunately, the sharing is necessary because Async uses OS threads to do [write()] syscalls using the writer buffer. When calling a program that redirects stdout and stderr to the same file, as in: {v foo.exe >/tmp/z.file 2>&1 v} if [Writer.stdout] and [Writer.stderr] weren't the same writer, then they could have threads simultaneously writing to the same file, which could easily cause data loss. *) val stdout : t Lazy.t val stderr : t Lazy.t type buffer_age_limit = [ `At_most of Time.Span.t | `Unlimited ] [@@deriving bin_io, sexp] (** [create ?buf_len ?syscall ?buffer_age_limit fd] creates a new writer. The file descriptor [fd] should not be in use for writing by anything else. By default, a write system call occurs at the end of a cycle in which bytes were written. One can supply [~syscall:(`Periodic span)] to get better performance. This batches writes together, doing the write system call periodically according to the supplied span. A writer can asynchronously fail if the underlying write syscall returns an error, e.g., [EBADF], [EPIPE], [ECONNRESET], .... [buffer_age_limit] specifies how backed up you can get before raising an exception. The default is [`Unlimited] for files, and 2 minutes for other kinds of file descriptors. You can supply [`Unlimited] to turn off buffer-age checks. [raise_when_consumer_leaves] specifies whether the writer should raise an exception when the consumer receiving bytes from the writer leaves, i.e., in Unix, the write syscall returns [EPIPE] or [ECONNRESET]. If [not raise_when_consumer_leaves], then the writer will silently drop all writes after the consumer leaves, and the writer will eventually fail with a writer-buffer-older-than error if the application remains open long enough. [line_ending] determines how [newline] and [write_line] terminate lines by default. If [line_ending = Unix] then end of line is ["\n"]; if [line_ending = Dos] then end of line is ["\r\n"]. Note that [line_ending = Dos] is not equivalent to opening the file in text mode because any "\n" characters being printed by other means (e.g., [write "\n"]) are still written verbatim (in Unix style). [time_source] is useful in tests to trigger [buffer_age_limit]-related conditions, or simply to have the result of (for example) [flushed_time_ns] agree with your test's synthetic time. It is also used to schedule the [`Periodic] syscalls. *) val create : ?buf_len:int -> ?syscall:[ `Per_cycle | `Periodic of Time.Span.t ] -> ?buffer_age_limit:buffer_age_limit -> ?raise_when_consumer_leaves:bool (** default is [true] *) -> ?line_ending:Line_ending.t (** default is [Unix] *) -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> Fd.t -> t val raise_when_consumer_leaves : t -> bool (** [set_raise_when_consumer_leaves t bool] sets the [raise_when_consumer_leaves] flag of [t], which determies how [t] responds to a write system call raising [EPIPE] and [ECONNRESET] (see [create]). *) val set_raise_when_consumer_leaves : t -> bool -> unit (** [set_buffer_age_limit t buffer_age_limit] replaces the existing buffer age limit with the new one. This is useful for stdout and stderr, which are lazily created in a context that does not allow applications to specify [buffer_age_limit]. *) val set_buffer_age_limit : t -> buffer_age_limit -> unit (** [consumer_left t] returns a deferred that becomes determined when [t] attempts to write to a pipe that broke because the consumer on the other side left. *) val consumer_left : t -> unit Deferred.t val of_out_channel : Out_channel.t -> Fd.Kind.t -> t (** [open_file file] opens [file] for writing and returns a writer for it. It uses [Unix_syscalls.openfile] to open the file. *) val open_file : ?info:Info.t (** for errors. Defaults to the file path. *) -> ?append:bool (** default is [false], meaning truncate instead *) -> ?buf_len:int -> ?syscall:[ `Per_cycle | `Periodic of Time.Span.t ] -> ?perm:int (** default is [0o666] *) -> ?line_ending:Line_ending.t (** default is [Unix] *) -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> string -> t Deferred.t (** [with_file ~file f] opens [file] for writing, creates a writer [t], and runs [f t] to obtain a deferred [d]. When [d] becomes determined, the writer is closed. When the close completes, the result of [with_file] becomes determined with the value of [d]. There is no need to call [Writer.flushed] to ensure that [with_file] waits for the writer to be flushed before closing it. [Writer.close] will already wait for the flush. [exclusive = true] uses a filesystem lock to try and make sure that the file is not modified during a concurrent read or write operation. This is an advisory lock, which means that the reader must be cooperating by taking a relevant lock when writing (see [Reader.with_file]). This is unrelated and should not be confused with the [O_EXCL] flag in [open] systemcall. Note that the implementation uses [Unix.lockf], which has known pitfalls. It's recommended that you avoid the [exclusive] flag in favor of using a library dedicated to dealing with file locks where the pitfalls can be documented in detail. *) val with_file : ?perm:int (** default is [0o666] *) -> ?append:bool (** default is [false], meaning truncate instead *) -> ?syscall:[ `Per_cycle | `Periodic of Time.Span.t ] -> ?exclusive:bool (** default is [false] *) -> ?line_ending:Line_ending.t (** default is [Unix] *) -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> string -> f:(t -> 'a Deferred.t) -> 'a Deferred.t (** [id] returns an id for this writer that is unique among all other writers. *) val id : t -> Id.t (** [fd] returns the [Fd.t] used to create this writer. *) val fd : t -> Fd.t (** [set_fd t fd] sets the [fd] used by [t] for its underlying system calls. It first waits until everything being sent to the current [fd] is flushed. Of course, one must understand how the writer works and what one is doing to use this. *) val set_fd : t -> Fd.t -> unit Deferred.t (** [write_gen t a] writes [a] to writer [t], with [length] specifying the number of bytes needed and [blit_to_bigstring] blitting [a] directly into the [t]'s buffer. If one has a type that has [length] and [blit_to_bigstring] functions, like: {[ module A : sig type t val length : t -> int val blit_to_bigstring : (t, Bigstring.t) Blit.blit end ]} then one can use [write_gen] to implement a custom analog of [Writer.write], like: {[ module Write_a : sig val write : ?pos:int -> ?len:int -> A.t -> Writer.t -> unit end = struct let write ?pos ?len a writer = Writer.write_gen ~length:A.length ~blit_to_bigstring:A.blit_to_bigstring ?pos ?len writer a end ]} In some cases it may be difficult to write only part of a value: {[ module B : sig type t val length : t -> int val blit_to_bigstring : t -> Bigstring.t -> pos:int -> unit end ]} In these cases, use [write_gen_whole] instead. It never requires writing only part of a value, although it is potentially less space-efficient. It may waste portions of previously-allocated write buffers if they are too small. {[ module Write_b : sig val write : B.t -> Writer.t -> unit end = struct let write b writer = Writer.write_gen_whole ~length:B.length ~blit_to_bigstring:B.blit_to_bigstring writer b end ]} Note: [write_gen] and [write_gen_whole] give you access to the writer's internal buffer. You should not capture it; doing so might lead to errors of the segfault kind. *) val write_gen : ?pos:int -> ?len:int -> t -> 'a -> blit_to_bigstring:('a, Bigstring.t) Blit.blit -> length:('a -> int) -> unit val write_gen_whole : t -> 'a -> blit_to_bigstring:('a -> Bigstring.t -> pos:int -> unit) -> length:('a -> int) -> unit (** [write_direct t ~f] gives [t]'s internal buffer to [f]. [pos] and [len] define the portion of the buffer that can be filled. [f] must return a pair [(x, written)] where [written] is the number of bytes written to the buffer at [pos]. [write_direct] raises if [written < 0 || written > len]. [write_direct] returns [Some x], or [None] if the writer is stopped. By using [write_direct] only, one can ensure that the writer's internal buffer never grows. Look at the [write_direct] expect tests for an example of how this can be used to construct a [write_string] like function that never grows the internal buffer. *) val write_direct : t -> f:(Bigstring.t -> pos:int -> len:int -> 'a * int) -> 'a option (** [write ?pos ?len t s] adds a job to the writer's queue of pending writes. The contents of the string are copied to an internal buffer before [write] returns, so clients can do whatever they want with [s] after that. *) val write_bytes : ?pos:int -> ?len:int -> t -> Bytes.t -> unit val write : ?pos:int -> ?len:int -> t -> string -> unit val write_bigstring : ?pos:int -> ?len:int -> t -> Bigstring.t -> unit val write_iobuf : ?pos:int -> ?len:int -> t -> ([> read ], _) Iobuf.t -> unit val write_substring : t -> Substring.t -> unit val write_bigsubstring : t -> Bigsubstring.t -> unit val writef : t -> ('a, unit, string, unit) format4 -> 'a (** [to_formatter] returns an OCaml-formatter that one can print to using {!Format.fprintf}. Note that flushing the formatter will only submit all buffered data to the writer, but does {e not} guarantee flushing to the operating system. *) val to_formatter : t -> Format.formatter (** [write_char t c] writes the character. *) val write_char : t -> char -> unit (** [newline t] writes the end-of-line terminator. [line_ending] can override [t]'s [line_ending]. *) val newline : ?line_ending:Line_ending.t -> t -> unit (** [write_line t s ?line_ending] is [write t s; newline t ?line_ending]. *) val write_line : ?line_ending:Line_ending.t -> t -> string -> unit (** [write_byte t i] writes one 8-bit integer (as the single character with that code). The given integer is taken modulo 256. *) val write_byte : t -> int -> unit module Terminate_with : sig type t = | Newline | Space_if_needed [@@deriving sexp_of] end (** [write_sexp t sexp] writes to [t] the string representation of [sexp], possibly followed by a terminating character as per [Terminate_with]. With [~terminate_with:Newline], the terminating character is a newline. With [~terminate_with:Space_if_needed], if a space is needed to ensure that the sexp reader knows that it has reached the end of the sexp, then the terminating character will be a space; otherwise, no terminating character is added. A terminating space is needed if the string representation doesn't end in [')'] or ['"']. *) val write_sexp : ?hum:bool (** default is [false] *) -> ?terminate_with:Terminate_with.t (** default is [Space_if_needed] *) -> t -> Sexp.t -> unit (** [write_bin_prot] writes out a value using its bin_prot sizer/writer pair. The format is the "size-prefixed binary protocol", in which the length of the data is written before the data itself. This is the format that [Reader.read_bin_prot] reads. *) val write_bin_prot : t -> 'a Bin_prot.Type_class.writer -> 'a -> unit (** Writes out a value using its bin_prot writer. Unlike [write_bin_prot], this doesn't prefix the output with the size of the bin_prot blob. [size] is the expected size. This function will raise if the bin_prot writer writes an amount other than [size] bytes. *) val write_bin_prot_no_size_header : t -> size:int -> 'a Bin_prot.Write.writer -> 'a -> unit (** Unlike the [write_] functions, all functions starting with [schedule_] require flushing or closing of the writer after returning before it is safe to modify the bigstrings which were directly or indirectly passed to these functions. The reason is that these bigstrings will be read from directly when writing; their contents is not copied to internal buffers. This is important if users need to send the same large data string to a huge number of clients simultaneously (e.g., on a cluster), because these functions then avoid needlessly exhausting memory by sharing the data. *) (** [schedule_bigstring t bstr] schedules a write of bigstring [bstr]. It is not safe to change the bigstring until the writer has been successfully flushed or closed after this operation. *) val schedule_bigstring : t -> ?pos:int -> ?len:int -> Bigstring.t -> unit val schedule_bigsubstring : t -> Bigsubstring.t -> unit (** [schedule_iobuf_peek] is like [schedule_bigstring], but for an iobuf. It is not safe to change the iobuf until the writer has been successfully flushed or closed after this operation. *) val schedule_iobuf_peek : t -> ?pos:int -> ?len:int -> ([> read ], _) Iobuf.t -> unit (** [schedule_iobuf_consume] is like [schedule_iobuf_peek]. Once the result is determined, the iobuf will be fully consumed (or advanced by [min len (Iobuf.length iobuf)] if [len] is specified), and the writer will be flushed. *) val schedule_iobuf_consume : t -> ?len:int -> ([> read ], Iobuf.seek) Iobuf.t -> unit Deferred.t module Destroy_or_keep : sig type t = | Destroy | Keep [@@deriving sexp_of] end (** [schedule_iovec t iovec] schedules a write of I/O-vector [iovec]. It is not safe to change the bigstrings underlying the I/O-vector until the writer has been successfully flushed or closed after this operation. *) val schedule_iovec : ?destroy_or_keep:Destroy_or_keep.t (** default is [Keep] *) -> t -> Bigstring.t Unix.IOVec.t -> unit (** [schedule_iovecs t iovecs] like {!schedule_iovec}, but takes a whole queue [iovecs] of I/O-vectors as argument. The queue is guaranteed to be empty when this function returns and can be modified. It is not safe to change the bigstrings underlying the I/O-vectors until the writer has been successfully flushed or closed after this operation. *) val schedule_iovecs : t -> Bigstring.t Unix.IOVec.t Queue.t -> unit module Flush_result : sig type t = | Error (** [Error] is accompanied by a detailed error being sent to the writer's monitor. *) | Consumer_left (** [Consumer_left] is returned when the consumer leaves (see {!consumer_left}) and {!raise_when_consumer_leaves} is set to [false]. If that flag is set to [true], then you get an [Error] instead. *) | Flushed of Time_ns.t (** The time just after the [write()] system call returned or the time [flushed_*] was called if all the writes were already flushed by then. *) [@@deriving sexp_of] end (** [flushed_or_failed_with_result t] returns a deferred that will become determined when all prior writes complete (i.e. the [write()] system call returns), or when any of them fail. Handling the [Error] case can be tricky due to the following race: the result gets determined concurrently with the exception propagation through the writer's monitor. The caller needs to make sure that the program behavior does not depend on which signal propagates first. *) val flushed_or_failed_with_result : t -> Flush_result.t Deferred.t (** [flushed_or_failed_unit t] returns a deferred that will become determined when all prior writes complete, or when any of them fail. Unlike {!flushed_or_failed_with_result}, its return value gives you no indication of which happened. In the [Error] case, the result will be determined in parallel with the error propagating to the writer's monitor. The caller should robustly handle either side winning that race. *) val flushed_or_failed_unit : t -> unit Deferred.t (** [flushed t] returns a deferred that will become determined when all prior writes complete (i.e. the [write()] system call returns). If a prior write fails, then the deferred will never become determined. It is OK to call [flushed t] after [t] has been closed. *) val flushed : t -> unit Deferred.t val flushed_time : t -> Time.t Deferred.t val flushed_time_ns : t -> Time_ns.t Deferred.t (** [fsync t] calls [flushed t] before calling [Unix.fsync] on the underlying file descriptor *) val fsync : t -> unit Deferred.t (** [fdatasync t] calls [flushed t] before calling [Unix.fdatasync] on the underlying file descriptor *) val fdatasync : t -> unit Deferred.t (** [send] writes a string to the writer that can be read back using [Reader.recv]. *) val send : t -> string -> unit (** [monitor t] returns the writer's monitor. *) val monitor : t -> Monitor.t (** [close ?force_close t] waits for the writer to be flushed, and then calls [Unix.close] on the underlying file descriptor. [force_close] causes the [Unix.close] to happen even if the flush hangs. By default [force_close] is [Deferred.never ()] for files and [after (sec 5)] for other types of file descriptors (e.g., sockets). If the close is forced, data in the writer's buffer may not be written to the file descriptor. You can check this by calling [bytes_to_write] after [close] finishes. WARNING: [force_close] will not reliably stop any write that is in progress. If there are any in-flight system calls, it will wait for them to finish, which includes [writev], which can legitimately block forever. [close] will raise an exception if the [Unix.close] on the underlying file descriptor fails. You must call [close] on a writer in order to close the underlying file descriptor. Not doing so will cause a file descriptor leak. It also will cause a space leak, because until the writer is closed, it is held on to in order to flush the writer on shutdown. It is an error to call other operations on [t] after [close t] has been called, except that calls of [close] subsequent to the original call to [close] will return the same deferred as the original call. [close_started t] becomes determined as soon as [close] is called. [close_finished t] becomes determined after [t]'s underlying file descriptor has been closed, i.e., it is the same as the result of [close]. [close_finished] differs from [close] in that it does not have the side effect of initiating a close. [is_closed t] returns [true] iff [close t] has been called. [is_open t] is [not (is_closed t)] [with_close t ~f] runs [f ()], and closes [t] after [f] finishes or raises. *) val close : ?force_close:unit Deferred.t -> t -> unit Deferred.t val close_started : t -> unit Deferred.t val close_finished : t -> unit Deferred.t val is_closed : t -> bool val is_open : t -> bool val with_close : t -> f:(unit -> 'a Deferred.t) -> 'a Deferred.t (** [can_write t] returns [true] if calls to [write*] functions on [t] are allowed. If [is_open t] then [can_write t]. But one can have [is_closed t] and [can_write t], during the time after [close t] before closing has finished. *) val can_write : t -> bool (** Errors raised within the writer can stop the background job that flushes out the writer's buffers. [is_stopped_permanently] returns [true] when the background job has stopped. [stopped_permanently] becomes determined when the background job has stopped. *) val is_stopped_permanently : t -> bool val stopped_permanently : t -> unit Deferred.t (** In addition to flushing its internal buffer prior to closing, a writer keeps track of producers that are feeding it data, so that when [Writer.close] is called, it does the following: + requests that the writer's producers flush their data to it + flushes the writer's internal buffer + calls [Unix.close] on the writer's underlying file descriptor [with_flushed_at_close t ~flushed ~f] calls [f] and adds [flushed] to the set of producers that should be flushed-at-close, for the duration of [f]. *) val with_flushed_at_close : t -> flushed:(unit -> unit Deferred.t) -> f:(unit -> 'a Deferred.t) -> 'a Deferred.t (** [bytes_to_write t] returns how many bytes have been requested to write but have not yet been written. *) val bytes_to_write : t -> int (** [bytes_written t] returns how many bytes have been written. *) val bytes_written : t -> Int63.t (** [bytes_received t] returns how many bytes have been received by the writer. As long as the writer is running, [bytes_received = bytes_written + bytes_to_write]. *) val bytes_received : t -> Int63.t (** [with_file_atomic ?temp_file ?perm ?fsync ?replace_special file ~f] creates a writer to a temp file, feeds that writer to [f], and when the result of [f] becomes determined, atomically moves (using [Unix.rename]) the temp file to [file]. If [file] currently exists and is a regular file (see below regarding [replace_special]) it will be replaced, even if it is read-only. The temp file will be [file] (or [temp_file] if supplied) suffixed by a unique random sequence of six characters. The temp file will be removed if an exception is raised to the monitor of [f] before the result of [f] becomes determined. However, if the program exits for some other reason, the temp file may not be cleaned up; so it may be prudent to choose a temp file that can be easily found by cleanup tools. If [fsync] is [true], the temp file will be flushed to disk before it takes the place of the target file, thus guaranteeing that the target file will always be in a sound state, even after a machine crash. Since synchronization is extremely slow, this is not the default. Think carefully about the event of machine crashes and whether you may need this option! If [replace_special] is [false] (the default) an existing special [file] (block or character device, socket or FIFO) will not be replaced by a regular file, the temporary file is not created and an exception is raised. To explicitly replace an existing special [file], [replace_special] must be passed as [true]. Note that if [file] exists and is a directory, the rename will fail; if [file] exists and is a symbolic link, the link will be replaced, not the target (as per [Unix.rename]). We intend for [with_file_atomic] to mimic the behavior of the [open] system call, so if [file] does not exist, we will apply the current umask to [perm] (the effective permissions become [perm land lnot umask], see [man 2 open]). However, if [file] does exist and [perm] is specified, we do something different from [open] system call: we override the permission with [perm], ignoring the umask. This means that if you create and then immediately overwrite the file with [with_file_atomic ~perm], then the umask will be honored the first time and ignored the second time. If [perm] is not specified, then any existing file permissions are preserved. If [f] closes the writer passed to it, [with_file_atomic] raises and does not create [file]. *) val with_file_atomic : ?temp_file:string -> ?perm:Unix.file_perm -> ?fsync:bool (** default is [false] *) -> ?replace_special:bool (** default is [false] *) -> ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> string -> f:(t -> 'a Deferred.t) -> 'a Deferred.t (** [save] is a special case of [with_file_atomic] that atomically writes the given string to the specified file. *) val save : ?temp_file:string -> ?perm:Unix.file_perm -> ?fsync:bool (** default is [false] *) -> ?replace_special:bool (** default is [false] *) -> string -> contents:string -> unit Deferred.t (** [save_lines file lines] writes all lines in [lines] to [file], with each line followed by a newline. *) val save_lines : ?temp_file:string -> ?perm:Unix.file_perm -> ?fsync:bool (** default is [false] *) -> ?replace_special:bool (** default is [false] *) -> string -> string list -> unit Deferred.t (** [save_sexp] is a special case of [with_file_atomic] that atomically writes the given sexp to the specified file. [save_sexp t sexp] writes [sexp] to [t], followed by a newline. To read a file produced using [save_sexp], one would typically use [Reader.load_sexp], which deals with the additional whitespace and works nicely with converting the sexp to a value. *) val save_sexp : ?temp_file:string -> ?perm:Unix.file_perm -> ?fsync:bool (** default is [false] *) -> ?replace_special:bool (** default is [false] *) -> ?hum:bool (** default is [true] *) -> string -> Sexp.t -> unit Deferred.t (** [save_sexps] works similarly to [save_sexp], but saves a sequence of sexps instead, separated by newlines. There is a corresponding [Reader.load_sexps] for reading back in. *) val save_sexps : ?temp_file:string -> ?perm:Unix.file_perm -> ?fsync:bool (** default is [false] *) -> ?replace_special:bool (** default is [false] *) -> ?hum:bool (** default is [true] *) -> string -> Sexp.t list -> unit Deferred.t (** [save_sexps_conv] is like [save_sexps], but converts to sexps internally, one at a time. This avoids allocating the list of sexps up front, which can be costly. The default values of the parameters are the same as [save_sexps]. *) val save_sexps_conv : ?temp_file:string -> ?perm:int -> ?fsync:bool (** default is [false] *) -> ?replace_special:bool (** default is [false] *) -> ?hum:bool -> string -> 'a list -> ('a -> Sexp.t) -> unit Deferred.t (** [save_bin_prot t bin_writer 'a] is a special case of [with_file_atomic] that writes ['a] to [t] using its bin_writer, in the size-prefixed format, like [write_bin_prot]. To read a file produced using [save_bin_prot], one would typically use [Reader.load_bin_prot]. *) val save_bin_prot : ?temp_file:string -> ?perm:Unix.file_perm -> ?fsync:bool (** default is [false] *) -> ?replace_special:bool (** default is [false] *) -> string -> 'a Bin_prot.Type_class.writer -> 'a -> unit Deferred.t (** [transfer' t pipe_r f] repeatedly reads values from [pipe_r] and feeds them to [f], which should in turn write them to [t]. It provides pushback to [pipe_r] by not reading when [t] cannot keep up with the data being pushed in. By default, each read from [pipe_r] reads all the values in [pipe_r]. One can supply [max_num_values_per_read] to limit the number of values per read. The [transfer'] stops and the result becomes determined when [stop] becomes determined, when [pipe_r] reaches its EOF, when [t] is closed, or when [t]'s consumer leaves. In the latter two cases, [transfer'] closes [pipe_r]. [transfer'] causes [Pipe.flushed] on [pipe_r]'s writer to ensure that the bytes have been flushed to [t] before returning. It also waits on [Pipe.upstream_flushed] at shutdown. [transfer t pipe_r f] is equivalent to: {[ transfer' t pipe_r (fun q -> Queue.iter q ~f; return ()) ]} *) val transfer' : ?stop:unit Deferred.t -> ?max_num_values_per_read:int -> t -> 'a Pipe.Reader.t -> ('a Queue.t -> unit Deferred.t) -> unit Deferred.t val transfer : ?stop:unit Deferred.t -> ?max_num_values_per_read:int -> t -> 'a Pipe.Reader.t -> ('a -> unit) -> unit Deferred.t (** [pipe t] returns the writing end of a pipe attached to [t] that pushes back when [t] cannot keep up with the data being pushed in. Closing the pipe does not close [t]. *) val pipe : t -> string Pipe.Writer.t (** [of_pipe info pipe_w] returns a writer [t] such that data written to [t] will appear on [pipe_w]. If either [t] or [pipe_w] are closed, the other is closed as well. [of_pipe] is implemented by attaching [t] to the write-end of a Unix pipe, and shuttling bytes from the read-end of the Unix pipe to [pipe_w]. *) val of_pipe : ?time_source:[> read ] Time_source.T1.t (** default is [Time_source.wall_clock ()] *) -> Info.t -> string Pipe.Writer.t -> (t * [ `Closed_and_flushed_downstream of unit Deferred.t ]) Deferred.t (** [behave_nicely_in_pipeline ~writers ()] causes the program to silently exit with status 0 if any of the consumers of [writers] go away. It also sets the buffer age to unlimited, in case there is a human (e.g., using [less]) on the other side of the pipeline. This can be called at the toplevel of a program, before [Command.run] for instance. (this function doesn't start the async scheduler). *) val behave_nicely_in_pipeline : ?writers:t list (** defaults to [stdout; stderr] *) -> unit -> unit (** [set_synchronous_out_channel t out_channel] waits until [byte_to_write t = 0], and then mutates [t] so that all future writes to [t] synchronously call [Out_channel.output*] functions to send data to the OS immediately. [set_synchronous_out_channel] is used by expect tests to ensure that the interleaving between calls to [Core.printf] (and similar IO functions) and [Async.printf] generates output with the same interleaving. [set_synchronous_out_channel] is idempotent. *) val set_synchronous_out_channel : t -> Out_channel.t -> unit Deferred.t (** [using_synchronous_backing_out_channel t = true] if writes to [t] are being done synchronously, e.g., due to [set_synchronous_out_channel], [set_synchronous_backing_out_channel], [use_synchronous_stdout_and_stderr]. *) val using_synchronous_backing_out_channel : t -> bool (** [clear_synchronous_out_channel t] restores [t] to its normal state, with the background writer asynchronously feeding data to the OS. [clear_synchronous_out_channel] is idempotent. *) val clear_synchronous_out_channel : t -> unit val with_synchronous_out_channel : t -> Out_channel.t -> f:(unit -> 'a Deferred.t) -> 'a Deferred.t (** [use_synchronous_stdout_and_stderr ()] causes all subsequent writes to stdout and stderr to occur synchronously (after any pending writes have flushed). This ensures [printf]-family writes happen immediately, which avoids two common sources of confusion: {ul {li unexpected interleaving of [Core.printf] and [Async.printf] calls; and} {li [Async.printf] calls that don't get flushed before an application exits}} The disadvantages are: {ul {li this makes writes blocking, which can delay unrelated asynchronous jobs until the consumer stops pushing back; and} {li the errors raised by write are different and it won't respect {!behave_nicely_in_pipeline} anymore}} *) val use_synchronous_stdout_and_stderr : unit -> unit Deferred.t (** [Backing_out_channel] generalizes [Out_channel] to a narrow interface that can be used to collect strings, etc. *) module Backing_out_channel : sig type t [@@deriving sexp_of] val create : output_char:(char -> unit) -> output_chars:(bigstring -> len:int -> unit) -> flush:(unit -> unit) -> sexp:(unit -> Sexp.t) -> t val of_out_channel : Out_channel.t -> t val of_output_char : (char -> unit) -> t end val set_synchronous_backing_out_channel : t -> Backing_out_channel.t -> unit Deferred.t val with_synchronous_backing_out_channel : t -> Backing_out_channel.t -> f:(unit -> 'a Deferred.t) -> 'a Deferred.t (**/**) module Private : sig val set_bytes_received : t -> Int63.t -> unit val set_bytes_written : t -> Int63.t -> unit module Check_buffer_age : sig module Internal_for_unit_test : sig val check_now : check_invariants:bool -> time_source:Time_source.t -> unit val num_active_checks_for : Time_source.t -> int option end end end async_unix-0.15.0/src/writer0.ml000066400000000000000000001747241420273305200165070ustar00rootroot00000000000000open Core open Import open Require_explicit_time_source module Unix = Unix_syscalls module IOVec = Core_unix.IOVec module Id = Unique_id.Int63 () let io_stats = Io_stats.create () let debug = Debug.writer module Time_ns_suppress_sexp_in_test = struct type t = Time_ns.t let sexp_of_t t = if am_running_inline_test then Sexp.List [] else Time_ns.sexp_of_t t end module Flush_result = struct type t = | Error | Consumer_left | Flushed of Time_ns_suppress_sexp_in_test.t [@@deriving sexp_of] end module Line_ending = struct type t = | Dos | Unix [@@deriving sexp_of] end module Check_buffer_age' = struct type 'a t = { writer : 'a ; maximum_age : Time_ns.Span.t ; mutable bytes_received_at_now_minus_maximum_age : Int63.t ; (* The 2 following queues hold the not-yet-written bytes received by the writer in the last [maximum_age] period of time, with the time they were received at. [Queue.length bytes_received_queue = Queue.length times_received_queue]. *) bytes_received_queue : Int63.t Queue.t ; times_received_queue : Time_ns.t Queue.t ; (* Number of bytes "seen" by the checker. [t.writer.bytes_received - t.bytes_seen] represents the number of bytes received by the writer since the last time the checker ran. *) mutable bytes_seen : Int63.t ; (* The buffer-age check is responsible for filling in [too_old] if it detects an age violation. *) mutable too_old : unit Ivar.t ; (* The buffer-age checks are stored in one of these data structures per time source, and we keep a reference to our parent one in this [t] so we can easily remove ourselves from it when closing the writer. *) for_this_time_source : 'a per_time_source } and 'a per_time_source = { active_checks : ('a t[@sexp.opaque]) Bag.t ; closed : unit Ivar.t } [@@deriving fields, sexp_of] end module Open_flags = Unix.Open_flags type open_flags = [ `Already_closed | `Ok of Open_flags.t | `Error of exn ] [@@deriving sexp_of] module Backing_out_channel = Backing_out_channel module Destroy_or_keep = struct type t = | Destroy | Keep [@@deriving sexp_of] end module Scheduled = struct type t = (Bigstring.t IOVec.t * Destroy_or_keep.t) Deque.t let length (t : t) = Deque.fold t ~init:0 ~f:(fun n (iovec, _) -> n + iovec.len) end module Stop_reason = struct type t = | Error | (* [Consumer_left] is only reported when [raise_when_consumer_leaves = false], otherwise an [Error] is reported. *) Consumer_left [@@deriving sexp_of] end type t = { id : Id.t ; mutable fd : Fd.t ; (* The writer uses a background job to flush data. The job runs within [inner_monitor], which has a handler that wraps all errors to include [sexp_of_t t], and sends them to [monitor]. *) monitor : Monitor.t ; inner_monitor : Monitor.t ; mutable background_writer_state : [ `Running | `Not_running | `Stopped_permanently of Stop_reason.t ] ; background_writer_stopped : unit Ivar.t ; (* [syscall] determines the batching approach that the writer uses to batch data together and flush it using the underlying write syscall. *) syscall : [ `Per_cycle | `Periodic of Time.Span.t ] ; (* Counts since the writer was created. *) mutable bytes_received : Int63.t ; mutable bytes_written : Int63.t ; (* Bytes that we have received but not yet written are stored in two places: [scheduled] and [buf]. The bytes that we need to write are the concatenation of the sequence of iovecs in [scheduled] followed by the bytes in [buf] from [scheduled_back] to [back]. Note that iovecs in [scheduled] can point to regions in [buf], even the current [buf] in the writer. *) (* [scheduled] holds iovecs that we plan to write. *) scheduled : Scheduled.t ; (* [scheduled_bytes] is the sum of the lengths of the iovecs in[scheduled] *) mutable scheduled_bytes : int ; (* [buf] has three regions: [0, scheduled_back) received and scheduled [scheduled_back, back) received but not scheduled [back, Bigstring.length buf) free space*) mutable buf : Bigstring.t ; mutable scheduled_back : int ; mutable back : int ; time_source : Time_source.t ; flushes : (Flush_result.t Ivar.t * Int63.t) Queue.t ; (* [closed_state] tracks the state of the writer as it is being closed. Initially, [closed_state] is [`Open]. When [close] is called, [closed_state] transitions to [`Closed_and_flushing]. Once the writer is flushed and we're actually going to close [fd], it transitions to[`Closed]. The distinction between [`Closed] and [`Closed_and_flushing] is necessary because we want to allow [write]s to happen while [`Closed_and_flushing], but not when [`Closed]. This is necessary to allow upstream producers to flush their data to the writer when it is closed. *) mutable close_state : [ `Open | `Closed_and_flushing | `Closed ] ; (* [close_finished] is filled when the close() system call on [fd] finishes. *) close_finished : unit Ivar.t ; (* [close_started] is filled when [close] is called. *) close_started : unit Ivar.t ; (* [producers_to_flush_at_close] holds all upstream producers feeding data to this writer, and thus should be flushed when we close this writer, before flushing the writer itself. *) producers_to_flush_at_close : (unit -> unit Deferred.t) Bag.t ; (* [flush_at_shutdown_elt] holds the element in [writers_to_flush_at_shutdown] for this writer. Being in that bag is what causes this writer to be automatically closed when [shutdown] is called, and for shutdown to wait for the close to finish. [flush_at_shutdown_elt] is [Some] for the lifetime of the writer, until the close finishes, at which point it transitions to[None]. *) mutable flush_at_shutdown_elt : t Bag.Elt.t option ; mutable check_buffer_age : t Check_buffer_age'.t Bag.Elt.t option ; (* The "consumer" of a writer is whomever is reading the bytes that the writer is writing. E.g. if the writer's file descriptor is a socket, then it is whomever is on the other side of the socket connection. If the consumer leaves, Unix will indicate this by returning EPIPE or ECONNRESET to a write() syscall. We keep track of this with the [consumer_left] ivar, which is exposed in writer.mli. We also allow the user to configure what action the writer takes when the consumer leaves. By default, it raises, but that can be disabled. *) consumer_left : unit Ivar.t ; mutable raise_when_consumer_leaves : bool (* default is [true] *) ; (* [open_flags] is the open-file-descriptor bits of [fd]. [open_flags] is used to report an error when [fd] is not writable. *) open_flags : open_flags ; line_ending : Line_ending.t ; (* If specified, subsequent writes are synchronously redirected here. *) mutable backing_out_channel : Backing_out_channel.t option } [@@deriving fields] let sexp_of_t t = [%sexp (t.fd : Fd.t_hum)] type t_internals = t let sexp_of_t_internals { id ; fd ; monitor ; inner_monitor ; background_writer_state ; background_writer_stopped ; syscall ; bytes_received ; bytes_written ; scheduled = _ ; scheduled_bytes ; buf = _ ; scheduled_back ; back ; time_source ; flushes = _ ; close_state ; close_finished ; close_started ; producers_to_flush_at_close ; flush_at_shutdown_elt ; check_buffer_age ; consumer_left ; raise_when_consumer_leaves ; open_flags ; line_ending ; backing_out_channel } = let suppress_in_test x = if am_running_inline_test then None else Some x in let monitor_name_in_test monitor = if am_running_inline_test then [%sexp (Monitor.name monitor : Info.t)] else [%sexp (monitor : Monitor.t)] in let time_source = if phys_equal time_source (Time_source.wall_clock ()) then None else Some time_source in (* [open_flags] are non-deterministic across CentOS versions and have been suppressed in tests. Linux kernels (CentOS 6) expose O_CLOEXEC via fcntl(fd, F_GETFL), but newer (CentOS 7) ones don't *) [%sexp { id = (suppress_in_test id : (Id.t option[@sexp.option])) ; fd = (suppress_in_test fd : (Fd.t option[@sexp.option])) ; monitor = (monitor_name_in_test monitor : Sexp.t) ; inner_monitor = (monitor_name_in_test inner_monitor : Sexp.t) ; background_writer_state : [ `Running | `Not_running | `Stopped_permanently of Stop_reason.t ] ; background_writer_stopped : unit Ivar.t ; syscall : [ `Per_cycle | `Periodic of Time.Span.t ] ; bytes_received : Int63.t ; bytes_written : Int63.t ; scheduled_bytes : int ; scheduled_back : int ; back : int ; time_source : (Time_source.t option[@sexp.option]) ; close_state : [ `Open | `Closed_and_flushing | `Closed ] ; close_finished : unit Ivar.t ; close_started : unit Ivar.t ; num_producers_to_flush_at_close = (Bag.length producers_to_flush_at_close : int) ; flush_at_shutdown_elt = (suppress_in_test flush_at_shutdown_elt : ((t[@sexp.opaque]) Bag.Elt.t option option [@sexp.option])) ; check_buffer_age = (suppress_in_test check_buffer_age : ((t[@sexp.opaque]) Check_buffer_age'.t Bag.Elt.t option option [@sexp.option])) ; consumer_left : unit Ivar.t ; raise_when_consumer_leaves : bool ; open_flags = (suppress_in_test open_flags : (open_flags option[@sexp.option])) ; line_ending : Line_ending.t ; backing_out_channel : (Backing_out_channel.t option[@sexp.option]) }] ;; type writer = t [@@deriving sexp_of] let set_raise_when_consumer_leaves t bool = t.raise_when_consumer_leaves <- bool let bytes_to_write t = t.scheduled_bytes + t.back - t.scheduled_back let is_stopped_permanently t = match t.background_writer_state with | `Stopped_permanently _ -> true | `Running | `Not_running -> false ;; let invariant t : unit = try let check f field = f (Field.get field t) in Fields.iter ~id:ignore ~fd:ignore ~monitor:ignore ~inner_monitor:ignore ~buf:ignore ~background_writer_state: (check (function | `Stopped_permanently _ -> assert (bytes_to_write t = 0); assert (Ivar.is_full t.background_writer_stopped) | `Running | `Not_running -> assert (Bigstring.length t.buf > 0); assert ( Int63.(t.bytes_received - t.bytes_written = of_int (bytes_to_write t))); assert (Ivar.is_empty t.background_writer_stopped))) ~background_writer_stopped:ignore ~syscall:ignore ~bytes_written: (check (fun bytes_written -> assert (Int63.(zero <= bytes_written && bytes_written <= t.bytes_received)))) ~bytes_received:ignore ~scheduled: (check (fun (scheduled : Scheduled.t) -> Deque.iter scheduled ~f:(fun (iovec, kind) -> if phys_equal t.buf iovec.buf then assert ( match kind with | Keep -> true | Destroy -> false)))) ~scheduled_bytes: (check (fun scheduled_bytes -> assert (scheduled_bytes = Scheduled.length t.scheduled))) ~scheduled_back: (check (fun scheduled_back -> assert (0 <= scheduled_back && scheduled_back <= t.back))) ~back:(check (fun back -> assert (back <= Bigstring.length t.buf))) ~time_source:ignore ~flushes:ignore ~close_state:ignore ~close_finished: (check (fun close_finished -> match t.close_state with | `Open | `Closed_and_flushing -> assert (Ivar.is_empty close_finished) | `Closed -> ())) ~close_started: (check (fun close_started -> [%test_result: bool] (Ivar.is_empty close_started) ~expect: (match t.close_state with | `Open -> true | `Closed | `Closed_and_flushing -> false))) ~producers_to_flush_at_close:ignore ~flush_at_shutdown_elt: (check (fun o -> assert (Bool.equal (is_none o) (Ivar.is_full t.close_finished)); Option.iter o ~f:(fun elt -> assert (phys_equal t (Bag.Elt.value elt))))) ~check_buffer_age:ignore ~consumer_left: (check (fun consumer_left -> if Ivar.is_full consumer_left then assert (is_stopped_permanently t))) ~raise_when_consumer_leaves:ignore ~open_flags:ignore ~line_ending:ignore ~backing_out_channel:(check (Option.invariant Backing_out_channel.invariant)) with | exn -> raise_s [%message "writer invariant failed" (exn : exn) ~writer:(t : t_internals)] ;; module Check_buffer_age : sig type t = writer Check_buffer_age'.t Bag.Elt.t option val dummy : t val create : writer -> maximum_age:[ `At_most of Time.Span.t | `Unlimited ] -> t val destroy : t -> unit val too_old : t -> unit Deferred.t module Internal_for_unit_test : sig val check_now : check_invariants:bool -> time_source:Time_source.t -> unit val num_active_checks_for : Time_source.t -> int option end end = struct open Check_buffer_age' type t = writer Check_buffer_age'.t Bag.Elt.t option let elt_invariant t : unit = Invariant.invariant [%here] t [%sexp_of: _ t] (fun () -> let check f field = f (Field.get field t) in assert (Queue.length t.bytes_received_queue = Queue.length t.times_received_queue); Fields.iter ~writer:ignore ~maximum_age:ignore ~too_old: (check (fun ivar -> let imply a b = (not a) || b in assert ( imply Int63.O.( t.bytes_received_at_now_minus_maximum_age > t.writer.bytes_written) (Ivar.is_full ivar)))) ~bytes_received_queue: (check (fun q -> let n = Queue.fold q ~init:t.bytes_received_at_now_minus_maximum_age ~f:(fun prev count -> assert (Int63.( < ) prev count); count) in assert (Int63.( <= ) n t.writer.bytes_received); assert (Int63.( = ) n t.bytes_seen))) ~times_received_queue: (check (fun q -> match Queue.to_list q with | [] -> () | times -> [%test_result: Time_ns.t list] ~expect:times (List.sort times ~compare:Time_ns.compare); assert ( Time_ns.Span.( <= ) (Time_ns.diff (List.last_exn times) (List.hd_exn times)) t.maximum_age))) ~bytes_received_at_now_minus_maximum_age:ignore ~bytes_seen:ignore ~for_this_time_source:ignore) ;; let dummy = None (* [sync] prunes history by removing all the entries from [*_received_queue]s that correspond to bytes already written or times older than [now - time_received]. *) let rec sync e ~now = if not (Queue.is_empty e.bytes_received_queue) then ( let bytes_received = Queue.peek_exn e.bytes_received_queue in let time_received = Queue.peek_exn e.times_received_queue in let bytes_are_written = Int63.( <= ) bytes_received e.writer.bytes_written in let bytes_are_too_old = Time_ns.Span.( > ) (Time_ns.diff now time_received) e.maximum_age in if bytes_are_too_old then e.bytes_received_at_now_minus_maximum_age <- bytes_received; if bytes_are_written || bytes_are_too_old then ( ignore (Queue.dequeue_exn e.bytes_received_queue : Int63.t); ignore (Queue.dequeue_exn e.times_received_queue : Time_ns.t); sync e ~now)) ;; module Per_time_source = struct type t = writer Check_buffer_age'.per_time_source let process_active_check e = let now = Time_source.now e.writer.time_source in sync e ~now; let bytes_received = e.writer.bytes_received in let bytes_written = e.writer.bytes_written in if Int63.O.(bytes_received > e.bytes_seen) then ( e.bytes_seen <- bytes_received; if Int63.O.(bytes_received > bytes_written) then ( Queue.enqueue e.bytes_received_queue e.writer.bytes_received; Queue.enqueue e.times_received_queue now)); let too_old = Int63.O.(e.bytes_received_at_now_minus_maximum_age > bytes_written) in match Ivar.is_full e.too_old, too_old with | true, true | false, false -> () | true, false -> e.too_old <- Ivar.create () | false, true -> Ivar.fill e.too_old (); let writer = e.writer in (* [Monitor.send_exn] enqueues jobs but does not run user code, and so cannot modify [e]. *) Monitor.send_exn e.writer.monitor (Exn.create_s [%message "writer buffer has data older than" ~maximum_age:(e.maximum_age : Time_ns.Span.t) ~beginning_of_buffer: (Bigstring.to_string writer.buf ~pos:0 ~len:(Int.min 1024 (Bigstring.length writer.buf)) : string) (writer : writer)]) ;; let create () = { active_checks = Bag.create (); closed = Ivar.create () } let check t = Bag.iter t.active_checks ~f:process_active_check let internal_check_now_for_unit_test t ~check_invariants = if check_invariants then Bag.iter t.active_checks ~f:elt_invariant; check t ;; end module Time_source_key = Hashable.Make_plain (struct type t = Time_source.t [@@deriving sexp_of] let hash_fold_t state t = Time_source.Id.hash_fold_t state (Time_source.id t) let hash t = Time_source.Id.hash (Time_source.id t) let compare t1 t2 = Time_source.Id.compare (Time_source.id t1) (Time_source.id t2) end) (* [by_time_source] holds the set of [Per_time_source.t]'s with nonempty [active_checks]. *) let by_time_source : Per_time_source.t Time_source_key.Table.t = Time_source_key.Table.create () ;; module Internal_for_unit_test = struct let num_active_checks_for time_source = Option.map (Hashtbl.find by_time_source time_source) ~f:(fun pt -> Bag.length pt.active_checks) ;; let check_now ~check_invariants ~time_source = Per_time_source.internal_check_now_for_unit_test (Hashtbl.find_exn by_time_source time_source) ~check_invariants ;; end let create writer ~maximum_age = match maximum_age with | `Unlimited -> None | `At_most maximum_age -> let time_source = writer.time_source in let for_this_time_source = Hashtbl.find_or_add by_time_source time_source ~default:(fun () -> let pt = Per_time_source.create () in Time_source.every time_source Time_ns.Span.second ~stop:(Ivar.read pt.closed) ~continue_on_error:false (fun () -> Per_time_source.check pt); pt) in Some (Bag.add for_this_time_source.active_checks { writer ; bytes_received_queue = Queue.create () ; times_received_queue = Queue.create () ; maximum_age = Time_ns.Span.of_span_float_round_nearest maximum_age ; bytes_seen = Int63.zero ; bytes_received_at_now_minus_maximum_age = Int63.zero ; too_old = Ivar.create () ; for_this_time_source }) ;; let destroy t = match t with | None -> () | Some elt -> let t = Bag.Elt.value elt in let per_time_source = t.for_this_time_source in Bag.remove per_time_source.active_checks elt; if Bag.is_empty per_time_source.active_checks then ( Hashtbl.remove by_time_source t.writer.time_source; Ivar.fill_if_empty per_time_source.closed ()) ;; let too_old t = match t with | None -> Deferred.never () | Some elt -> Ivar.read (Bag.Elt.value elt).too_old ;; end let flushed_or_failed_with_result t = match t.backing_out_channel with | Some backing_out_channel -> Backing_out_channel.flush backing_out_channel; return (Flush_result.Flushed (Time_source.now t.time_source)) | None -> if Int63.O.(t.bytes_written = t.bytes_received) then return (Flush_result.Flushed (Time_source.now t.time_source)) else ( match t.background_writer_state with | `Stopped_permanently Error -> return Flush_result.Error | `Stopped_permanently Consumer_left -> return Flush_result.Consumer_left | `Running | `Not_running -> if Ivar.is_full t.close_finished then Deferred.return Flush_result.Error else Deferred.create (fun ivar -> Queue.enqueue t.flushes (ivar, t.bytes_received))) ;; let eager_map t ~f = if Deferred.is_determined t then return (f (Deferred.value_exn t)) else Deferred.map t ~f ;; let eager_bind t ~f = if Deferred.is_determined t then f (Deferred.value_exn t) else Deferred.bind t ~f ;; let flushed_or_failed_unit t = eager_map (flushed_or_failed_with_result t) ~f:ignore let flushed_time_ns t = eager_bind (flushed_or_failed_with_result t) ~f:(function | Flushed t -> Deferred.return t | Error | Consumer_left -> Deferred.never ()) ;; let flushed_time t = eager_map (flushed_time_ns t) ~f:Time_ns.to_time_float_round_nearest let flushed t = (* even though we don't promise any eagerness, there are tests in the tree that depend on it *) eager_map (flushed_time_ns t) ~f:(ignore : Time_ns.t -> unit) ;; let set_backing_out_channel t backing_out_channel = t.backing_out_channel <- Some backing_out_channel ;; let set_synchronous_backing_out_channel t backing_out_channel = let rec wait_until_no_bytes_to_write () = if bytes_to_write t = 0 then ( set_backing_out_channel t backing_out_channel; return ()) else ( let%bind () = flushed t in wait_until_no_bytes_to_write ()) in wait_until_no_bytes_to_write () ;; let set_synchronous_out_channel t out_channel = set_synchronous_backing_out_channel t (Backing_out_channel.of_out_channel out_channel) ;; let using_synchronous_backing_out_channel t = Option.is_some t.backing_out_channel let clear_synchronous_out_channel t = if is_some t.backing_out_channel then ( assert (bytes_to_write t = 0); t.backing_out_channel <- None) ;; let with_synchronous_backing_out_channel t backing_out_channel ~f = let saved_backing_out_channel = t.backing_out_channel in (* This code will flush a bit more eagerly than it needs to if [with_synchronous_backing_out_channel t oc] is called recursively on the same [t] and [oc]. The flush is caused by [set_synchronous_backing_out_channel]. In theory this could happen but in practice is exceedingly unlikely. *) Monitor.protect ~run:`Schedule ~rest:`Log (fun () -> let%bind () = set_synchronous_backing_out_channel t backing_out_channel in f ()) ~finally:(fun () -> t.backing_out_channel <- saved_backing_out_channel; return ()) ;; let with_synchronous_out_channel t out_channel ~f = with_synchronous_backing_out_channel t ~f (Backing_out_channel.of_out_channel out_channel) ;; let set_fd t fd = let%map () = flushed t in t.fd <- fd ;; let consumer_left t = Ivar.read t.consumer_left let close_finished t = Ivar.read t.close_finished let close_started t = Ivar.read t.close_started let is_closed t = match t.close_state with | `Open -> false | `Closed | `Closed_and_flushing -> true ;; let is_open t = not (is_closed t) let writers_to_flush_at_shutdown : t Bag.t = Bag.create () let final_flush ?force t = let producers_flushed = (* Note that each element of [producers_to_flush_at_close] checks that the upstream producer is flushed, which includes checking that [t] itself is flushed once the producer has written everything to [t]. So, there is no need to call [flushed t] after the producer is flushed. *) Deferred.List.iter ~how:`Parallel ~f:(fun f -> f ()) (Bag.to_list t.producers_to_flush_at_close) in let force = match force with | Some fc -> fc | None -> (* We used to use [after (sec 5.)] as the default value for [force] for all kinds of underlying fds. This was problematic, because it silently caused data in the writer's buffer to be dropped when it kicked in. We care about data getting out only for the files, when we want to get data to disk. When we close socket writers, we usually just want to drop the connection, so using [after (sec 5.)] makes sense. *) (match Fd.kind t.fd with | File -> Deferred.never () | Char | Fifo | Socket _ -> Time_source.after t.time_source (Time_ns.Span.of_sec 5.)) in Deferred.any_unit [ (* If the consumer leaves, there's no more writing we can do. *) consumer_left t ; Deferred.all_unit [ producers_flushed; flushed t ] ; force ; (* The buffer-age check might fire while we're waiting. *) Check_buffer_age.too_old t.check_buffer_age ] ;; let close ?force_close t = if debug then Debug.log "Writer.close" t [%sexp_of: t]; (match t.close_state with | `Closed_and_flushing | `Closed -> () | `Open -> t.close_state <- `Closed_and_flushing; Ivar.fill t.close_started (); final_flush t ?force:force_close >>> fun () -> t.close_state <- `Closed; Check_buffer_age.destroy t.check_buffer_age; (match t.flush_at_shutdown_elt with | None -> assert false | Some elt -> Bag.remove writers_to_flush_at_shutdown elt); Unix.close t.fd >>> fun () -> Ivar.fill t.close_finished ()); close_finished t ;; let () = Shutdown.at_shutdown (fun () -> if debug then Debug.log_string "Writer.at_shutdown"; Deferred.List.iter ~how:`Parallel (Bag.to_list writers_to_flush_at_shutdown) ~f:(fun t -> Deferred.any_unit [ final_flush t; close_finished t ])) ;; let fill_flushes { bytes_written; flushes; time_source; _ } = if not (Queue.is_empty flushes) then ( let now = Time_source.now time_source in let rec loop () = match Queue.peek flushes with | None -> () | Some (ivar, z) -> if Int63.(z <= bytes_written) then ( Ivar.fill ivar (Flush_result.Flushed now); ignore (Queue.dequeue flushes : (Flush_result.t Ivar.t * Int63.t) option); loop ()) in loop ()) ;; let stop_permanently t (outcome : Stop_reason.t) = t.background_writer_state <- `Stopped_permanently outcome; Deque.clear t.scheduled; t.scheduled_bytes <- 0; t.buf <- Bigstring.create 0; t.scheduled_back <- 0; t.back <- 0; Ivar.fill_if_empty t.background_writer_stopped (); Queue.iter t.flushes ~f:(fun (ivar, _) -> Ivar.fill ivar (match outcome with | Error -> Flush_result.Error | Consumer_left -> Flush_result.Consumer_left)); Queue.clear t.flushes ;; let stopped_permanently t = Ivar.read t.background_writer_stopped let die t sexp = stop_permanently t Error; raise_s sexp ;; type buffer_age_limit = [ `At_most of Time.Span.t | `Unlimited ] [@@deriving bin_io, sexp] let create ?buf_len ?(syscall = `Per_cycle) ?buffer_age_limit ?(raise_when_consumer_leaves = true) ?(line_ending = Line_ending.Unix) ?time_source fd = let time_source = match time_source with | Some x -> Time_source.read_only x | None -> Time_source.wall_clock () in let buffer_age_limit = match buffer_age_limit with | Some z -> z | None -> (match Fd.kind fd with | File -> `Unlimited | Char | Fifo | Socket _ -> `At_most (Time.Span.of_min 2.)) in let buf_len = match buf_len with | None -> 65 * 1024 * 2 (* largest observed single write call * 2 *) | Some buf_len -> if buf_len <= 0 then invalid_arg "Writer.create: buf_len <= 0" else buf_len in let id = Id.create () in let monitor = Monitor.create () ?name:(if am_running_inline_test then Some "Writer.monitor" else None) in let inner_monitor = Monitor.create () ?name:(if am_running_inline_test then Some "Writer.inner_monitor" else None) in let consumer_left = Ivar.create () in let open_flags = Fd.syscall fd (fun file_descr -> Core_unix.fcntl_getfl file_descr) in let t = { id ; fd ; syscall ; monitor ; inner_monitor ; buf = Bigstring.create buf_len ; back = 0 ; scheduled_back = 0 ; scheduled = Deque.create () ; scheduled_bytes = 0 ; bytes_received = Int63.zero ; bytes_written = Int63.zero ; time_source ; flushes = Queue.create () ; background_writer_state = `Not_running ; background_writer_stopped = Ivar.create () ; close_state = `Open ; close_finished = Ivar.create () ; close_started = Ivar.create () ; producers_to_flush_at_close = Bag.create () ; flush_at_shutdown_elt = None ; check_buffer_age = Check_buffer_age.dummy ; consumer_left ; raise_when_consumer_leaves ; open_flags ; line_ending ; backing_out_channel = None } in Monitor.detach_and_iter_errors inner_monitor ~f:(fun (exn : Exn.t) -> Monitor.send_exn monitor (Exn.create_s [%message "Writer error from inner_monitor" ~_:(Monitor.extract_exn exn : Exn.t) ~writer:(t : t)])); t.check_buffer_age <- Check_buffer_age.create t ~maximum_age:buffer_age_limit; t.flush_at_shutdown_elt <- Some (Bag.add writers_to_flush_at_shutdown t); t ;; let set_buffer_age_limit t maximum_age = Check_buffer_age.destroy t.check_buffer_age; t.check_buffer_age <- Check_buffer_age.create t ~maximum_age ;; let of_out_channel oc kind = create (Fd.of_out_channel oc kind) let can_write t = match t.close_state with | `Open | `Closed_and_flushing -> true | `Closed -> false ;; let ensure_can_write t = if not (can_write t) then raise_s [%message "attempt to use closed writer" ~_:(t : t)] ;; let open_file ?info ?(append = false) ?buf_len ?syscall ?(perm = 0o666) ?line_ending ?time_source file = (* Writing to NFS needs the [`Trunc] flag to avoid leaving extra junk at the end of a file. *) let mode = [ `Wronly; `Creat ] in let mode = (if append then `Append else `Trunc) :: mode in Unix.openfile ?info file ~mode ~perm >>| create ?buf_len ?syscall ?line_ending ?time_source ;; let with_close t ~f = Monitor.protect ~run:`Schedule ~rest:`Log f ~finally:(fun () -> close t) ;; let with_writer_exclusive t f = let%bind () = Unix.lockf t.fd Exclusive in Monitor.protect ~run:`Schedule ~rest:`Log f ~finally:(fun () -> let%map () = flushed t in Unix.unlockf t.fd) ;; let with_file ?perm ?append ?syscall ?(exclusive = false) ?line_ending ?time_source file ~f = let%bind t = open_file ?perm ?append ?syscall ?line_ending ?time_source file in with_close t ~f:(fun () -> if exclusive then with_writer_exclusive t (fun () -> f t) else f t) ;; let got_bytes t n = t.bytes_received <- Int63.(t.bytes_received + of_int n) let add_iovec t kind (iovec : _ IOVec.t) ~count_bytes_as_received = assert (t.scheduled_back = t.back); if count_bytes_as_received then got_bytes t iovec.len; if not (is_stopped_permanently t) then ( t.scheduled_bytes <- t.scheduled_bytes + iovec.len; Deque.enqueue_back t.scheduled (iovec, kind)); assert (t.scheduled_back = t.back) ;; let schedule_unscheduled t kind = let need_to_schedule = t.back - t.scheduled_back in assert (need_to_schedule >= 0); if need_to_schedule > 0 then ( let pos = t.scheduled_back in t.scheduled_back <- t.back; add_iovec t kind (IOVec.of_bigstring t.buf ~pos ~len:need_to_schedule) ~count_bytes_as_received:false (* they were already counted *)) ;; let dummy_iovec = IOVec.empty IOVec.bigstring_kind let mk_iovecs t = schedule_unscheduled t Keep; let n_iovecs = Int.min (Deque.length t.scheduled) (Lazy.force IOVec.max_iovecs) in let iovecs = Array.create ~len:n_iovecs dummy_iovec in let contains_mmapped_ref = ref false in let iovecs_len = ref 0 in with_return (fun r -> let i = ref 0 in Deque.iter t.scheduled ~f:(fun (iovec, _) -> if !i >= n_iovecs then r.return (); if (not !contains_mmapped_ref) && Bigstring.is_mmapped iovec.buf then contains_mmapped_ref := true; iovecs_len := !iovecs_len + iovec.len; iovecs.(!i) <- iovec; incr i)); iovecs, !contains_mmapped_ref, !iovecs_len ;; (* Size of I/O- or blit operation for which a helper thread should be used. This number (a power of two) is somewhat empirically motivated, but there is no reason why it should be the best. *) let thread_io_cutoff = 262_144 let is_running = function | `Running -> true | _ -> false ;; (* If the writer was closed, we should be quiet. But if it wasn't, then someone was monkeying around with the fd behind our back, and we should complain. *) let fd_closed t = if not (is_closed t) then die t [%message "writer fd unexpectedly closed "] ;; let rec start_write t = if debug then Debug.log "Writer.start_write" t [%sexp_of: t]; assert (is_running t.background_writer_state); let iovecs, contains_mmapped, iovecs_len = mk_iovecs t in let handle_write_result = function | `Already_closed -> fd_closed t | `Ok n -> if n >= 0 then write_finished t n else die t [%message "write system call returned negative result" (n : int)] | `Error (Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _)) -> write_when_ready t | `Error (Unix.Unix_error (EBADF, _, _)) -> die t [%message "write got EBADF"] | `Error (Unix.Unix_error ( ( EPIPE | ECONNRESET | EHOSTUNREACH | ENETDOWN | ENETRESET | ENETUNREACH | ETIMEDOUT ) , _ , _ ) as exn) -> (* [t.consumer_left] is empty since once we reach this point, we stop the writer permanently, and so will never reach here again. *) assert (Ivar.is_empty t.consumer_left); Ivar.fill t.consumer_left (); if t.raise_when_consumer_leaves then ( stop_permanently t Error; raise exn) else stop_permanently t Consumer_left | `Error exn -> die t [%message "" ~_:(exn : Exn.t)] in let should_write_in_thread = (not (Fd.supports_nonblock t.fd)) (* Though the write will not block in this case, a memory-mapped bigstring in an I/O-vector may cause a page fault, which would cause the async scheduler thread to block. So, we write in a separate thread, and the [Bigstring.writev] releases the OCaml lock, allowing the async scheduler thread to continue. *) || iovecs_len > thread_io_cutoff || contains_mmapped in if should_write_in_thread then Fd.syscall_in_thread t.fd ~name:"writev" (fun file_descr -> Bigstring_unix.writev file_descr iovecs) >>> handle_write_result else handle_write_result (Fd.syscall t.fd ~nonblocking:true (fun file_descr -> Bigstring_unix.writev_assume_fd_is_nonblocking file_descr iovecs)) and write_when_ready t = if debug then Debug.log "Writer.write_when_ready" t [%sexp_of: t]; assert (is_running t.background_writer_state); Fd.ready_to t.fd `Write >>> function | `Bad_fd -> die t [%message "writer ready_to got Bad_fd"] | `Closed -> fd_closed t | `Ready -> start_write t and write_finished t bytes_written = if debug then Debug.log "Writer.write_finished" (bytes_written, t) [%sexp_of: int * t]; assert (is_running t.background_writer_state); let int63_bytes_written = Int63.of_int bytes_written in Io_stats.update io_stats ~kind:(Fd.kind t.fd) ~bytes:int63_bytes_written; t.bytes_written <- Int63.(int63_bytes_written + t.bytes_written); if Int63.(t.bytes_written > t.bytes_received) then die t [%message "writer wrote more bytes than it received"]; fill_flushes t; t.scheduled_bytes <- t.scheduled_bytes - bytes_written; (* Remove processed iovecs from t.scheduled. *) let rec remove_done bytes_written = assert (bytes_written >= 0); match Deque.dequeue_front t.scheduled with | None -> if bytes_written > 0 then die t [%message "writer wrote nonzero amount but IO_queue is empty"] | Some ({ buf; pos; len }, kind) -> if bytes_written >= len then ( (* Current I/O-vector completely written. Internally generated buffers get destroyed immediately unless they are still in use for buffering. *) (match kind with | Destroy -> Bigstring.unsafe_destroy buf | Keep -> ()); remove_done (bytes_written - len)) else ( (* Partial I/O: update partially written I/O-vector and retry I/O. *) let new_iovec = IOVec.of_bigstring buf ~pos:(pos + bytes_written) ~len:(len - bytes_written) in Deque.enqueue_front t.scheduled (new_iovec, kind)) in remove_done bytes_written; (* See if there's anything else to do. *) schedule_unscheduled t Keep; if Deque.is_empty t.scheduled then ( t.back <- 0; t.scheduled_back <- 0; t.background_writer_state <- `Not_running) else ( match t.syscall with | `Per_cycle -> start_write t | `Periodic span -> Time_source.after t.time_source (Time_ns.Span.of_span_float_round_nearest span) >>> fun _ -> start_write t) ;; let maybe_start_writer t = match t.background_writer_state with | `Stopped_permanently _ | `Running -> () | `Not_running -> if bytes_to_write t > 0 then ( t.background_writer_state <- `Running; (* We schedule the background writer thread to run with low priority, so that it runs at the end of the cycle and that all of the calls to Writer.write will usually be batched into a single system call. *) schedule ~monitor:t.inner_monitor ~priority:Priority.low (fun () -> let open_flags = t.open_flags in let can_write_fd = match open_flags with | `Error _ | `Already_closed -> false | `Ok flags -> Unix.Open_flags.can_write flags in if not can_write_fd then (* The reason we produce a custom error message in this case is that Linux conflates this case with "not a valid file descriptor" (EBADF), which normally indicates a serious bug in file descriptor handling. *) die t [%message "not allowed to write due to file-descriptor flags" (open_flags : open_flags)]; start_write t)) ;; let give_buf t desired = assert (desired > 0); assert (not (is_stopped_permanently t)); got_bytes t desired; let buf_len = Bigstring.length t.buf in let available = buf_len - t.back in if desired <= available then ( (* Data fits into buffer *) let pos = t.back in t.back <- t.back + desired; t.buf, pos) else if (* Preallocated buffer too small; schedule buffered writes. We create a new buffer of exactly the desired size if the desired size is more than half the buffer length. If we only created a new buffer when the desired size was greater than the buffer length, then multiple consecutive writes of slightly more than half the buffer length would each waste slightly less than half of the buffer. Although, it is still the case that multiple consecutive writes of slightly more than one quarter of the buffer length will waste slightly less than one quarter of the buffer. *) desired > buf_len / 2 then ( schedule_unscheduled t Keep; (* Preallocation size too small; allocate dedicated buffer *) let buf = Bigstring.create desired in add_iovec t Destroy (IOVec.of_bigstring ~len:desired buf) ~count_bytes_as_received:false; (* we already counted them above *) buf, 0) else ( schedule_unscheduled t Destroy; (* Preallocation size sufficient; preallocate new buffer *) let buf = Bigstring.create buf_len in t.buf <- buf; t.scheduled_back <- 0; t.back <- desired; buf, 0) ;; (* If [blit_to_bigstring] raises, [write_gen_unchecked] may leave some unexpected bytes in the bigstring. However it leaves [t.back] and [t.bytes_received] in agreement. *) let write_gen_internal (type a) t src ~src_pos ~src_len ~allow_partial_write ~(blit_to_bigstring : (a, Bigstring.t) Blit.blit) = if is_stopped_permanently t then got_bytes t src_len else ( match t.backing_out_channel with | Some backing_out_channel -> got_bytes t src_len; Backing_out_channel.output backing_out_channel ~blit_to_bigstring ~src ~src_len ~src_pos; t.bytes_written <- Int63.(t.bytes_written + of_int src_len) | None -> let available = Bigstring.length t.buf - t.back in if available >= src_len then ( got_bytes t src_len; let dst_pos = t.back in t.back <- dst_pos + src_len; blit_to_bigstring ~src ~src_pos ~len:src_len ~dst:t.buf ~dst_pos) else if allow_partial_write then ( got_bytes t available; let dst_pos = t.back in t.back <- dst_pos + available; blit_to_bigstring ~src ~src_pos ~len:available ~dst:t.buf ~dst_pos; let remaining = src_len - available in let dst, dst_pos = give_buf t remaining in blit_to_bigstring ~src ~src_pos:(src_pos + available) ~len:remaining ~dst ~dst_pos) else ( let dst, dst_pos = give_buf t src_len in blit_to_bigstring ~src ~src_pos ~dst ~dst_pos ~len:src_len); maybe_start_writer t) ;; let write_direct t ~f = if is_stopped_permanently t then None else ( let pos = t.back in let len = Bigstring.length t.buf - pos in let x, written = f t.buf ~pos ~len in if written < 0 || written > len then raise_s [%message "[write_direct]'s [~f] argument returned invalid [written]" (written : int) (len : int) ~writer:(t : t)]; t.back <- pos + written; got_bytes t written; maybe_start_writer t; Some x) ;; let write_gen_unchecked ?pos ?len t src ~blit_to_bigstring ~length = let src_pos, src_len = Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length src) in write_gen_internal t src ~src_pos ~src_len ~allow_partial_write:true ~blit_to_bigstring ;; let write_gen_whole_unchecked t src ~blit_to_bigstring ~length = let src_len = length src in write_gen_internal t src ~src_pos:0 ~src_len ~allow_partial_write:false ~blit_to_bigstring:(fun ~src ~src_pos ~dst ~dst_pos ~len -> assert (src_pos = 0); assert (len = src_len); blit_to_bigstring src dst ~pos:dst_pos) ;; let write_bytes ?pos ?len t src = write_gen_unchecked ?pos ?len t src ~blit_to_bigstring:Bigstring.From_bytes.blit ~length:Bytes.length ;; let write ?pos ?len t src = write_gen_unchecked ?pos ?len t src ~blit_to_bigstring:Bigstring.From_string.blit ~length:String.length ;; let write_bigstring ?pos ?len t src = write_gen_unchecked ?pos ?len t src ~blit_to_bigstring:Bigstring.blit ~length:Bigstring.length ;; let write_iobuf ?pos ?len t iobuf = let iobuf = Iobuf.read_only (Iobuf.no_seek iobuf) in write_gen_unchecked ?pos ?len t iobuf ~blit_to_bigstring:Iobuf.Peek.To_bigstring.blit ~length:Iobuf.length ;; let write_substring t substring = write_bytes t (Substring.base substring) ~pos:(Substring.pos substring) ~len:(Substring.length substring) ;; let write_bigsubstring t bigsubstring = write_bigstring t (Bigsubstring.base bigsubstring) ~pos:(Bigsubstring.pos bigsubstring) ~len:(Bigsubstring.length bigsubstring) ;; let writef t = ksprintf (fun s -> write t s) let write_gen ?pos ?len t src ~blit_to_bigstring ~length = try write_gen_unchecked ?pos ?len t src ~blit_to_bigstring ~length with | exn -> die t [%message "Writer.write_gen: error writing value" (exn : exn)] ;; let write_gen_whole t src ~blit_to_bigstring ~length = try write_gen_whole_unchecked t src ~blit_to_bigstring ~length with | exn -> die t [%message "Writer.write_gen_whole: error writing value" (exn : exn)] ;; let to_formatter t = Format.make_formatter (fun str pos len -> let str = Bytes.of_string str in ensure_can_write t; write_substring t (Substring.create str ~pos ~len)) ignore ;; let write_char t c = if is_stopped_permanently t then got_bytes t 1 else ( (* Check for the common case that the char can simply be put in the buffer. *) match t.backing_out_channel with | Some backing_out_channel -> got_bytes t 1; Backing_out_channel.output_char backing_out_channel c; t.bytes_written <- Int63.(t.bytes_written + of_int 1) | None -> if Bigstring.length t.buf - t.back >= 1 then ( got_bytes t 1; t.buf.{t.back} <- c; t.back <- t.back + 1) else ( let dst, dst_pos = give_buf t 1 in dst.{dst_pos} <- c); maybe_start_writer t) ;; let newline ?line_ending t = let line_ending = match line_ending with | Some x -> x | None -> t.line_ending in (match line_ending with | Unix -> () | Dos -> write_char t '\r'); write_char t '\n' ;; let write_line ?line_ending t s = write t s; newline t ?line_ending ;; let write_byte t i = write_char t (char_of_int (i % 256)) module Terminate_with = struct type t = | Newline | Space_if_needed [@@deriving sexp_of] end let write_sexp_internal = let initial_size = 10 * 1024 in let buffer = lazy (Buffer.create initial_size) in let blit_str = ref (Bytes.create 0) in fun ~(terminate_with : Terminate_with.t) ?(hum = false) t sexp -> let buffer = Lazy.force buffer in Buffer.clear buffer; if hum then Sexp.to_buffer_hum ~buf:buffer ~indent:!Sexp.default_indent sexp else Sexp.to_buffer ~buf:buffer sexp; let len = Buffer.length buffer in let blit_str_len = Bytes.length !blit_str in if len > blit_str_len then blit_str := Bytes.create (max len (max initial_size (2 * blit_str_len))); Buffer.blit ~src:buffer ~src_pos:0 ~dst:!blit_str ~dst_pos:0 ~len; write_bytes t !blit_str ~len; match terminate_with with | Newline -> newline t | Space_if_needed -> (* If the string representation doesn't start/end with paren or double quote, we add a space after it to ensure that the parser can recognize the end of the sexp. *) let c = Bytes.get !blit_str 0 in if not Char.O.(c = '(' || c = '"') then write_char t ' ' ;; let write_sexp ?hum ?(terminate_with = Terminate_with.Space_if_needed) t sexp = write_sexp_internal t sexp ?hum ~terminate_with ;; let write_bin_prot t (writer : _ Bin_prot.Type_class.writer) v = let len = writer.size v in assert (len > 0); let tot_len = len + Bin_prot.Utils.size_header_length in if is_stopped_permanently t then got_bytes t tot_len else ( let buf, start_pos = give_buf t tot_len in ignore (Bigstring.write_bin_prot buf ~pos:start_pos writer v : int); maybe_start_writer t) ;; let write_bin_prot_no_size_header t ~size write v = if is_stopped_permanently t then got_bytes t size else ( let buf, start_pos = give_buf t size in let end_pos = write buf ~pos:start_pos v in let written = end_pos - start_pos in if written <> size then raise_s [%message "Writer.write_bin_prot_no_size_header bug!" (written : int) (size : int)]; maybe_start_writer t) ;; let send t s = write t (string_of_int (String.length s) ^ "\n"); write t s ;; let schedule_iovec ?(destroy_or_keep = Destroy_or_keep.Keep) t iovec = schedule_unscheduled t Keep; add_iovec t destroy_or_keep iovec ~count_bytes_as_received:true; maybe_start_writer t ;; let schedule_iovecs t iovecs = schedule_unscheduled t Keep; Queue.iter iovecs ~f:(add_iovec t Keep ~count_bytes_as_received:true); Queue.clear iovecs; maybe_start_writer t ;; let schedule_bigstring ?destroy_or_keep t ?pos ?len bstr = schedule_iovec t (IOVec.of_bigstring ?pos ?len bstr) ?destroy_or_keep ;; let schedule_bigsubstring t bigsubstring = schedule_bigstring t (Bigsubstring.base bigsubstring) ~pos:(Bigsubstring.pos bigsubstring) ~len:(Bigsubstring.length bigsubstring) ;; let schedule_iobuf_peek t ?pos ?len iobuf = schedule_iovec t (Iobuf_unix.Expert.to_iovec_shared ?pos ?len iobuf) ;; let schedule_iobuf_consume t ?len iobuf = let iovec = Iobuf_unix.Expert.to_iovec_shared ?len iobuf in let len = iovec.len in schedule_iovec t iovec; let%map _ = flushed_time t in Iobuf.advance iobuf len ;; (* The code below ensures that no calls happen on a closed writer. *) let fsync t = ensure_can_write t; let%bind () = flushed t in Unix.fsync t.fd ;; let fdatasync t = ensure_can_write t; let%bind () = flushed t in Unix.fdatasync t.fd ;; let write_bin_prot t sw_arg v = ensure_can_write t; write_bin_prot t sw_arg v ;; let send t s = ensure_can_write t; send t s ;; let schedule_iovec ?destroy_or_keep t iovec = ensure_can_write t; schedule_iovec ?destroy_or_keep t iovec ;; let schedule_iovecs t iovecs = ensure_can_write t; schedule_iovecs t iovecs ;; let schedule_bigstring t ?pos ?len bstr = ensure_can_write t; schedule_bigstring t ?pos ?len bstr ;; let schedule_bigsubstring t bigsubstring = ensure_can_write t; schedule_bigsubstring t bigsubstring ;; let schedule_iobuf_peek t ?pos ?len iobuf = ensure_can_write t; schedule_iobuf_peek t ?pos ?len iobuf ;; let schedule_iobuf_consume t ?len iobuf = ensure_can_write t; schedule_iobuf_consume t ?len iobuf ;; let write_gen ?pos ?len t src ~blit_to_bigstring ~length = ensure_can_write t; write_gen ?pos ?len t src ~blit_to_bigstring ~length ;; let write_bytes ?pos ?len t s = ensure_can_write t; write_bytes ?pos ?len t s ;; let write ?pos ?len t s = ensure_can_write t; write ?pos ?len t s ;; let write_line ?line_ending t s = ensure_can_write t; write_line t s ?line_ending ;; let writef t = ensure_can_write t; writef t ;; let write_sexp ?hum ?terminate_with t s = ensure_can_write t; write_sexp ?hum ?terminate_with t s ;; let write_iobuf ?pos ?len t iobuf = ensure_can_write t; write_iobuf ?pos ?len t iobuf ;; let write_bigstring ?pos ?len t src = ensure_can_write t; write_bigstring ?pos ?len t src ;; let write_bigsubstring t s = ensure_can_write t; write_bigsubstring t s ;; let write_substring t s = ensure_can_write t; write_substring t s ;; let write_byte t b = ensure_can_write t; write_byte t b ;; let write_char t c = ensure_can_write t; write_char t c ;; let newline ?line_ending t = ensure_can_write t; newline ?line_ending t ;; let stdout_and_stderr_behave_nicely_in_pipeline = ref ignore let stdout_and_stderr = lazy (* We [create] the writers inside [Monitor.main] so that it is their monitors' parent. *) (match Scheduler.within_v ~monitor:Monitor.main (fun () -> let stdout = Fd.stdout () in let stderr = Fd.stderr () in let t = create stdout in let dev_and_ino fd = let stats = Core_unix.fstat (Fd.file_descr_exn fd) in stats.st_dev, stats.st_ino in match am_test_runner with | true -> (* In tests, we use synchronous output to improve determinism, especially when mixing libraries that use Core and Async printing. *) set_backing_out_channel t (Backing_out_channel.of_out_channel Out_channel.stdout); t, t | false -> let stdout, stderr = if [%compare.equal: int * int] (dev_and_ino stdout) (dev_and_ino stderr) then (* If stdout and stderr point to the same file, we must share a single writer between them. See the comment in writer.mli for details. *) t, t else t, create stderr in !stdout_and_stderr_behave_nicely_in_pipeline stdout; !stdout_and_stderr_behave_nicely_in_pipeline stderr; stdout, stderr) with | None -> raise_s [%message [%here] "unable to create stdout/stderr"] | Some v -> v) ;; let stdout = lazy (fst (Lazy.force stdout_and_stderr)) let stderr = lazy (snd (Lazy.force stdout_and_stderr)) let use_synchronous_stdout_and_stderr () = let stdout, stderr = Lazy.force stdout_and_stderr in let ts_and_channels = (stdout, Out_channel.stdout) :: (* We only set [stderr] if it is distinct from [stdout]. *) (match phys_equal stdout stderr with | true -> [] | false -> [ stderr, Out_channel.stderr ]) in List.map ts_and_channels ~f:(fun (t, out_channel) -> set_synchronous_out_channel t out_channel) |> Deferred.all_unit ;; (* This test is here rather than in a [test] directory because we want it to run immediately after [stdout] and [stderr] are defined, so that they haven't yet been forced. *) let%expect_test "stdout and stderr are always the same in tests" = print_s [%message (Lazy.is_val stdout : bool)]; [%expect {| ("Lazy.is_val stdout" false) |}]; print_s [%message (Lazy.is_val stderr : bool)]; [%expect {| ("Lazy.is_val stderr" false) |}]; let module U = Core_unix in let saved_stderr = U.dup U.stderr in (* Make sure fd 1 and 2 have different inodes at the point that we force them. *) let pipe_r, pipe_w = U.pipe () in U.dup2 ~src:pipe_w ~dst:U.stderr (); U.close pipe_r; U.close pipe_w; let stdout = Lazy.force stdout in let stderr = Lazy.force stderr in U.dup2 ~src:saved_stderr ~dst:U.stderr (); U.close saved_stderr; print_s [%message (phys_equal stdout stderr : bool)]; [%expect {| ("phys_equal stdout stderr" true) |}] ;; let make_writer_behave_nicely_in_pipeline writer = set_buffer_age_limit writer `Unlimited; set_raise_when_consumer_leaves writer false; don't_wait_for (let%map () = consumer_left writer in Shutdown.shutdown 0) ;; let behave_nicely_in_pipeline ?writers () = match writers with | Some l -> List.iter l ~f:make_writer_behave_nicely_in_pipeline | None -> if Lazy.is_val stdout_and_stderr then ( let stdout, stderr = force stdout_and_stderr in List.iter [ stdout; stderr ] ~f:make_writer_behave_nicely_in_pipeline) else (* Forcing the lazy would initialize the scheduler, which would make calls to Scheduler.go_main raise. Avoid that, so users can call this function without having to think about this kind of implication. *) stdout_and_stderr_behave_nicely_in_pipeline := make_writer_behave_nicely_in_pipeline ;; let with_file_atomic ?temp_file ?perm ?fsync:(do_fsync = false) ?(replace_special = false) ?time_source file ~f = let%bind current_file_permissions = match%map Monitor.try_with ~run:`Now ~rest:`Raise (fun () -> Unix.stat file) with | Ok stats -> (match stats.kind with | `File -> Some stats.perm | `Directory -> raise_s [%message "Writer.with_file_atomic: not replacing a directory" ~_:(file : string)] | `Char | `Block | `Fifo | `Socket -> (match replace_special with | true -> Some stats.perm | false -> raise_s [%message "Writer.with_file_atomic: not replacing special file" ~_:(file : string)]) | `Link -> (* [Unix.stat] resolves the symlinks already. Unfortunately, this means we won't be able to replace a "broken" symlink. *) assert false) | Error _ -> None in let initial_permissions = match perm with | Some p -> p | None -> (match current_file_permissions with | None -> 0o666 | Some p -> p) in let%bind temp_file, fd = let temp_file = Option.value temp_file ~default:file in let%map temp_file, fd = let dir = Filename.dirname temp_file in let prefix = Filename.basename temp_file in In_thread.run (fun () -> Filename_unix.open_temp_file_fd ~perm:initial_permissions ~in_dir:dir prefix "") in temp_file, Fd.create File fd (Info.of_string temp_file) in let t = create ?time_source fd in (let%bind.Deferred.Result f_result = Monitor.try_with_or_error (fun () -> f t) >>| Result.map_error ~f:(fun e -> `f_raised e) in match%map let%bind.Deferred.Or_error () = Result.ok_if_true (not (is_closed t)) ~error:(Error.create_s [%message "writer closed by [f]" ~_:(file : string)]) |> Deferred.return in Monitor.try_with_or_error (fun () -> let%bind () = match current_file_permissions with | None -> (* We don't need to change the permissions here. The [initial_permissions] (with umask applied by the OS) should be good. *) return () | Some _ -> (* We are overwriting permissions here to undo the umask that was applied by [openfile]. This is, perhaps, unreasonable, but it preserves the previous behavior. *) Unix.fchmod fd ~perm:initial_permissions in let%bind () = if do_fsync then fsync t else return () in let%bind () = close t in Unix.rename ~src:temp_file ~dst:file) with | Error e -> Error (`final_steps_raised e) | Ok () -> Ok f_result) >>= function | Ok res -> return res | Error error -> let%bind unlink_result = Monitor.try_with_or_error (fun () -> Unix.unlink temp_file) in (* NB we may have tried to close above, but that's OK because close is idempotent. *) let%map close_result = Monitor.try_with_or_error (fun () -> close t) in (match Or_error.combine_errors_unit [ close_result; unlink_result ] with | Ok () -> (match error with | `f_raised f_error -> (* We do not tag an error arising in [f] *) Error.raise f_error | `final_steps_raised our_error -> our_error) | Error cleanup_error -> let initial_error = match error with | `final_steps_raised e | `f_raised e -> e in Error.of_list [ initial_error; cleanup_error ]) |> Error.tag_s ~tag:[%message "Error in Writer.with_file_atomic" (file : string)] |> Error.raise ;; let save ?temp_file ?perm ?fsync ?replace_special file ~contents = with_file_atomic ?temp_file ?perm ?fsync ?replace_special file ~f:(fun t -> write t contents; return ()) ;; let save_lines ?temp_file ?perm ?fsync ?replace_special file lines = with_file_atomic ?temp_file ?perm ?fsync ?replace_special file ~f:(fun t -> List.iter lines ~f:(fun line -> write t line; newline t); return ()) ;; let save_sexp ?temp_file ?perm ?fsync ?replace_special ?(hum = true) file sexp = with_file_atomic ?temp_file ?perm ?fsync ?replace_special file ~f:(fun t -> write_sexp_internal t sexp ~hum ~terminate_with:Newline; return ()) ;; let save_sexps_conv ?temp_file ?perm ?fsync ?replace_special ?(hum = true) file xs sexp_of_x = with_file_atomic ?temp_file ?perm ?fsync ?replace_special file ~f:(fun t -> List.iter xs ~f:(fun x -> write_sexp_internal t (sexp_of_x x) ~hum ~terminate_with:Newline); return ()) ;; let save_sexps ?temp_file ?perm ?fsync ?replace_special ?hum file sexps = save_sexps_conv ?temp_file ?perm ?fsync ?replace_special ?hum file sexps Fn.id ;; let save_bin_prot ?temp_file ?perm ?fsync ?replace_special file bin_writer a = with_file_atomic ?temp_file ?perm ?fsync ?replace_special file ~f:(fun t -> write_bin_prot t bin_writer a; return ()) ;; let with_flushed_at_close t ~flushed ~f = let producers_to_flush_at_close_elt = Bag.add t.producers_to_flush_at_close flushed in Monitor.protect ~run:`Schedule ~rest:`Log f ~finally:(fun () -> Bag.remove t.producers_to_flush_at_close producers_to_flush_at_close_elt; return ()) ;; let make_transfer ?(stop = Deferred.never ()) ?max_num_values_per_read t pipe_r write_f = let consumer = Pipe.add_consumer pipe_r ~downstream_flushed:(fun () -> let%map () = flushed t in `Ok) in let end_of_pipe_r = Ivar.create () in (* The only reason we can't use [Pipe.iter] is because it doesn't accept [?max_num_values_per_read]. *) let rec iter () = if Ivar.is_full t.consumer_left || (not (can_write t)) || Deferred.is_determined stop then (* The [choose] in [doit] will become determined and [doit] will do the right thing. *) () else ( let read_result = match max_num_values_per_read with | None -> Pipe.read_now' pipe_r ~consumer | Some max_queue_length -> Pipe.read_now' pipe_r ~consumer ~max_queue_length in match read_result with | `Eof -> Ivar.fill end_of_pipe_r () | `Nothing_available -> Pipe.values_available pipe_r >>> fun _ -> iter () | `Ok q -> write_f q ~cont:(fun () -> Pipe.Consumer.values_sent_downstream consumer; flushed t >>> iter)) in let doit () = (* Concurrecy between [iter] and [choose] is essential. Even if [iter] gets blocked, for example on [flushed], the result of [doit] can still be determined by [choice]s other than [end_of_pipe_r]. *) iter (); match%map choose [ choice (Ivar.read end_of_pipe_r) (fun () -> `End_of_pipe_r) ; choice stop (fun () -> `Stop) ; choice (close_finished t) (fun () -> `Writer_closed) ; choice (consumer_left t) (fun () -> `Consumer_left) ] with | `End_of_pipe_r | `Stop -> () | `Writer_closed | `Consumer_left -> Pipe.close_read pipe_r in with_flushed_at_close t ~f:doit ~flushed:(fun () -> Deferred.ignore_m (Pipe.upstream_flushed pipe_r)) ;; let transfer ?stop ?max_num_values_per_read t pipe_r write_f = make_transfer ?stop ?max_num_values_per_read t pipe_r (fun q ~cont -> Queue.iter q ~f:write_f; cont ()) ;; let transfer' ?stop ?max_num_values_per_read t pipe_r write_f = make_transfer ?stop ?max_num_values_per_read t pipe_r (fun q ~cont -> write_f q >>> cont) ;; let pipe t = let pipe_r, pipe_w = Pipe.create () in don't_wait_for (transfer t pipe_r (fun s -> write t s)); pipe_w ;; async_unix-0.15.0/thread_pool/000077500000000000000000000000001420273305200162535ustar00rootroot00000000000000async_unix-0.15.0/thread_pool/README.md000066400000000000000000000003001420273305200175230ustar00rootroot00000000000000# Thread_pool A thread pool is a set of OCaml threads used to do work, where each piece of work is simply a thunk. The `Async_unix` library uses `Thread_pool` to make blocking system calls. async_unix-0.15.0/thread_pool/src/000077500000000000000000000000001420273305200170425ustar00rootroot00000000000000async_unix-0.15.0/thread_pool/src/dune000066400000000000000000000003731420273305200177230ustar00rootroot00000000000000(library (name thread_pool) (public_name async_unix.thread_pool) (libraries core core_unix.linux_ext core_unix.nano_mutex core_unix.squeue core_kernel.thread_pool_cpu_affinity thread_safe_ivar core_unix.time_ns_unix) (preprocess (pps ppx_jane)))async_unix-0.15.0/thread_pool/src/import.ml000066400000000000000000000001601420273305200207030ustar00rootroot00000000000000open! Core module Time_ns = Time_ns_unix include Int.Replace_polymorphic_compare let sec = Time_ns.Span.of_sec async_unix-0.15.0/thread_pool/src/thread_pool.ml000066400000000000000000000606531420273305200217060ustar00rootroot00000000000000open! Core open! Import module Cpu_affinity = Thread_pool_cpu_affinity let debug_log message a sexp_of_a = eprintf "%s\n%!" (Sexp.to_string_hum [%sexp (Time_ns.now () : Time_ns.t), (message : string), (a : a)]) ;; module Time_ns = struct include Time_ns let sexp_of_t t = [%sexp (if am_running_test then epoch else t : t)] end module Thread_id : sig type t [@@deriving sexp_of] include Hashable with type t := t val of_ocaml_thread : Core_thread.t -> t val self : unit -> t end = struct include Int let of_ocaml_thread = Core_thread.id let self () = of_ocaml_thread (Core_thread.self ()) end module Priority = Linux_ext.Priority let priority_zero = Priority.of_int 0 let getpriority = match Linux_ext.getpriority with | Error _ -> const priority_zero | Ok f -> f ;; let setpriority = match Linux_ext.setpriority with | Error _ -> Fn.ignore | Ok f -> f ;; let set_thread_name = match Linux_ext.pr_set_name_first16 with | Ok f -> f | Error _ -> Fn.ignore ;; let debug = ref false (* We define everything in an [Internal] module, and then wrap in a [Mutex.critical_section] each thread-safe function exposed in the mli. When reading code here, keep in mind that there are two entry points: (1) The functions that are exposed for external consumption in the mli (these are protected by the mutex). (2) Code that is called within threads created in this module. All such code should acquire the mutex before it affects the thread state. *) module Internal = struct module Mutex = Nano_mutex let check_invariant = ref false let error = Or_error.error module Pool_id : Unique_id = Unique_id.Int63 () module Work = struct type t = { (* When this work starts running, the name of the thread will be set (via [Linux_ext.pr_set_name]) to[name]. *) name : string ; doit : unit -> unit ; priority : Priority.t } [@@deriving sexp_of] end module Work_queue = struct type elt = | Stop | Work of Work.t [@@deriving sexp_of] type t = elt Squeue.t [@@deriving sexp_of] let create () = Squeue.create 1 let enqueue t work = Squeue.push_uncond t work end module Helper_thread = struct type 'thread t = { in_pool : Pool_id.t ; mutable state : [ `In_use | `Finishing | `Finished ] ; thread : 'thread (* [default_name] will be used as the name of work run by the helper thread, unless that work is added with an overriding name. *) ; default_name : string (* [default_priority] will be used as the priority of work run by the helper thread, unless that work is added with an overriding priority. *) ; default_priority : Priority.t } [@@deriving fields, sexp_of] end module Thread = struct type t = { (* [name] is the name of the thread that the OS knows, i.e. the argument supplied to the most recent call to [set_thread_name] by the thread. *) mutable name : string (* [thread_id] is the OCaml thread id of the OCaml thread that this corresponds to. It is an option only because we create this object before creating the thread. We set it to [Some] as soon as we create the thread, and then never change it. *) ; mutable thread_id : Thread_id.t option (* [priority] is the priority of the thread that the OS knows, i.e. the argument supplied in the most recent call to [setpriority] by the thread. *) ; mutable priority : Priority.t (* A thread can be "available", meaning that it isn't working on anything, or doing work added to the thread pool, or serving as a helper thread. *) ; mutable state : [ `Available | `Working | `Helper of (t[@sexp.opaque]) Helper_thread.t ] (* [unfinished_work] is the amount of work remaining for this thread to do. It includes all the work in [work_queue], plus perhaps an additional work that is running. *) ; mutable unfinished_work : int (* [work_queue] is where this thread pulls work from. Each thread has its own queue. If a thread is working for the general pool, then its work queue has at most one element. If a thread is a helper thread, then the work queue has all the unfinished work that has been added for the helper thread. *) ; work_queue : Work_queue.t } [@@deriving fields, sexp_of] let invariant t : unit = try let check invariant field = invariant (Field.get field t) in Fields.iter ~name:ignore ~thread_id:(check (fun o -> assert (is_some o))) ~priority:ignore ~state:ignore ~unfinished_work: (check (fun unfinished_work -> assert ( unfinished_work = Squeue.length t.work_queue || unfinished_work = Squeue.length t.work_queue + 1))) ~work_queue:ignore with | exn -> raise_s [%message "Thread.invariant failed" (exn : exn) ~thread:(t : t)] ;; let is_available t = match t.state with | `Available -> true | `Working | `Helper _ -> false ;; let create priority = { name = "" ; thread_id = None ; priority ; state = `Available ; unfinished_work = 0 ; work_queue = Work_queue.create () } ;; let enqueue_work t work = t.unfinished_work <- t.unfinished_work + 1; Work_queue.enqueue t.work_queue (Work work) ;; let stop t = Work_queue.enqueue t.work_queue Stop let initialize_ocaml_thread t (cpu_affinity : Cpu_affinity.t) = set_thread_name t.name; (* We call [getpriority] to see whether we need to set the priority. This is not a performance optimization. It is done so that in programs that don't use priorities, we never call [setpriority], and thus prevent problems due to the user's "ulimit -e" being too restrictive. The use of [getpriority] is limited to initialization, and is not used elsewhere in this module. *) if not (Priority.equal (getpriority ()) t.priority) then setpriority t.priority; match cpu_affinity with | Inherit -> () | Cpuset cpuset -> Or_error.ok_exn Core_thread.setaffinity_self_exn (cpuset |> Cpu_affinity.Cpuset.raw) ;; let set_name t name = if String.( <> ) name t.name then ( set_thread_name name; t.name <- name) ;; let set_priority t priority = if not (Priority.equal t.priority priority) then ( setpriority priority; t.priority <- priority) ;; end module Thread_creation_failure = struct type t = { at : Time_ns.t ; error : Error.t } [@@deriving fields, sexp_of] end (* [Thread_pool.t] *) type t = { id : Pool_id.t (** [state] starts as [`In_use] when the thread pool is created. When the user calls [finished_with], it transitions to [`Finishing]. When the last work is done, it transitions to [`Finished] and fills [finished]. *) ; mutable state : [ `In_use | `Finishing | `Finished ] ; finished : unit Thread_safe_ivar.t (* [mutex] is used to protect all access to [t] and its substructures, since the threads actually doing the work need to access[t]. *) ; mutex : Mutex.t (** [default_priority] is the priority that will be used for work unless that work is added with an overriding priority. It is set to whatever the priority is when the thread pool is created. *) ; default_priority : Priority.t (* [max_num_threads] is the maximum number of threads that the thread pool is allowed to create. *) ; max_num_threads : int (* [cpu_affinity] is the desired CPU affinity for threads in this pool. *) ; cpu_affinity : Cpu_affinity.t (* [num_threads] is the number of threads that have been created by the pool. The thread pool guarantees that [num_threads <= max_num_threads]. *) ; mutable num_threads : int (* [thread_creation_failure_lockout] is the amount of time that must pass after a thread-creation failure before the thread pool will make another attempt to create a thread. *) ; mutable thread_creation_failure_lockout : Time_ns.Span.t (* [last_thread_creation_failure] has information about the last time that [Core_thread.create] raised. *) ; mutable last_thread_creation_failure : Thread_creation_failure.t option (* [thread_by_id] holds all the threads that have been created by the pool. *) ; mutable thread_by_id : Thread.t Thread_id.Table.t (* [available_threads] holds all threads that have [state = `Available]. It is used as a stack so that the most recently used available thread is used next, on the theory that this is better for locality. *) ; mutable available_threads : Thread.t list (* [work_queue] holds work to be done for which no thread is available. *) ; work_queue : Work.t Queue.t (* [unfinished_work] holds the amount of work that has been submitted to the pool but not yet been completed. *) ; mutable unfinished_work : int ; mutable num_work_completed : int } [@@deriving fields, sexp_of] let invariant t : unit = try let check invariant field = invariant (Field.get field t) in Fields.iter ~id:ignore ~state: (check (function | `In_use | `Finishing -> () | `Finished -> assert (t.unfinished_work = 0); assert (t.num_threads = 0))) ~finished:ignore ~cpu_affinity:ignore ~mutex:(check Mutex.invariant) ~default_priority:ignore ~max_num_threads:(check (fun max_num_threads -> assert (max_num_threads >= 1))) ~num_threads: (check (fun num_threads -> assert (num_threads = Hashtbl.length t.thread_by_id); assert (num_threads <= t.max_num_threads))) ~thread_creation_failure_lockout:ignore ~last_thread_creation_failure:ignore ~thread_by_id: (check (fun thread_by_id -> Thread_id.Table.invariant Thread.invariant thread_by_id)) ~available_threads: (check (fun available_threads -> assert (List.length available_threads <= t.num_threads); List.iter available_threads ~f:(fun thread -> assert ( Hashtbl.exists t.thread_by_id ~f:(fun thread' -> phys_equal thread thread')); assert (Thread.is_available thread)))) ~work_queue: (check (fun work_queue -> (* It is possible that: {[ has_unstarted_work t && t.num_threads < t.max_num_threads ]} This happens when adding work and [Core_thread.create] raises. In that case, the thread pool enqueues the work and continues with the threads it has. If the thread pool can't make progress, then Async's thread-pool-stuck detection will later report it. *) assert (Queue.is_empty work_queue || List.is_empty t.available_threads))) ~unfinished_work:(check (fun unfinished_work -> assert (unfinished_work >= 0))) ~num_work_completed: (check (fun num_work_completed -> assert (num_work_completed >= 0))) with | exn -> raise_s [%message "Thread_pool.invariant failed" (exn : exn) ~thread_pool:(t : t)] ;; let is_finished t = match t.state with | `Finished -> true | `Finishing | `In_use -> false ;; let is_in_use t = match t.state with | `In_use -> true | `Finishing | `Finished -> false ;; let has_unstarted_work t = not (Queue.is_empty t.work_queue) let create ?(cpu_affinity = Cpu_affinity.Inherit) ~max_num_threads () = if match cpu_affinity with | Inherit -> false | Cpuset _ -> Or_error.is_error Core_thread.setaffinity_self_exn then Or_error.error_string "Thread_pool.create setaffinity not supported on this platform" else if max_num_threads < 1 then error "Thread_pool.create max_num_threads was < 1" max_num_threads [%sexp_of: int] else ( let t = { id = Pool_id.create () ; state = `In_use ; finished = Thread_safe_ivar.create () ; mutex = Mutex.create () ; default_priority = getpriority () ; cpu_affinity ; max_num_threads ; num_threads = 0 ; thread_by_id = Thread_id.Table.create () ; thread_creation_failure_lockout = sec 1. ; last_thread_creation_failure = None ; available_threads = [] ; work_queue = Queue.create () ; unfinished_work = 0 ; num_work_completed = 0 } in Ok t) ;; let maybe_finish t = match t.state with | `In_use | `Finished -> () | `Finishing -> if t.unfinished_work = 0 then ( let set x f = Option.value_exn (Field.setter f) t x in Fields.iter ~id:ignore ~state:(set `Finished) ~finished:(fun _ -> Thread_safe_ivar.fill t.finished ()) ~mutex:ignore ~default_priority:ignore ~cpu_affinity:ignore ~max_num_threads:ignore ~num_threads:(set 0) ~thread_creation_failure_lockout:ignore ~last_thread_creation_failure:ignore ~thread_by_id:(fun _ -> Hashtbl.iter t.thread_by_id ~f:Thread.stop; Hashtbl.clear t.thread_by_id) ~available_threads:(set []) ~work_queue:ignore ~unfinished_work:ignore ~num_work_completed:ignore) ;; let finished_with t = if !debug then debug_log "Thread_pool.finished_with" t [%sexp_of: t]; match t.state with | `Finishing | `Finished -> () | `In_use -> t.state <- `Finishing; maybe_finish t ;; let assign_work_to_thread (thread : Thread.t) work = thread.state <- `Working; Thread.enqueue_work thread work ;; let make_thread_available t thread = if !debug then debug_log "make_thread_available" (thread, t) [%sexp_of: Thread.t * t]; match Queue.dequeue t.work_queue with | Some work -> assign_work_to_thread thread work | None -> thread.state <- `Available; t.available_threads <- thread :: t.available_threads; maybe_finish t ;; let maybe_finish_helper_thread t (helper_thread : Thread.t Helper_thread.t) = match helper_thread.state with | `In_use | `Finished -> () | `Finishing -> let thread = helper_thread.thread in if thread.unfinished_work = 0 then ( helper_thread.state <- `Finished; make_thread_available t thread) ;; let create_thread t = if !debug then debug_log "create_thread" t [%sexp_of: t]; let thread = Thread.create t.default_priority in let ocaml_thread = Or_error.try_with (fun () -> Core_thread.create ~on_uncaught_exn:`Print_to_stderr (fun () -> Thread.initialize_ocaml_thread thread t.cpu_affinity; let rec loop () = match Squeue.pop thread.work_queue with | Stop -> () | Work work -> if !debug then debug_log "thread got work" (work, thread, t) [%sexp_of: Work.t * Thread.t * t]; Thread.set_name thread work.name; Thread.set_priority thread work.priority; (try work.doit () (* the actual work *) with | _ -> ()); t.num_work_completed <- t.num_work_completed + 1; if !debug then debug_log "thread finished with work" (work, thread, t) [%sexp_of: Work.t * Thread.t * t]; Mutex.critical_section t.mutex ~f:(fun () -> t.unfinished_work <- t.unfinished_work - 1; thread.unfinished_work <- thread.unfinished_work - 1; match thread.state with | `Available -> raise_s [%message "thread-pool thread unexpectedly available" (thread : Thread.t)] | `Helper helper_thread -> maybe_finish_helper_thread t helper_thread | `Working -> make_thread_available t thread); loop () in loop ()) ()) in Or_error.map ocaml_thread ~f:(fun ocaml_thread -> let thread_id = Thread_id.of_ocaml_thread ocaml_thread in thread.thread_id <- Some thread_id; t.num_threads <- t.num_threads + 1; Hashtbl.add_exn t.thread_by_id ~key:thread_id ~data:thread; thread) ;; let last_thread_creation_failure_at t = Option.value_map t.last_thread_creation_failure ~default:Time_ns.epoch ~f:Thread_creation_failure.at ;; let get_available_thread t = if !debug then debug_log "get_available_thread" t [%sexp_of: t]; match t.available_threads with | thread :: rest -> t.available_threads <- rest; `Ok thread | [] -> if t.num_threads = t.max_num_threads then `None_available else ( let now = Time_ns.now () in if Time_ns.Span.( < ) (Time_ns.diff now (last_thread_creation_failure_at t)) t.thread_creation_failure_lockout then `None_available else ( match create_thread t with | Ok thread -> `Ok thread | Error error -> t.last_thread_creation_failure <- Some { at = now; error }; `None_available)) ;; let inc_unfinished_work t = t.unfinished_work <- t.unfinished_work + 1 let default_thread_name = "thread-pool thread" let add_work ?priority ?name t doit = if !debug then debug_log "add_work" t [%sexp_of: t]; if not (is_in_use t) then error "add_work called on finished thread pool" t [%sexp_of: t] else ( let work = { Work.doit ; name = Option.value name ~default:default_thread_name ; priority = Option.value priority ~default:t.default_priority } in inc_unfinished_work t; (match get_available_thread t with | `None_available -> Queue.enqueue t.work_queue work | `Ok thread -> assign_work_to_thread thread work); Ok ()) ;; let become_helper_thread_internal ?priority ?name t ~(get_thread : t -> Thread.t Or_error.t) = if !debug then debug_log "become_helper_thread_internal" t [%sexp_of: t]; if not (is_in_use t) then error "become_helper_thread_internal called on finished thread pool" t [%sexp_of: t] else ( match get_thread t with | Error _ as e -> e | Ok thread -> let helper_thread = { Helper_thread.default_name = Option.value name ~default:"helper_thread" ; default_priority = Option.value priority ~default:t.default_priority ; in_pool = t.id ; state = `In_use ; thread } in thread.state <- `Helper helper_thread; Ok helper_thread) ;; let create_helper_thread ?priority ?name t = become_helper_thread_internal ?priority ?name t ~get_thread:(fun t -> match get_available_thread t with | `Ok thread -> Ok thread | `None_available -> error ~strict:() "create_helper_thread could not get a thread" t [%sexp_of: t]) ;; let become_helper_thread ?priority ?name t = become_helper_thread_internal ?priority ?name t ~get_thread:(fun t -> match Hashtbl.find t.thread_by_id (Thread_id.self ()) with | Some thread -> Ok thread | None -> Or_error.error_string "become_helper_thread not called within thread-pool thread") ;; let add_work_for_helper_thread ?priority ?name t helper_thread doit = if !debug then debug_log "add_work_for_helper_thread" (helper_thread, t) [%sexp_of: Thread.t Helper_thread.t * t]; if not (Pool_id.equal t.id helper_thread.in_pool) then error "add_work_for_helper_thread called on helper thread not in pool" (helper_thread, t) [%sexp_of: Thread.t Helper_thread.t * t] else if not (is_in_use t) then error "add_work_for_helper_thread called on finished thread pool" t [%sexp_of: t] else ( match helper_thread.state with | `Finishing | `Finished -> error "add_work_for_helper_thread called on helper thread no longer in use" (helper_thread, t) [%sexp_of: Thread.t Helper_thread.t * t] | `In_use -> let { Helper_thread.thread; _ } = helper_thread in inc_unfinished_work t; Thread.enqueue_work thread { Work.name = Option.value name ~default:(Helper_thread.default_name helper_thread) ; doit ; priority = Option.value priority ~default:(Helper_thread.default_priority helper_thread) }; Ok ()) ;; let finished_with_helper_thread t helper_thread = if !debug then debug_log "finished_with_helper_thread" (helper_thread, t) [%sexp_of: Thread.t Helper_thread.t * t]; if not (Pool_id.equal t.id helper_thread.in_pool) then raise_s [%message "finished_with_helper_thread called on helper thread not in pool" (helper_thread : Thread.t Helper_thread.t) ~thread_pool:(t : t)] else ( match helper_thread.state with | `Finishing | `Finished -> () | `In_use -> helper_thread.state <- `Finishing; maybe_finish_helper_thread t helper_thread) ;; end (* Now we define everything to be exported, being careful to wrap everything in [Mutex.critical_section] that needs to be. *) open Internal type t = Internal.t [@@deriving sexp_of] let thread_creation_failure_lockout = Internal.thread_creation_failure_lockout let last_thread_creation_failure t = Option.map t.last_thread_creation_failure ~f:Thread_creation_failure.sexp_of_t ;; let critical_section t ~f = Mutex.critical_section t.mutex ~f:(fun () -> protect ~f ~finally:(fun () -> if !check_invariant then invariant t)) ;; let invariant t = critical_section t ~f:(fun () -> invariant t) let create ?cpu_affinity ~max_num_threads () = Result.map (create ?cpu_affinity ~max_num_threads ()) ~f:(fun t -> if !check_invariant then invariant t; t) ;; let finished_with t = critical_section t ~f:(fun () -> finished_with t) (* We do not use [critical_section] for [block_until_finished] because it is already thread safe, and we do not want it to hold [t]'s lock while blocking, because we must allow the finishing threads to acquire [t]'s lock. *) let block_until_finished t = Thread_safe_ivar.read t.finished (* We do not use [critical_section] for the record field accessors because that's thread-safe with the current OCaml runtime. *) let cpu_affinity = cpu_affinity let default_priority = default_priority let has_unstarted_work = has_unstarted_work let max_num_threads = max_num_threads let num_threads = num_threads let num_work_completed = num_work_completed let unfinished_work = unfinished_work module Helper_thread = struct open Helper_thread type t = Thread.t Helper_thread.t [@@deriving sexp_of] let default_name = default_name let default_priority = default_priority end let add_work ?priority ?name t doit = critical_section t ~f:(fun () -> add_work ?priority ?name t doit) ;; let become_helper_thread ?priority ?name t = critical_section t ~f:(fun () -> become_helper_thread ?priority ?name t) ;; let create_helper_thread ?priority ?name t = critical_section t ~f:(fun () -> create_helper_thread ?priority ?name t) ;; let add_work_for_helper_thread ?priority ?name t helper_thread doit = critical_section t ~f:(fun () -> add_work_for_helper_thread ?priority ?name t helper_thread doit) ;; let finished_with_helper_thread t helper_thread = critical_section t ~f:(fun () -> finished_with_helper_thread t helper_thread) ;; module Private = struct let check_invariant = check_invariant let default_thread_name = default_thread_name let is_finished = is_finished let is_in_use = is_in_use let set_last_thread_creation_failure t at = t.last_thread_creation_failure <- Some { at; error = Error.of_string "fake-error" } ;; let set_thread_creation_failure_lockout t span = t.thread_creation_failure_lockout <- span ;; end async_unix-0.15.0/thread_pool/src/thread_pool.mli000066400000000000000000000213701420273305200220500ustar00rootroot00000000000000(** A thread pool is a set of OCaml threads used to do work, where each piece of work is simply a thunk. One creates a thread pool, and then uses [add_work] to submit work to it. Work is done first-come-first-served by available threads in the pool. Any of the available threads in the pool could be used to do work submitted to the pool (except helper threads, see below). A thread pool starts with no threads. As work is added, the thread pool creates new threads to do the work, up to the maximum number of allowed threads, [max_num_threads], supplied to [create]. Thread-pool threads never die. They just get created up until [max_num_threads] is reached and then live forever, doing work. Each thread in the pool is in a loop, waiting for a piece of work, running the thunk, and then repeating. It may be that all the threads in the pool are not doing anything, but in this case, the threads still exist, and are simply blocked waiting for work. Sometimes one wants work to run in a dedicated thread, e.g. some C libraries require this. To do this, use [Helper_thread], see below. All of the functions exposed by this module are thread safe; they synchronize using a mutex on the thread pool. One must not call thread-pool functions from a GC finalizer, since a finalizer could run within a thread running a thread-pool function, which already holds the lock, and would therefore deadlock or error when attempting to re-acquire it. This is accomplished elsewhere by using Async finalizers, which are run from ordinary Async jobs, and thus do not hold the thread-pool lock. One can control the priority and affinity of threads in the pool (priority in the sense of [Linux_ext.setpriority]). Work added to the pool can optionally be given a priority, and the pool will set the priority of the thread that runs it for the duration of the work. Helper threads can also be given a priority, which will be used for all work run by the helper thread, unless the work has an overriding priority. The thread pool has a "default" priority that will be used for all work and helper threads that have no specified priority. The default priority is the priority in effect when [create] is called. Affinity, on the other hand, can only be specified when you create a pool. The default affinity is the affinity in effect when a new thread happens to be created (e.g. when you call [add_work]). Behavior is unspecified if work calls [setpriority] or [setaffinity] directly. *) open! Core open! Import module Cpu_affinity = Thread_pool_cpu_affinity module Priority : module type of Linux_ext.Priority with type t = Linux_ext.Priority.t type t [@@deriving sexp_of] include Invariant.S with type t := t (** [create ?cpuset ~max_num_threads] returns a new thread pool. It is an error if [max_num_threads < 1]. If [cpuset] is specified, then every thread will be affinitized to those CPU cores upon creation. If [cpuset] is not specified, then every thread will inherit the affinitization of the thread (typically the main thread) that created it. *) val create : ?cpu_affinity:Cpu_affinity.t (** default is [Inherit] *) -> max_num_threads:int -> unit -> t Or_error.t (** [cpu_affinity t] returns the CPU affinity that [t] was created with. All threads created by [t] will be created with this affinity. *) val cpu_affinity : t -> Cpu_affinity.t (** [finished_with t] makes it an error to subsequently call [add_work* t] or [create_helper_thread t]. And, once all current work in [t] is finished, destroys all the threads in [t]. It is OK to call [finished_with] multiple times on the same [t]; subsequent calls will have no effect. *) val finished_with : t -> unit (** [block_until_finished t] blocks the current thread until thread pool [t] has finished. One must previously have called [finished_with] to cause [t] to start finishing. *) val block_until_finished : t -> unit (** [max_num_threads t] returns the maximum number of threads that [t] is allowed to create. *) val max_num_threads : t -> int (** [num_threads t] returns the number of threads that the pool [t] has created. *) val num_threads : t -> int (** [unfinished_work t] returns the number of jobs that have been submitted to [t] but haven't yet finished. *) val unfinished_work : t -> int (** [default_priority t] returns the priority that will be used for work performed by [t], unless that work is added with an overriding priority. *) val default_priority : t -> Priority.t (** [add_work ?priority ?name t f] enqueues [f] to be done by some thread in the pool. Exceptions raised by [f] are silently ignored. While the work is run, the name of the thread running the work will be set (via [Linux_ext.pr_set_name]) to [name] and the priority of the thread will be set to [priority]. It is an error to call [add_work t] after [finished_with t]. *) val add_work : ?priority:Priority.t (** default is [default_priority t] *) -> ?name:string (** default is ["thread-pool thread"] *) -> t -> (unit -> unit) -> unit Or_error.t val num_work_completed : t -> int (** [has_unstarted_work t] returns [true] if [t] has work that it hasn't been assigned to start running in a thread. *) val has_unstarted_work : t -> bool (** A helper thread is a thread with its own dedicated work queue. Work added for the helper thread is guaranteed to be run by that thread. The helper thread only runs work explicitly supplied to it. Helper threads count towards a thread pool's [max_num_threads]. *) module Helper_thread : sig type t [@@deriving sexp_of] (** [default_name t] returns the name that will be used for work performed by [t], unless that work is added with an overriding name *) val default_name : t -> string (** [default_priority t] returns the priority that will be used for work performed by [t], unless that work is added with an overriding priority. *) val default_priority : t -> Priority.t end (** [create_helper_thread ?priority ?name t] takes an available thread from the thread pool and makes it a helper thread, raising if no threads are available or if [finished_with t] was previously called. The new helper thread runs work with [name] and [priority], except for work that is added with an overriding priority or name. The thread remains a helper thread until [finished_with_helper_thread] is called, if ever. *) val create_helper_thread : ?priority:Priority.t (** default is [default_priority t] *) -> ?name:string (** default is ["helper thread"] *) -> t -> Helper_thread.t Or_error.t (** [become_helper_thread ?priority ?name t] should be run from within work supplied to [add_work]. When [become_helper_thread] runs, it transitions the current thread into a helper thread. Other than that, [become_helper_thread] is like [create_helper_thread], except it cannot fail because no threads are available. *) val become_helper_thread : ?priority:Priority.t (** default is [default_priority t] *) -> ?name:string (** default is ["helper thread"] *) -> t -> Helper_thread.t Or_error.t (** [add_work_for_helper_thread ?priority ?name t helper_thread f] enqueues [f] on [helper_thread]'s work queue. Exceptions raised by [f] are silently ignored. It is an error to call [add_work_for_helper_thread t] after [finished_with_helper_thread t]. When the helper thread runs [f], it will be at the helper thread's name and priority, unless overriden by [name] or [priority]. *) val add_work_for_helper_thread : ?priority:Priority.t (** default is [Helper_thread.default_priority helper_thread] *) -> ?name:string (** default is [Helper_thread.name helper_thread] *) -> t -> Helper_thread.t -> (unit -> unit) -> unit Or_error.t (** [finished_with_helper_thread t helper_thread] informs thread pool [t] that no future work will be added for [helper_thread], and makes it an error to in the future add work for [helper_thread]. Furthermore, once [helper_thread] finishes with its last piece of work, it will revert to a general thread-pool thread. It is OK to call [finished_with_helper_thread] multiple times on the same [helper_thread]; subsequent calls will have no effect. *) val finished_with_helper_thread : t -> Helper_thread.t -> unit val last_thread_creation_failure : t -> Sexp.t option val thread_creation_failure_lockout : t -> Time_ns.Span.t val debug : bool ref (**/**) module Private : sig val check_invariant : bool ref val default_thread_name : string val is_finished : t -> bool val is_in_use : t -> bool val set_last_thread_creation_failure : t -> Time_ns.t -> unit val set_thread_creation_failure_lockout : t -> Time_ns.Span.t -> unit end async_unix-0.15.0/thread_pool/test/000077500000000000000000000000001420273305200172325ustar00rootroot00000000000000async_unix-0.15.0/thread_pool/test/dune000066400000000000000000000002451420273305200201110ustar00rootroot00000000000000(library (name thread_pool_test) (libraries async_kernel expect_test_helpers_core thread_pool thread_safe_ivar core_unix.nano_mutex) (preprocess (pps ppx_jane)))async_unix-0.15.0/thread_pool/test/test_thread_pool.ml000066400000000000000000000376621420273305200231410ustar00rootroot00000000000000open! Core open! Expect_test_helpers_core open! Thread_pool open! Thread_pool.Private module Thread = Core_thread module Time_ns = Time_ns_unix module Debug = Async_kernel.Async_kernel_private.Debug let debug = Debug.thread_pool let sec = Time_ns.Span.of_sec let%test_module _ = (module struct let () = check_invariant := true let wait_until_no_unfinished_work t = let rec loop i = if unfinished_work t > 0 then ( Time_ns.pause (sec 0.01); loop (i + 1)) in loop 0 ;; (* [create] and [finished_with]. *) let%expect_test _ = let t = ok_exn (create ~max_num_threads:1 ()) in assert (max_num_threads t = 1); assert (num_threads t = 0); (* no threads should have been created *) finished_with t ;; (* Error cases for [create]. *) let%expect_test _ = List.iter [ -1; 0 ] ~f:(fun max_num_threads -> require [%here] (Result.is_error (create ~max_num_threads ()))) ;; (* Error cases for [add_work]. *) let%expect_test _ = let t = ok_exn (create ~max_num_threads:1 ()) in finished_with t; assert (Result.is_error (add_work t ignore)) ;; (* Work finishing after [finished_with] is called causes the thread pool to finish. *) let%expect_test _ = let t = ok_exn (create ~max_num_threads:1 ()) in let finish_work = Thread_safe_ivar.create () in ok_exn (add_work t (fun () -> Thread_safe_ivar.read finish_work)); finished_with t; Thread_safe_ivar.fill finish_work (); wait_until_no_unfinished_work t; assert (is_finished t) ;; (* Check that the expected concurrency is used. *) let%expect_test _ = List.iter [ 1; 2; 5; 10; 100; 1000 ] ~f:(fun num_jobs -> List.iter ([ 1; 2; 5; 10 ] @ if Sys.word_size_in_bits = 32 then [] (* not enough address space when the stack limit is high *) else [ 100 ]) ~f:(fun max_num_threads -> if debug then eprintf "num_jobs = %d max_num_threads = %d\n%!" num_jobs max_num_threads; let mutex = Nano_mutex.create () in let expected_max_concurrent_jobs = min num_jobs max_num_threads in let max_observed_concurrent_jobs = ref 0 in let num_concurrent_jobs = ref 0 in let job_starts = ref [] in let t = ok_exn (create ~max_num_threads ()) in let worker_threads_have_fully_started = Thread_safe_ivar.create () in let worker_threads_should_continue = Thread_safe_ivar.create () in let (_ : Core_thread.t) = Core_thread.create ~on_uncaught_exn:`Print_to_stderr (fun () -> let start = Time_ns.now () in let rec loop () = if is_in_use t then ( let how_long = Time_ns.diff (Time_ns.now ()) start in if Time_ns.Span.( >= ) how_long (sec 10.) then ( Debug.log "thread-pool unit test hung" ( t , worker_threads_have_fully_started , worker_threads_should_continue ) [%sexp_of: t * unit Thread_safe_ivar.t * unit Thread_safe_ivar.t]; Caml.exit 1) else ( Time_ns.pause (sec 0.1); loop ())) in loop ()) () in let jobs = ref [] in for i = 0 to num_jobs - 1 do let job = ok_exn (add_work t (fun () -> Nano_mutex.critical_section mutex ~f:(fun () -> job_starts := i :: !job_starts; if List.length !job_starts = expected_max_concurrent_jobs then Thread_safe_ivar.fill worker_threads_have_fully_started (); incr num_concurrent_jobs; max_observed_concurrent_jobs := max !max_observed_concurrent_jobs !num_concurrent_jobs; assert (!num_concurrent_jobs <= max_num_threads); ); Thread_safe_ivar.read worker_threads_should_continue; Nano_mutex.critical_section mutex ~f:(fun () -> decr num_concurrent_jobs))) in jobs := job :: !jobs done; Thread_safe_ivar.read worker_threads_have_fully_started; assert (!num_concurrent_jobs = expected_max_concurrent_jobs); assert (List.length !job_starts = expected_max_concurrent_jobs); if max_num_threads = 1 then assert ( List.equal Int.equal !job_starts (List.init expected_max_concurrent_jobs ~f:Fn.id)); Thread_safe_ivar.fill worker_threads_should_continue (); wait_until_no_unfinished_work t; assert (!max_observed_concurrent_jobs = expected_max_concurrent_jobs); if max_num_threads = 1 then assert ( List.equal Int.equal (List.rev !job_starts) (List.init num_jobs ~f:Fn.id)); assert (num_threads t <= max_num_threads); finished_with t)) ;; (* Helper threads. *) let%expect_test _ = let t = ok_exn (create ~max_num_threads:1 ()) in let helper_thread = ok_exn (create_helper_thread t) in let helper_continue = Thread_safe_ivar.create () in let helper_finished = Thread_safe_ivar.create () in let work_finished = Thread_safe_ivar.create () in ok_exn (add_work_for_helper_thread t helper_thread (fun () -> Thread_safe_ivar.read helper_continue; Thread_safe_ivar.fill helper_finished ())); ok_exn (add_work t (fun () -> Thread_safe_ivar.fill work_finished ())); Thread_safe_ivar.fill helper_continue (); Thread_safe_ivar.read helper_finished; finished_with_helper_thread t helper_thread; Thread_safe_ivar.read work_finished; wait_until_no_unfinished_work t; finished_with t ;; (* Calling [finished_with_helper_thread] while work remains is allowed, and causes the thread to be returned to the general pool once it finishes all its work. *) let%expect_test _ = let t = ok_exn (create ~max_num_threads:1 ()) in let helper_thread = ok_exn (create_helper_thread t) in let general_work_got_done = ref false in ok_exn (add_work t (fun () -> general_work_got_done := true)); let helper_continue = Thread_safe_ivar.create () in let helper_finished = Thread_safe_ivar.create () in ok_exn (add_work_for_helper_thread t helper_thread (fun () -> Thread_safe_ivar.read helper_continue; Thread_safe_ivar.fill helper_finished ())); finished_with_helper_thread t helper_thread; assert (Result.is_error (add_work_for_helper_thread t helper_thread Fn.ignore)); assert (not !general_work_got_done); Thread_safe_ivar.fill helper_continue (); Thread_safe_ivar.read helper_finished; wait_until_no_unfinished_work t; assert !general_work_got_done; finished_with t ;; (* Error cases for mismatches between pool and helper thread. *) let%expect_test _ = let t = ok_exn (create ~max_num_threads:1 ()) in let t_bad = ok_exn (create ~max_num_threads:1 ()) in let helper_thread = ok_exn (create_helper_thread t) in assert (Result.is_error (add_work_for_helper_thread t_bad helper_thread ignore)); assert ( Result.is_error (Result.try_with (fun () -> finished_with_helper_thread t_bad helper_thread))); finished_with_helper_thread t helper_thread; finished_with t ;; (* Setting thread name and priority. *) let%expect_test _ = let module RLimit = Core_unix.RLimit in Result.iter RLimit.nice ~f:(fun rlimit_nice -> let test_parameters = let nice_limit = RLimit.get rlimit_nice in match nice_limit.max with | Infinity -> let max = 40 in `Test ({ nice_limit with cur = Limit (Int64.of_int_exn max) }, max) | Limit max -> if Int64.( < ) max (Int64.of_int 2) then `Cannot_test else `Test ({ nice_limit with cur = Limit max }, Int64.to_int_exn max) in match test_parameters with | `Cannot_test -> () | `Test (nice_limit, cur_limit) -> Core_unix.RLimit.set rlimit_nice nice_limit; for priority = 20 - cur_limit to 20 do let initial_priority = Priority.of_int priority in match Linux_ext.getpriority, Linux_ext.pr_get_name with | Error _, _ | _, Error _ -> () | Ok getpriority, Ok get_name -> let t = ok_exn (create ~max_num_threads:2 ()) in let check4 ~name ~priority (check : ?name:string -> ?priority:Priority.t -> unit -> unit Or_error.t) = ok_exn (check ()); ok_exn (check ~name ()); ok_exn (check ~priority ()); ok_exn (check ~name ~priority ()); wait_until_no_unfinished_work t in check4 ~name:"new name" ~priority:(Priority.decr initial_priority) (fun ?name ?priority () -> add_work ?priority ?name t (fun () -> assert ( String.equal (get_name ()) (Option.value name ~default:default_thread_name)); assert ( Priority.equal (getpriority ()) (Option.value priority ~default:(default_priority t))))); check4 ~name:"new name" ~priority:(Priority.decr initial_priority) (fun ?name ?priority () -> let helper_thread = ok_exn (create_helper_thread t ?priority ?name) in let default_thread_name = Option.value name ~default:default_thread_name in let default_priority = Option.value priority ~default:(default_priority t) in check4 ~name:"new name 2" ~priority:(Priority.decr initial_priority) (fun ?name ?priority () -> add_work_for_helper_thread ?priority ?name t helper_thread (fun () -> assert ( String.equal (get_name ()) (Option.value name ~default:default_thread_name)); assert ( Priority.equal (getpriority ()) (Option.value priority ~default:default_priority)))); finished_with_helper_thread t helper_thread; Ok ()); finished_with t done) ;; (* [Core_thread.create] failure *) let%expect_test _ = let t = ok_exn (create ~max_num_threads:2 ()) in (* simulate failure *) set_last_thread_creation_failure t (Time_ns.now ()); set_thread_creation_failure_lockout t (sec 100.); let finish_work = Thread_safe_ivar.create () in ok_exn (add_work t (fun () -> Thread_safe_ivar.read finish_work)); assert (has_unstarted_work t); set_thread_creation_failure_lockout t (sec 0.); ok_exn (add_work t (fun () -> Thread_safe_ivar.read finish_work)); Thread_safe_ivar.fill finish_work (); wait_until_no_unfinished_work t ;; let%expect_test "become_helper_thread" = let t = ok_exn (create ~max_num_threads:1 ()) in let helper_thread = Thread_safe_ivar.create () in ok_exn (add_work t (fun () -> Thread_safe_ivar.fill helper_thread (ok_exn (become_helper_thread t)))); let helper_thread = Thread_safe_ivar.read helper_thread in let helper_thread_finished = Thread_safe_ivar.create () in ok_exn (add_work_for_helper_thread t helper_thread (fun () -> Thread_safe_ivar.fill helper_thread_finished ())); Thread_safe_ivar.read helper_thread_finished; finished_with_helper_thread t helper_thread; wait_until_no_unfinished_work t ;; (* Affinity *) module Cpuset = Cpu_affinity.Cpuset let%expect_test _ = let t = ok_exn (create ~max_num_threads:1 ()) in assert ( match cpu_affinity t with | Inherit -> true | Cpuset _ -> false) ;; let%expect_test _ = let cpuset = Int.Set.singleton 0 |> Cpuset.create_exn in let t = ok_exn (create ~cpu_affinity:(Cpuset cpuset) ~max_num_threads:1 ()) in assert ( match cpu_affinity t with | Inherit -> true | Cpuset actual_cpuset -> Cpuset.equal actual_cpuset cpuset) ;; let test_affinity ~(cpu_affinity : Cpu_affinity.t) ~max_num_threads = let get_affinity_self () = ok_exn Thread.getaffinity_self_exn () |> Cpuset.create_exn in let expected_cpuset = match cpu_affinity with | Inherit -> get_affinity_self () | Cpuset cpuset -> cpuset in let reported_cpuset = ref None in let t = ok_exn (create ~cpu_affinity ~max_num_threads ()) in ok_exn (add_work t (fun () -> reported_cpuset := Some (get_affinity_self ()))); finished_with t; wait_until_no_unfinished_work t; assert (Cpuset.equal expected_cpuset (Option.value_exn !reported_cpuset)) ;; let%expect_test "inherit affinity" = test_affinity ~cpu_affinity:Inherit ~max_num_threads:1 ;; let%expect_test "empty cpuset is invalid" = require_does_raise [%here] ~hide_positions:true (fun () -> ignore (Cpuset.create_exn Int.Set.empty : Cpuset.t)); [%expect {| ("validation failed" ( () ("validation errors" (("" "value 0 < bound 1"))) lib/thread_pool_cpu_affinity/src/thread_pool_cpu_affinity.ml:LINE:COL)) |}] ;; let%expect_test "can affinitize to a single core" = test_affinity ~cpu_affinity:(Cpuset (Int.Set.singleton 0 |> Cpuset.create_exn)) ~max_num_threads:1 ;; module Quickcheck_cpuset = struct type t = Int.Set.t [@@deriving sexp_of] let quickcheck_generator = let cpuids = ok_exn Thread.getaffinity_self_exn () |> Int.Set.to_list in (* Fail if it's not possible to test on more than one CPU. We already have a test above to cover that case, so the rest of this would be pointless. *) let cpucount = List.length cpuids in assert (cpucount > 1); let open Base_quickcheck in let open Generator.Let_syntax in let%bind permutation = Generator.list_permutations cpuids in let%map count = Generator.int_inclusive 1 (cpucount - 1) in List.take permutation count |> Int.Set.of_list ;; let quickcheck_shrinker = Base_quickcheck.Shrinker.atomic end let%expect_test "can affinitize to any subset on the system" = Base_quickcheck.Test.run_exn ~config:{ Base_quickcheck.Test.default_config with test_count = 100 } ~f:(fun cpuset -> test_affinity ~cpu_affinity:(Cpuset (cpuset |> Cpuset.create_exn)) ~max_num_threads:1) (module Quickcheck_cpuset) ;; end) ;; async_unix-0.15.0/thread_pool/test/test_thread_pool.mli000066400000000000000000000000551420273305200232740ustar00rootroot00000000000000(*_ This signature is deliberately empty. *) async_unix-0.15.0/thread_safe_ivar/000077500000000000000000000000001420273305200172415ustar00rootroot00000000000000async_unix-0.15.0/thread_safe_ivar/README.md000066400000000000000000000000761420273305200205230ustar00rootroot00000000000000# Thread_safe_ivar A simple thread-safe ivar implementation. async_unix-0.15.0/thread_safe_ivar/src/000077500000000000000000000000001420273305200200305ustar00rootroot00000000000000async_unix-0.15.0/thread_safe_ivar/src/dune000066400000000000000000000002301420273305200207010ustar00rootroot00000000000000(library (name thread_safe_ivar) (public_name async_unix.thread_safe_ivar) (libraries core core_unix.error_checking_mutex) (preprocess (pps ppx_jane)))async_unix-0.15.0/thread_safe_ivar/src/import.ml000066400000000000000000000000631420273305200216730ustar00rootroot00000000000000open! Core include Int.Replace_polymorphic_compare async_unix-0.15.0/thread_safe_ivar/src/thread_safe_ivar.ml000066400000000000000000000022611420273305200236510ustar00rootroot00000000000000open! Core open! Import module Mutex = Error_checking_mutex type 'a t = { mutable value : 'a option ; mutable num_waiting : int ; mutex : (Mutex.t [@sexp.opaque] (* Threads that do [read t] when [is_none t.value] block using [Condition.wait t.full]. When [fill] sets [t.value], it uses [Condition.broadcast] to wake up all the blocked threads. *)) ; full : (Condition.t[@sexp.opaque]) } [@@deriving sexp_of] let create () = { value = None; num_waiting = 0; mutex = Mutex.create (); full = Condition.create () } ;; let critical_section t ~f = Mutex.critical_section t.mutex ~f let fill t v = critical_section t ~f:(fun () -> if is_some t.value then raise_s [%message "Thread_safe_ivar.fill of full ivar"]; t.value <- Some v; Condition.broadcast t.full) ;; let read t = match t.value with | Some v -> v | None -> critical_section t ~f:(fun () -> match t.value with | Some v -> v | None -> t.num_waiting <- t.num_waiting + 1; Condition.wait t.full t.mutex; t.num_waiting <- t.num_waiting - 1; (match t.value with | Some v -> v | None -> assert false)) ;; async_unix-0.15.0/thread_safe_ivar/src/thread_safe_ivar.mli000066400000000000000000000003451420273305200240230ustar00rootroot00000000000000(** A simple thread-safe ivar implementation. *) open! Core open! Import type 'a t [@@deriving sexp_of] val create : unit -> _ t val fill : 'a t -> 'a -> unit (** [read t] blocks until [t] is filled. *) val read : 'a t -> 'a async_unix-0.15.0/thread_safe_pipe/000077500000000000000000000000001420273305200172355ustar00rootroot00000000000000async_unix-0.15.0/thread_safe_pipe/README.md000066400000000000000000000001551420273305200205150ustar00rootroot00000000000000# Thread_safe_pipe A thread-safe pipe is a thread-safe interface to the write end of a normal `Async.Pipe`. async_unix-0.15.0/thread_safe_pipe/src/000077500000000000000000000000001420273305200200245ustar00rootroot00000000000000async_unix-0.15.0/thread_safe_pipe/src/dune000066400000000000000000000001771420273305200207070ustar00rootroot00000000000000(library (name thread_safe_pipe) (public_name async_unix.thread_safe_pipe) (libraries async_unix) (preprocess (pps ppx_jane)))async_unix-0.15.0/thread_safe_pipe/src/import.ml000066400000000000000000000000631420273305200216670ustar00rootroot00000000000000open! Core include Int.Replace_polymorphic_compare async_unix-0.15.0/thread_safe_pipe/src/thread_safe_pipe.ml000066400000000000000000000040241420273305200236400ustar00rootroot00000000000000(* Unit tests are in ../../lib_test/thread_safe_test.ml. *) open! Core open! Async_kernel open! Async_unix open! Import type 'a t = 'a Pipe.Writer.t [@@deriving sexp_of] let in_async ?wakeup_scheduler f = Thread_safe.run_in_async_exn ?wakeup_scheduler f let in_async_wait f = Thread_safe.run_in_async_wait_exn f module Written_or_closed = struct type t = | Written | Closed end module If_closed = struct type 'a t = | Raise : unit t | Return : Written_or_closed.t t let closed : type a. a t -> a = function | Raise -> raise_s [%message "pipe is closed"] | Return -> Closed ;; let written : type a. a t -> a = function | Raise -> () | Return -> Written ;; end let in_async_unless_closed ?wakeup_scheduler t f ~if_closed = in_async ?wakeup_scheduler (fun () -> if Pipe.is_closed t then If_closed.closed if_closed else ( f (); If_closed.written if_closed)) ;; let in_async_unless_closed_wait t f ~if_closed = in_async_wait (fun () -> if Pipe.is_closed t then return (If_closed.closed if_closed) else ( let%map () = f () in If_closed.written if_closed)) ;; let create () = if Thread_safe.am_holding_async_lock () then Pipe.create () else in_async Pipe.create ;; let pushback t = in_async_wait (fun () -> Pipe.pushback t) let transfer_in t ~from ~if_closed = in_async_unless_closed_wait t ~if_closed (fun () -> Pipe.transfer_in t ~from) ;; let write t a ~if_closed = in_async_unless_closed_wait t ~if_closed (fun () -> Pipe.write t a) ;; let transfer_in_without_pushback ?wakeup_scheduler t ~from ~if_closed = in_async_unless_closed ?wakeup_scheduler t ~if_closed (fun () -> Pipe.transfer_in_without_pushback t ~from) ;; let write_without_pushback ?wakeup_scheduler t a ~if_closed = in_async_unless_closed ?wakeup_scheduler t ~if_closed (fun () -> Pipe.write_without_pushback t a) ;; let close t = in_async (fun () -> Pipe.close t) let is_closed t = in_async (fun () -> Pipe.is_closed t) let closed t = in_async_wait (fun () -> Pipe.closed t) async_unix-0.15.0/thread_safe_pipe/src/thread_safe_pipe.mli000066400000000000000000000055501420273305200240160ustar00rootroot00000000000000(** A thread-safe pipe is a thread-safe interface to the write end of a normal [Async.Pipe]. {b All operations except for [create] must be called from threads outside Async}, while [create] can be called from inside or outside Async. For [Pipe] functions that return a [unit Deferred.t], the analog in [Thread_safe_pipe] blocks. For documentation of [wakeup_scheduler], see the {!Thread_safe} module. *) open! Core open! Async_kernel open! Import (** The writer end of the pipe. *) type 'a t [@@deriving sexp_of] (** [create ()] returns a reader end, which must be used inside Async, and a writer end, which must be used outside Async. [create] can be called inside or outside Async. *) val create : unit -> 'a Pipe.Reader.t * 'a t (** All the following functions must be called outside Async. They behave as their counterpart in the {!Pipe} module. *) (** [pushback writer] blocks the current thread until the pipe is empty or closed. *) val pushback : _ t -> unit module Written_or_closed : sig type t = | Written | Closed end (** Functions that write elements to the pipe take an [If_closed.t] argument to specify how to deal with the possibility that the pipe is closed. The alternatives are to [Raise] on a closed pipe, or [Return] a variant indicating whether the pipe is closed. This allows lightweight syntax for calls that want to raise if the pipe is closed: {[ write t a ~if_closed:Raise ]} It also allows lightweight syntax for calls that want to match on whether the pipe was closed: {[ match write t a ~if_closed:Return with | Closed -> ... | Written -> ... ]} Returning a variant is essential when one wants to distinguish a closed pipe from other errors. Also, since pipe-writing functions acquire the Async lock, it would be incorrect (due to races) to check [is_closed] prior to the lock acquisition. *) module If_closed : sig type 'a t = | Raise : unit t | Return : Written_or_closed.t t end (** [transfer_in_without_pushback'] and [write_without_pushback] transfer the element(s) into the pipe and return immediately. *) val transfer_in_without_pushback : ?wakeup_scheduler:bool (** default is [true] *) -> 'a t -> from:'a Queue.t -> if_closed:'b If_closed.t -> 'b val write_without_pushback : ?wakeup_scheduler:bool (** default is [true] *) -> 'a t -> 'a -> if_closed:'b If_closed.t -> 'b (** [transfer_in] and [write] transfer the element(s) into the pipe and block the current thread until the pipe is empty or closed (like {!pushback}). *) val transfer_in : 'a t -> from:'a Queue.t -> if_closed:'b If_closed.t -> 'b val write : 'a t -> 'a -> if_closed:'b If_closed.t -> 'b val close : _ t -> unit val is_closed : _ t -> bool (** [closed writer] blocks the current thread until the pipe is closed. *) val closed : _ t -> unit async_unix-0.15.0/thread_safe_pipe/test/000077500000000000000000000000001420273305200202145ustar00rootroot00000000000000async_unix-0.15.0/thread_safe_pipe/test/dune000066400000000000000000000001461420273305200210730ustar00rootroot00000000000000(library (name thread_safe_pipe_test) (libraries async thread_safe_pipe) (preprocess (pps ppx_jane)))async_unix-0.15.0/thread_safe_pipe/test/test_thread_safe_pipe.ml000066400000000000000000000027251420273305200250750ustar00rootroot00000000000000open! Core open Poly open! Async open! Thread_safe_pipe let%expect_test "Thread_safe_pipe" = let module P = Thread_safe_pipe in let r, p = P.create () in assert ( try P.write p 13 ~if_closed:Raise; false with | _ -> true); let throttle = Throttle.create ~continue_on_error:false ~max_concurrent_jobs:1 in let run_in_thread f = don't_wait_for (Throttle.enqueue throttle (fun () -> In_thread.run f)) in let num_elts = 100 in for i = 0 to num_elts - 1 do run_in_thread (fun () -> P.write p i ~if_closed:Raise) done; run_in_thread (fun () -> P.close p); Pipe.to_list r >>| fun list -> assert (list = List.init num_elts ~f:Fn.id) ;; let%expect_test "Thread_safe_pipe2" = In_thread.run (fun () -> Thread_safe_pipe.create ()) >>= fun (pipe_reader, pipe_writer) -> assert ( (* [write] raises if we're in Async. *) try Thread_safe_pipe.write pipe_writer 13 ~if_closed:Raise; false with | _ -> true); let throttle = Throttle.create ~continue_on_error:false ~max_concurrent_jobs:1 in let run_in_thread f = don't_wait_for (Throttle.enqueue throttle (fun () -> In_thread.run f)) in let num_elts = 100 in for i = 0 to num_elts - 1 do run_in_thread (fun () -> Thread_safe_pipe.write_without_pushback pipe_writer i ~if_closed:Raise) done; run_in_thread (fun () -> Thread_safe_pipe.close pipe_writer); Pipe.to_list pipe_reader >>| fun list -> assert (list = List.init num_elts ~f:Fn.id) ;; async_unix-0.15.0/thread_safe_pipe/test/test_thread_safe_pipe.mli000066400000000000000000000000551420273305200252400ustar00rootroot00000000000000(*_ This signature is deliberately empty. *)