swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

6
unikernel/duniverse/lwt/.github/dependabot.yml vendored Normal file
View file

@ -0,0 +1,6 @@
version: 2
updates:
- package-ecosystem: github-actions
directory: /
schedule:
interval: weekly

100
unikernel/duniverse/lwt/.github/workflows/workflow.yml vendored Normal file
View file

@ -0,0 +1,100 @@
name: Builds, tests & co
on:
pull_request:
push:
schedule:
# Prime the caches every Monday
- cron: 0 1 * * MON
jobs:
build-and-test:
strategy:
fail-fast: false
matrix:
os:
- ubuntu-latest
ocaml-compiler:
- "4.08"
- "4.09"
- "4.10"
- "4.11"
- "4.12"
- "4.13"
- "4.14"
- "5.0"
- "5.1"
- "5.2"
- "5.3"
libev:
- true
- false
include:
- os: ubuntu-24.04-arm
ocaml-compiler: "5.3"
libev: false
- os: macos-latest
ocaml-compiler: "5.3"
libev: false
- os: windows-latest
ocaml-compiler: "5.3"
libev: false
runs-on: ${{ matrix.os }}
steps:
- name: set ppx-related variables
id: configppx
shell: bash
run: |
case ${{ matrix.ocaml-compiler }} in
"4.08"|"4.09"|"4.10"|"4.11"|"4.12"|"4.13"|"4.14"|"5.0")
echo "letppx=false"
echo "letppx=false" >> "$GITHUB_OUTPUT"
;;
"5.1"|"5.2"|"5.3")
echo "letppx=true"
echo "letppx=true" >> "$GITHUB_OUTPUT"
;;
*)
printf "unrecognised version %s\n" "${{ matrix.ocaml-compiler }}";
exit 1
;;
esac
- name: Checkout tree
uses: actions/checkout@v5
- name: Set-up OCaml
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: ${{ matrix.ocaml-compiler }}
- run: opam install conf-libev
if: ${{ matrix.libev == true }}
- run: opam install ./lwt.opam ./lwt_react.opam ./lwt_retry.opam ./lwt_ppx.opam --deps-only --with-test
- run: opam install ./lwt_ppx__ppx_let_tests.opam --deps-only --with-test
if: ${{ fromJSON(steps.configppx.outputs.letppx) }}
- run: opam exec -- dune build --only-packages lwt,lwt_react,lwt_retry
- run: opam exec -- dune build --only-packages lwt,lwt_ppx__ppx_let_tests
if: ${{ fromJSON(steps.configppx.outputs.letppx) }}
- run: opam exec -- dune runtest --only-packages lwt,lwt_react,lwt_retry,lwt_ppx
- run: opam exec -- dune runtest --only-packages lwt,lwt_ppx__ppx_let_tests
if: ${{ fromJSON(steps.configppx.outputs.letppx) }}
lint-opam:
runs-on: ubuntu-latest
steps:
- name: Checkout tree
uses: actions/checkout@v5
- name: Set-up OCaml
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: 5
- uses: ocaml/setup-ocaml/lint-opam@v3

23
unikernel/duniverse/lwt/.gitignore vendored Normal file
View file

@ -0,0 +1,23 @@
_build
src/unix/discover_arguments
*.flag
# OPAM 2.0 local switches.
_opam
# Coverage analysis.
bisect*.out
_coverage/
# For local work, tests, etc.
scratch/
# Autogenerated by jbuider
.merlin
*.install
# BuckleScript output.
lib/
# Wikidoc output.
/docs/api/

1209
unikernel/duniverse/lwt/CHANGES Normal file
View file

File diff suppressed because it is too large Load diff

12
unikernel/duniverse/lwt/CODE_OF_CONDUCT.md Normal file
View file

@ -0,0 +1,12 @@
# Code of Conduct
This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md).
# Enforcement
This project follows the OCaml Code of Conduct [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement).
To report any violations, please contact Jérôme
Vouillon, Raphaël Proust, Vincent Balat, Hugo Heuzard and Gabriel
Radanne at <moderation [at] ocsigen [dot] org>
(or some of them individually).

19
unikernel/duniverse/lwt/LICENSE.md Normal file
View file

@ -0,0 +1,19 @@
Copyright (c) 1999-2020, the Authors of Lwt (docs/AUTHORS)
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.

74
unikernel/duniverse/lwt/Makefile Normal file
View file

@ -0,0 +1,74 @@
# Default rule
.PHONY: default
default: build
# build the usual development packages
.PHONY: build
build:
dune build
# run unit tests for package lwt
.PHONY: test
test: build
dune runtest
# Promote expect test output.
.PHONY : promote
promote :
for FILE in $$(ls _build/default/test/ppx_expect/cases/*.fixed); \
do \
EXPECT=test/ppx_expect/cases/$$(basename $${FILE%.fixed}).expect; \
cp $$FILE $$EXPECT; \
done
# Install dependencies needed during development.
.PHONY : dev-deps
dev-deps :
opam install . --deps-only --yes
# Use Dune+odoc to generate static html documentation.
# Currently requires ocaml 4.03.0 to install odoc.
.PHONY: doc
doc:
dune build @doc
# Build HTML documentation with ocamldoc
.PHONY: doc-api-html
doc-api-html: build
$(MAKE) -C docs api/html/index.html
# Build wiki documentation with wikidoc
# requires ocaml 4.03.0 and pinning the repo
# https://github.com/ocsigen/wikidoc
.PHONY: doc-api-wiki
doc-api-wiki: build
$(MAKE) -C docs api/wiki/index.wiki
# ppx_let integration test.
.PHONY : ppx_let-test
ppx_let-test :
dune build test/ppx_let/test.exe
dune exec test/ppx_let/test.exe
.PHONY: clean
clean :
dune clean
rm -fr docs/api
rm -f src/unix/discover_arguments
rm -rf _coverage/
EXPECTED_FILES := \
--expect src/core/ \
--expect src/react/ \
--expect src/unix/ \
--do-not-expect src/unix/config/ \
--do-not-expect src/unix/lwt_gc.ml \
--do-not-expect src/unix/lwt_throttle.ml \
--do-not-expect src/unix/unix_c/
.PHONY: coverage
coverage :
dune runtest --instrument-with bisect_ppx --force
bisect-ppx-report html $(EXPECTED_FILES)
bisect-ppx-report summary
@echo See _coverage/index.html

181
unikernel/duniverse/lwt/README.md Normal file
View file

@ -0,0 +1,181 @@
# Lwt
[![version][version]][releases] [![GitHub Actions status][github-actions-img]][github-actions]
[version]: https://img.shields.io/github/v/release/ocsigen/lwt
[releases]: https://github.com/ocsigen/lwt/releases
[github-actions]: https://github.com/ocsigen/lwt/actions
[github-actions-img]: https://github.com/ocsigen/lwt/actions/workflows/workflow.yml/badge.svg?branch=master
Lwt is a concurrent programming library for OCaml. It provides a single data
type: the *promise*, which is a value that will become determined in the future.
Creating a promise spawns a computation. When that computation is I/O, Lwt runs
it in parallel with your OCaml code.
OCaml code, including creating and waiting on promises, is run in a single
thread by default, so you don't have to worry about locking or preemption. You
can detach code to be run in separate threads on an opt-in basis.
Here is a simplistic Lwt program which requests the Google front page, and fails
if the request is not completed in five seconds:
```ocaml
open Lwt.Syntax
let () =
let request =
let* addresses = Lwt_unix.getaddrinfo "google.com" "80" [] in
let google = Lwt_unix.((List.hd addresses).ai_addr) in
Lwt_io.(with_connection google (fun (incoming, outgoing) ->
let* () = write outgoing "GET / HTTP/1.1\r\n" in
let* () = write outgoing "Connection: close\r\n\r\n" in
let* response = read incoming in
Lwt.return (Some response)))
in
let timeout =
let* () = Lwt_unix.sleep 5. in
Lwt.return None
in
match Lwt_main.run (Lwt.pick [request; timeout]) with
| Some response -> print_string response
| None -> prerr_endline "Request timed out"; exit 1
(* ocamlfind opt -package lwt.unix -linkpkg example.ml && ./a.out *)
```
In the program, functions such as `Lwt_io.write` create promises. The
`let* ... in` construct is used to wait for a promise to become determined; the
code after `in` is scheduled to run in a "callback." `Lwt.pick` races promises
against each other, and behaves as the first one to complete. `Lwt_main.run`
forces the whole promise-computation network to be executed. All the visible
OCaml code is run in a single thread, but Lwt internally uses a combination of
worker threads and non-blocking file descriptors to resolve in parallel the
promises that do I/O.
<br/>
### Overview
Lwt compiles to native code on Linux, macOS, Windows, and other systems. It's
also routinely compiled to JavaScript for the front end and Node by js_of_ocaml.
In Lwt,
- The [core library `Lwt`][core] provides promises...
- ...and a few pure-OCaml helpers, such as promise-friendly [mutexes][mutex],
[condition variables][cond], and [mvars][mvar].
- There is a big Unix binding, [`Lwt_unix`][unix] that binds almost every Unix
system call. A higher-level module [`Lwt_io`][io] provides nice I/O channels.
- [`Lwt_process`][process] is for subprocess handling.
- [`Lwt_preemptive`][preemptive] spawns system threads.
- The [PPX syntax][ppx] allows using all of the above without going crazy!
- There are also some other helpers, such as [`Lwt_react`][react] for reactive
programming. See the table of contents on the linked manual pages!
[core]: https://ocsigen.org/lwt/latest/api/Lwt
[cond]: https://ocsigen.org/lwt/latest/api/Lwt_condition
[mutex]: https://ocsigen.org/lwt/latest/api/Lwt_mutex
[mvar]: https://ocsigen.org/lwt/latest/api/Lwt_mvar
[unix]: https://ocsigen.org/lwt/latest/api/Lwt_unix
[io]: https://ocsigen.org/lwt/latest/api/Lwt_io
[process]: https://ocsigen.org/lwt/latest/api/Lwt_process
[preemptive]: https://ocsigen.org/lwt/latest/api/Lwt_preemptive
[ppx]: https://ocsigen.org/lwt/latest/api/Ppx_lwt
[react]: https://ocsigen.org/lwt/latest/api/Lwt_react
<br/>
## Installing
1. Use your system package manager to install a development libev package.
It is often called `libev-dev` or `libev-devel`.
2. `opam install conf-libev lwt`
<br/>
## Documentation
We are currently working on improving the Lwt documentation (drastically; we are
rewriting the manual). In the meantime:
- The current manual can be found [here][manual].
- Mirage has a nicely-written [Lwt tutorial][mirage-tutorial].
- An example of a [simple server][counter-server] written in Lwt.
- [Concurrent Programming with Lwt][rwo-lwt] is a nice source of Lwt examples.
They are translations of code from the excellent Real World OCaml, but are
just as useful if you are not reading the book.
*Note: much of the current manual refers to `'a Lwt.t` as "lightweight threads"
or just "threads." This will be fixed in the new manual. `'a Lwt.t` is a
promise, and has nothing to do with system or preemptive threads.*
[manual]: https://ocsigen.org/lwt/
[rwo-lwt]: https://github.com/dkim/rwo-lwt#readme
[mirage-tutorial]: https://mirage.io/docs/tutorial-lwt
[counter-server]: https://baturin.org/code/lwt-counter-server/
<br/>
## Contact
Open an [issue][issues], visit [Discord][discord] chat, ask on
[discuss.ocaml.org][discourse], or on [Stack Overflow][so].
Release announcements are made on [discuss.ocaml.org][discourse]. Watching the
repo for "Releases only" is also an option.
[so]: https://stackoverflow.com/questions/ask?tags=ocaml,lwt,ocaml-lwt
[discourse]: https://discuss.ocaml.org/tag/lwt
[issues]: https://github.com/ocsigen/lwt/issues/new
[discord]: https://discord.com/invite/cCYQbqN
<br/>
## Contributing
- [`CONTRIBUTING.md`][contributing-md] contains tips for working on the code,
such as how to check the code out, how review works, etc. There is also a
high-level outline of the code base.
- [Ask](#contact) us anything, whether it's about working on Lwt, or any
question at all about it :)
- The [documentation](#documentation) always needs proofreading and fixes.
- You are welcome to pick up any other [issue][issues-and-prs], review a PR, add
your opinion, etc.
- Any feedback is welcome, including how to make contributing easier!
[issues-and-prs]: https://github.com/ocsigen/lwt/issues?utf8=%E2%9C%93&q=is%3Aopen
[contributing-md]: https://github.com/ocsigen/lwt/blob/master/docs/CONTRIBUTING.md#readme
<br/>
## Libraries to use with Lwt
- [alcotest](https://github.com/mirage/alcotest/) —
unit testing
- [angstrom](https://github.com/inhabitedtype/angstrom) —
parser combinators
- [cohttp](https://github.com/mirage/ocaml-cohttp) — HTTP client and server
- [cstruct](https://github.com/mirage/ocaml-cstruct) —
interop with C-like structures
- [ezjsonm](https://github.com/mirage/ezjsonm) —
JSON parsing and output
- [faraday](https://github.com/inhabitedtype/faraday) —
serialization combinators
- [logs](https://github.com/dbuenzli/logs) —
logging
- [lwt-parallel](https://github.com/ivg/lwt-parallel) —
distributed computing
- [mwt](https://github.com/hcarty/mwt) — preemptive (system) thread pools
- [opium](https://github.com/rgrinberg/opium) —
web framework
- [lwt_domain](https://github.com/ocsigen/lwt_domain) — domain parallelism when
using Lwt with OCaml 5

18
unikernel/duniverse/lwt/docs/AUTHORS Normal file
View file

@ -0,0 +1,18 @@
Copyright (c) 1999-2008 Jérôme Vouillon
Laboratoire PPS - CNRS Université Paris Diderot
2005 Nataliya Guts, Vincent Balat
Laboratoire PPS - CNRS Université Paris Diderot
2008 Stéphane Glondu
2009 Mauricio Fernandez
2009, 2010 Pierre Chambart
2009-2012 Jérémie Dimino
Laboratoire PPS - CNRS Université Paris Diderot
2014 Peter Zotov
2014, 2018 Gabriel Radanne
2015 Nicolas Ojeda Bar
2016 Simon Cruanes
2016-2018 Anton Bachin
2017 Joseph Thomas
2017 Andrew Ray
2020 Raphaël Proust
Nomadic Labs

277
unikernel/duniverse/lwt/docs/CONTRIBUTING.md Normal file
View file

@ -0,0 +1,277 @@
# Contributing to the Lwt code
Contributing to Lwt doesn't only mean writing code! Asking questions, fixing
docs, etc., are all valuable contributions. For notes on contributing in
general, see [Contributing][contributing] in the Lwt `README`. This file
contains extra information for working on code specifically.
This file is meant to be an aid, not a hindrance. If you think you already
have a good idea of what to do, go ahead and work without reading this :)
<br/>
#### Table of contents
- [General](#General)
- [OPAM+git workflow](#Workflow)
- [Getting the code](#Checkout)
- [Testing](#Testing)
- [Testing with coverage analysis](#Test_with_coverage_analysis)
- [Getting your change merged](#Getting_your_change_merged)
- [Making additional changes](#Making_additional_changes)
- [Cleaning up](#Cleaning_up)
- [Internal documentation](#Documentation)
- [Code overview](#Code_overview)
<br/>
<a id="General"></a>
## General
1. If you get stuck, or have any question, please [ask][contact]!
2. If you start working, but then life interferes and you don't want to
continue, there is no problem in stopping. This can be for any reason
whatsoever, and you don't have to tell anyone what that reason is. Lwt
respects your time and your needs.
3. If a maintainer is trying your patience (hopefully by accident) by making you
fix too many nits, do excessive history rewriting, or something else like
that, please let them know! Lwt doesn't want to tire you out!
4. To find something to work on, you can look at the [easy issues][easy]. If
those don't look interesting, some [medium issues][medium] are
self-contained. If you [contact][contact] the maintainers, they may be able
to suggest a few. Otherwise, you are welcome to work on anything at all.
5. If you begin working on an issue, it's good to leave a comment on it to claim
it. This prevents multiple people from doing the same work.
[contact]: https://github.com/ocsigen/lwt#contact
[contributing]: https://github.com/ocsigen/lwt#contributing
[easy]: https://github.com/ocsigen/lwt/labels/easy
[medium]: https://github.com/ocsigen/lwt/labels/medium
<br/>
<a id="Workflow"></a>
## OPAM+git workflow
<a id="Checkout"></a>
#### Getting the code
To get started, fork the Lwt repo by clicking on the "Fork" button at the very
top of this page. You will now have a repository at
`https://github.com/your-user-name/lwt`. Let's clone it to your machine:
```
git clone https://github.com/your-user-name/lwt.git
cd lwt/
```
Now, we need to install Lwt's development dependencies. Before doing that, you
may want to switch to a special OPAM switch for working on Lwt:
```
opam switch create . 4.08.2 --no-install # optional
eval `opam config env` # optional
make dev-deps
```
On most systems, you should also [install libev][installing]:
```
your-package-manager install libev-devel
opam install conf-libev
```
[installing]: https://github.com/ocsigen/lwt#installing
Now, check out a new branch, and make your changes:
```
git checkout -b my-awesome-change
```
<a id="Testing"></a>
#### Testing
Each time you are ready to test, run
```
make test
```
If you want to test your development branch using another OPAM package that
depends on Lwt, install your development copy of Lwt with:
```
opam pin add lwt .
opam install lwt
```
If you make further changes, you can install your updated code with:
```
opam upgrade lwt
```
Since Lwt is pinned, these commands will install Lwt from your modified code.
All installed OPAM packages that depend on Lwt will be rebuilt against your
modified code when you run these commands.
<a id="Testing_with_coverage_analysis"></a>
#### Testing with coverage analysis
To generate coverage reports, run
```
make coverage
```
in the Lwt repo. To view the coverage report, open `_coverage/index.html` in
your browser.
<a id="Getting_your_change_merged"></a>
#### Getting your change merged
When you are ready, commit your change:
```
git commit
```
You can see examples of commit messages in the Git log; run `git log`. Now,
upload your commit(s) to your fork:
```
git push -u origin my-awesome-change
```
Go to the GitHub web interface for your Lwt fork
(`https://github.com/your-user-name/lwt`), and click on the New Pull Request
button. Follow the instructions, and open the pull request.
This will trigger automatic building and testing of your change on many versions
of OCaml, and several operating systems, in [GitHub Actions][github-actions].
You can even a submit a preliminary PR just to trigger
these tests – just say in the description that it's not ready for review!
At about the same time, a (hopefully!) friendly maintainer will review your
change and start a conversation with you. Ultimately, this will result in a
merged PR and a "thank you!" :smiley: You'll be immortalized in the history,
mentioned in the changelog, and you will have helped a bunch of users have an
easier time with Lwt.
Finally, take a nice break :) This process can be a lot!
<a id="Making_additional_changes"></a>
#### Making additional changes
If additional changes are needed after you open the PR, make them in your branch
locally, commit them, and run:
```
git push
```
This will push the changes to your fork, and GitHub will automatically update
the PR.
#### Tidy history
In some cases, you may be asked to rebase or squash your PR for a cleaner
history (it's normal). If that happens, you will need to run some combination of
`git rebase master`, `git rebase -i master`, and/or `git cherry-pick`. There
isn't really enough space to explain these commands here, but:
- We encourage you to find examples and documentation for them online.
- You can always ask a maintainer for help using them.
- You can always ask a maintainer to do it for you (and we will usually offer).
We can tell you what commands we ran and why.
Afterwards, `git push -f` will force the new history into the PR.
If we do this rewriting, it is usually at the very end, right before merging the
PR. This is to avoid interfering with reviewers while they are still reviewing
it.
[github-actions]: https://github.com/ocsigen/lwt/actions
<br/>
<a id="Documentation"></a>
## Internal documentation
Lwt internal documentation is currently pretty sparse, but we are working on
fixing that.
- The bulk of documentation is still the [manual][manual].
- The [internals of the Lwt core][lwt.ml] are well-documented.
- Working on the Unix binding (`Lwt_unix`, `Lwt_bytes`, etc.) sometimes requires
writing C code. To make this easier, we have thoroughly
[documented `Lwt_unix.getcwd`][unix-model] as a model function.
- Everything else is sparsely documented in comments.
[manual]: https://ocsigen.org/lwt/
[lwt.ml]: https://github.com/ocsigen/lwt/blob/master/src/core/lwt.ml
[unix-model]: https://github.com/ocsigen/lwt/blob/99d1ec8b5c159456855eb2f55ddab77207bc92b3/src/unix/unix_c/unix_getcwd_job.c#L36
<br/>
<a id="Code_overview"></a>
## Code overview
Lwt is separated into several layers and sub-libraries, grouped by directory.
This list surveys them, roughly in order of importance.
- [`src/core/`][core-dir] is the "core" library. It is written in pure OCaml,
so it is portable across all systems and to JavaScript.
The major file here is [`src/core/lwt.ml`][lwt.ml], which implements the main
type, [`'a Lwt.t`][Lwt.t]. Also here are some pure-OCaml data structures and
synchronization primitives. Most of the modules besides `Lwt` are relatively
trivial – the only exception to this is [`Lwt_stream`][Lwt_stream].
The code in `src/core/` doesn't know how to do I/O – that is system specific.
On Unix (including Windows), I/O is provided by the Unix binding (see below).
On js_of_ocaml, it is provided by `Lwt_js`, a module distributed with
js_of_ocaml.
- [`src/ppx/`][ppx-dir] is the Lwt PPX. It is also portable, but separated into
its own little code base, as it is an optional separate library.
- [`src/unix/`][unix-dir] is the Unix binding, i.e. [`Lwt_unix`][Lwt_unix],
[`Lwt_io`][Lwt_io], [`Lwt_main`][Lwt_main], some other related modules, and a
bunch of [C code][c]. This is what actually does I/O, maintains a worker
thread pool, etc. This is not portable to JavaScript. It supports Unix and
Windows. We want to write a future pair of Node.js and Unix/Windows bindings,
so that code using them is portable, even if two separate sets of bindings
are required. See [#328][issue-328].
- [`src/react/`][react-dir] provides the separate library
[`Lwt_react`][Lwt_react]. This is basically an independent project that lives
in the Lwt repo.
- [`src/util/`][util-dir] contains various scripts, such as the
[configure script][configure.ml] scripts, etc.
[core-dir]: https://github.com/ocsigen/lwt/tree/master/src/core
[lwt.ml]: https://github.com/ocsigen/lwt/blob/master/src/core/lwt.ml
[Lwt.t]: https://github.com/ocsigen/lwt/blob/73976987bcae37133e2cd590bcc515afc9e1498e/src/core/lwt.ml#L424
[Lwt_stream]: https://github.com/ocsigen/lwt/blob/master/src/core/lwt_stream.mli
[ppx-dir]: https://github.com/ocsigen/lwt/tree/master/src/ppx
[unix-dir]: https://github.com/ocsigen/lwt/tree/master/src/unix
[Lwt_unix]: https://github.com/ocsigen/lwt/blob/master/src/unix/lwt_unix.cppo.mli
[Lwt_io]: https://github.com/ocsigen/lwt/blob/master/src/unix/lwt_io.mli
[Lwt_main]: https://github.com/ocsigen/lwt/blob/master/src/unix/lwt_main.mli
[c]: https://github.com/ocsigen/lwt/tree/master/src/unix/unix_c
[issue-328]: https://github.com/ocsigen/lwt/issues/328
[react-dir]: https://github.com/ocsigen/lwt/tree/master/src/react
[Lwt_react]: https://github.com/ocsigen/lwt/blob/master/src/react/lwt_react.mli
[util-dir]: https://github.com/ocsigen/lwt/tree/master/src/util

44
unikernel/duniverse/lwt/docs/Makefile Normal file
View file

@ -0,0 +1,44 @@
BLD=../_build/default/src
SRC=../src
PKGS=\
-package bytes -package result \
-package bigarray -package unix \
-package ocaml-migrate-parsetree -package ppx_tools_versioned \
-package react
INCS=\
-I ${BLD}/core/.lwt.objs/byte \
-I ${BLD}/ppx/.ppx_lwt.objs/byte \
-I ${BLD}/react/.lwt_react.objs/byte \
-I ${BLD}/unix/.lwt_unix.objs/byte
MLIS=\
$(wildcard ${SRC}/core/*.mli) \
$(wildcard ${SRC}/ppx/*.mli) \
$(wildcard ${SRC}/react/*.mli) \
$(filter-out ${BLD}/unix/lwt_unix.cppo.mli,$(wildcard ${BLD}/unix/*.mli))
MLIS := $(filter-out %.pp.mli,$(MLIS))
DOCOPT := -colorize-code -short-functors -charset utf-8
.PHONY: doc wikidoc
doc: api/html/index.html
api/html/index.html: ${MLIS} apiref-intro
mkdir -p api/html
ocamlfind ocamldoc ${DOCOPT} -package ocamlbuild,uchar ${PKGS} ${INCS} -intro apiref-intro -html \
-d api/html \
${MLIS}
wikidoc: api/wiki/index.wiki
api/wiki/index.wiki: ${MLIS} apiref-intro
mkdir -p api/wiki
ocamlfind ocamldoc ${DOCOPT} -package ocamlbuild,uchar ${PKGS} ${INCS} -intro apiref-intro \
-d api/wiki \
-i $(shell ocamlfind query wikidoc) -g odoc_wiki.cma \
${MLIS}
.PHONY : clean
clean :
rm -rf api/

85
unikernel/duniverse/lwt/docs/apiref-intro Normal file
View file

@ -0,0 +1,85 @@
{1 Lwt - API Reference}
{2 Core library}
The {e core} library ({e lwt} package) contains the {!Lwt} module, which defines
cooperative threads with all the primitives to manipulate them. It
also provides several general purpose modules, which do not depend on
any external package.
{!modules:
Lwt
Lwt_result
Lwt_condition
Lwt_list
Lwt_mutex
Lwt_mvar
Lwt_pool
Lwt_stream
Lwt_switch
Lwt_sequence
Lwt_seq
Lwt_pqueue
}
{2 Unix bindings}
The {e lwt.unix} package provides:
- the {!Lwt_unix} module, which wrap system calls into cooperative ones
- the {!Lwt_io} module, which defines cooperative byte channel, in
replacement of ones of the standard library
- module helpers for spawning processes, ...
{!modules:
Lwt_gc
Lwt_io
Lwt_main
Lwt_engine
Lwt_process
Lwt_throttle
Lwt_timeout
Lwt_unix
Lwt_bytes
Lwt_fmt
Lwt_sys
}
This package depends on the {e core} library and the {e unix} package.
{2 Reactive programming helpers}
The {e lwt.react} package provides helpers for functional reactive
programming with Lwt. It is based on the {e react} package. The
{!Lwt_react} module is a replacement for the [React] module. It
contains:
- all the functions of the [React] module
- Lwt specific primitives
- cooperative versions of {e react} functions
{!modules:
Lwt_react
}
This package depends on the {e core} library and the {e react} package.
{2 PPX syntax extension}
Syntactic sugar for Lwt, such as [let%lwt x = e in e'] syntax for [bind].
{!modules:
Ppx_lwt
}
{2 Miscellaneous}
The following modules are wrapper for integration of non-Lwt
functions/packages into Lwt.
{!modules:
Lwt_preemptive
}
{2 Index}
{!indexlist}

3
unikernel/duniverse/lwt/docs/dune Normal file
View file

@ -0,0 +1,3 @@
(documentation
(package lwt)
(mld_files :standard))

974
unikernel/duniverse/lwt/docs/manual.mld Normal file
View file

@ -0,0 +1,974 @@
{0 Lwt manual }
{1 Introduction }
When writing a program, a common developer's task is to handle I/O
operations. Indeed, most software interacts with several different
resources, such as:
{ul
{- the kernel, by doing system calls,}
{- the user, by reading the keyboard, the mouse, or any input device,}
{- a graphical server, to build graphical user interface,}
{- other computers, by using the network,}
{- …and so on.}}
When this list contains only one item, it is pretty easy to
handle. However as this list grows it becomes harder and harder to
make everything work together. Several choices have been proposed
to solve this problem:
{ul
{- using a main loop, and integrating all components we are
interacting with into this main loop,}
{- using preemptive system threads.}}
Both solutions have their advantages and their drawbacks. For the
first one, it may work, but it becomes very complicated to write
a piece of asynchronous sequential code. The typical example is
graphical user interfaces freezing and not redrawing themselves
because they are waiting for some blocking part of the code to
complete.
If you already wrote code using preemptive threads, you should know
that doing it right with threads is a difficult job. Moreover, system
threads consume non-negligible resources, and so you can only launch
a limited number of threads at the same time. Thus, this is not a
general solution.
[Lwt] offers a third alternative. It provides promises, which are
very fast: a promise is just a reference that will be filled asynchronously,
and calling a function that returns a promise does not require a new stack,
new process, or anything else. It is just a normal, fast, function call.
Promises compose nicely, allowing us to write highly asynchronous programs.
In the first part, we will explain the concepts of [Lwt], then we will
describe the main modules [Lwt] consists of.
{2 Finding examples }
Additional sources of examples:
{ul
{- {{: https://github.com/dkim/rwo-lwt#readme }Concurrent Programming with Lwt}}
{- {{: https://mirage.io/docs/tutorial-lwt }Mirage Lwt Tutorial}}
{- {{: https://baturin.org/code/lwt-counter-server/ }Simple Server with Lwt}}}
{1 The Lwt core library }
In this section we describe the basics of [Lwt]. It is advised to
start [utop] and try the given code examples.
{2 Lwt concepts }
Let's take a classic function of the [Stdlib] module:
{[
# Stdlib.input_char;;
- : in_channel -> char = <fun>
]}
This function will wait for a character to come on the given input
channel, and then return it. The problem with this function is that it is
blocking: while it is being executed, the whole program will be
blocked, and other events will not be handled until it returns.
Now, let's look at the lwt equivalent:
{[
# Lwt_io.read_char;;
- : Lwt_io.input_channel -> char Lwt.t = <fun>
]}
As you can see, it does not return just a character, but something of
type [char Lwt.t]. The type ['a Lwt.t] is the type
of promises that can be fulfilled later with a value of type ['a].
[Lwt_io.read_char] will try to read a character from the
given input channel and {e immediately} return a promise, without
blocking, whether a character is available or not. If a character is
not available, the promise will just not be fulfilled {e yet}.
Now, let's see what we can do with a [Lwt] promise. The following
code creates a pipe, creates a promise that is fulfilled with the result of
reading the input side:
{[
# let ic, oc = Lwt_io.pipe ();;
val ic : Lwt_io.input_channel = <abstr>
val oc : Lwt_io.output_channel = <abstr>
# let p = Lwt_io.read_char ic;;
val p : char Lwt.t = <abstr>
]}
We can now look at the state of our newly created promise:
{[
# Lwt.state p;;
- : char Lwt.state = Lwt.Sleep
]}
A promise may be in one of the following states:
{ul
{- [Return x], which means that the promise has been fulfilled
with the value [x]. This usually implies that the asynchronous
operation, that you started by calling the function that returned the
promise, has completed successfully.}
{- [Fail exn], which means that the promise has been rejected
with the exception [exn]. This usually means that the asynchronous
operation associated with the promise has failed.}
{- [Sleep], which means that the promise is has not yet been
fulfilled or rejected, so it is {e pending}.}}
The above promise [p] is pending because there is nothing yet
to read from the pipe. Let's write something:
{[
# Lwt_io.write_char oc 'a';;
- : unit Lwt.t = <abstr>
# Lwt.state p;;
- : char Lwt.state = Lwt.Return 'a'
]}
So, after we write something, the reading promise has been fulfilled
with the value ['a'].
{2 Primitives for promise creation }
There are several primitives for creating [Lwt] promises. These
functions are located in the module [Lwt].
Here are the main primitives:
{ul
{- [Lwt.return : 'a -> 'a Lwt.t]
creates a promise which is already fulfilled with the given value}
{- [Lwt.fail : exn -> 'a Lwt.t]
creates a promise which is already rejected with the given exception}
{- [Lwt.wait : unit -> 'a Lwt.t * 'a Lwt.u]
creates a pending promise, and returns it, paired with a resolver (of
type ['a Lwt.u]), which must be used to resolve (fulfill or reject)
the promise.}}
To resolve a pending promise, use one of the following
functions:
{ul
{- [Lwt.wakeup : 'a Lwt.u -> 'a -> unit]
fulfills the promise with a value.}
{- [Lwt.wakeup_exn : 'a Lwt.u -> exn -> unit]
rejects the promise with an exception.}}
Note that it is an error to try to resolve the same promise twice. [Lwt]
will raise [Invalid_argument] if you try to do so.
With this information, try to guess the result of each of the
following expressions:
{[
# Lwt.state (Lwt.return 42);;
# Lwt.state (Lwt.fail Exit);;
# let p, r = Lwt.wait ();;
# Lwt.state p;;
# Lwt.wakeup r 42;;
# Lwt.state p;;
# let p, r = Lwt.wait ();;
# Lwt.state p;;
# Lwt.wakeup_exn r Exit;;
# Lwt.state p;;
]}
{3 Primitives for promise composition }
The most important operation you need to know is [bind]:
{[
val bind : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t
]}
[bind p f] creates a promise which waits for [p] to become
become fulfilled, then passes the resulting value to [f]. If [p] is a
pending promise, then [bind p f] will be a pending promise too,
until [p] is resolved. If [p] is rejected, then the resulting
promise will be rejected with the same exception. For example, consider the
following expression:
{[
Lwt.bind
(Lwt_io.read_line Lwt_io.stdin)
(fun str -> Lwt_io.printlf "You typed %S" str)
]}
This code will first wait for the user to enter a line of text, then
print a message on the standard output.
Similarly to [bind], there is a function to handle the case
when [p] is rejected:
{[
val catch : (unit -> 'a Lwt.t) -> (exn -> 'a Lwt.t) -> 'a Lwt.t
]}
[catch f g] will call [f ()], then wait for it to become
resolved, and if it was rejected with an exception [exn], call
[g exn] to handle it. Note that both exceptions raised with
[Pervasives.raise] and [Lwt.fail] are caught by
[catch].
{3 Cancelable promises }
In some case, we may want to cancel a promise. For example, because it
has not resolved after a timeout. This can be done with cancelable
promises. To create a cancelable promise, you must use the
[Lwt.task] function:
{[
val task : unit -> 'a Lwt.t * 'a Lwt.u
]}
It has the same semantics as [Lwt.wait], except that the
pending promise can be canceled with [Lwt.cancel]:
{[
val cancel : 'a Lwt.t -> unit
]}
The promise will then be rejected with the exception
[Lwt.Canceled]. To execute a function when the promise is
canceled, you must use [Lwt.on_cancel]:
{[
val on_cancel : 'a Lwt.t -> (unit -> unit) -> unit
]}
Note that canceling a promise does not automatically cancel the
asynchronous operation that is going to resolve it. It does, however,
prevent any further chained operations from running. The asynchronous
operation associated with a promise can only be canceled if its implementation
has taken care to set an [on_cancel] callback on the promise that
it returned to you. In practice, most operations (such as system calls)
can't be canceled once they are started anyway, so promise cancellation is
useful mainly for interrupting future operations once you know that a chain of
asynchronous operations will not be needed.
It is also possible to cancel a promise which has not been
created directly by you with [Lwt.task]. In this case, the deepest
cancelable promise that the given promise depends on will be canceled.
For example, consider the following code:
{[
# let p, r = Lwt.task ();;
val p : '_a Lwt.t = <abstr>
val r : '_a Lwt.u = <abstr>
# let p' = Lwt.bind p (fun x -> Lwt.return (x + 1));;
val p' : int Lwt.t = <abstr>
]}
Here, cancelling [p'] will in fact cancel [p], rejecting
it with [Lwt.Canceled]. [Lwt.bind] will then propagate the
exception forward to [p']:
{[
# Lwt.cancel p';;
- : unit = ()
# Lwt.state p;;
- : int Lwt.state = Lwt.Fail Lwt.Canceled
# Lwt.state p';;
- : int Lwt.state = Lwt.Fail Lwt.Canceled
]}
It is possible to prevent a promise from being canceled
by using the function [Lwt.protected]:
{[
val protected : 'a Lwt.t -> 'a Lwt.t
]}
Canceling [(protected p)] will have no effect on [p].
{3 Primitives for concurrent composition }
We now show how to compose several promises concurrently. The
main functions for this are in the [Lwt] module: [join],
[choose] and [pick].
The first one, [join] takes a list of promises and returns a promise
that is waiting for all of them to resolve:
{[
val join : unit Lwt.t list -> unit Lwt.t
]}
Moreover, if at least one promise is rejected, [join l] will be rejected
with the same exception as the first one, after all the promises are resolved.
Conversely, [choose] waits for at least {e one} promise to become
resolved, then resolves with the same value or exception:
{[
val choose : 'a Lwt.t list -> 'a Lwt.t
]}
For example:
{[
# let p1, r1 = Lwt.wait ();;
val p1 : '_a Lwt.t = <abstr>
val r1 : '_a Lwt.u = <abstr>
# let p2, r2 = Lwt.wait ();;
val p2 : '_a Lwt.t = <abstr>
val r2 : '_a Lwt.u = <abstr>
# let p3 = Lwt.choose [p1; p2];;
val p3 : '_a Lwt.t = <abstr>
# Lwt.state p3;;
- : '_a Lwt.state = Lwt.Sleep
# Lwt.wakeup r2 42;;
- : unit = ()
# Lwt.state p3;;
- : int Lwt.state = Lwt.Return 42
]}
The last one, [pick], is the same as [choose], except that it tries to cancel
all other promises when one resolves. Promises created via [Lwt.wait()] are not cancellable
and are thus not cancelled.
{3 Rules }
A callback, like the [f] that you might pass to [Lwt.bind], is
an ordinary OCaml function. [Lwt] just handles ordering calls to these
functions.
[Lwt] uses some preemptive threading internally, but all of your code
runs in the main thread, except when you explicitly opt into additional
threads with [Lwt_preemptive].
This simplifies reasoning about critical sections: all the code in one
callback cannot be interrupted by any of the code in another callback.
However, it also carries the danger that if a single callback takes a very
long time, it will not give [Lwt] a chance to run your other callbacks.
In particular:
{ul
{- do not write functions that may take time to complete, without splitting
them up using [Lwt.pause] or performing some [Lwt] I/O,}
{- do not do I/O that may block, otherwise the whole program will
hang inside that callback. You must instead use the asynchronous I/O
operations provided by [Lwt].}}
{2 The syntax extension }
[Lwt] offers a PPX syntax extension which increases code readability and
makes coding using [Lwt] easier. The syntax extension is documented
in {!Ppx_lwt}.
To use the PPX syntax extension, add the [lwt_ppx] package when
compiling:
{[
$ ocamlfind ocamlc -package lwt_ppx -linkpkg -o foo foo.ml
]}
Or, in [utop]:
{[
# #require "lwt_ppx";;
]}
[lwt_ppx] is distributed in a separate opam package of that same name.
For a brief overview of the syntax, see the Correspondence table below.
{3 Correspondence table }
{table
{tr
{th Without Lwt}
{th With Lwt}}
{tr
{td {[let pattern_1 = expr_1
and pattern_2 = expr2
…
and pattern_n = expr_n in
expr]}}
{td {[let%lwt pattern_1 = expr_1
and pattern_2 = expr2
…
and pattern_n = expr_n in
expr]}}}
{tr
{td {[try expr with
| pattern_1 = expr_1
| pattern_2 = expr2
…
| pattern_n = expr_n]}}
{td {[try%lwt expr with
| pattern_1 = expr_1
| pattern_2 = expr2
…
| pattern_n = expr_n]}}}
{tr
{td {[match expr with
| pattern_1 = expr_1
| pattern_2 = expr2
…
| pattern_n = expr_n]}}
{td {[match%lwt expr with
| pattern_1 = expr_1
| pattern_2 = expr2
…
| pattern_n = expr_n]}}}
{tr
{td {[for ident = expr_init to expr_final do
expr
done]}}
{td {[for%lwt ident = expr_init to expr_final do
expr
done]}}}
{tr
{td {[while expr do expr done]}}
{td {[while%lwt expr do expr done]}}}
{tr
{td {[if expr then expr else expr]}}
{td {[if%lwt expr then expr else expr]}}}
{tr
{td {[assert expr]}}
{td {[assert%lwt expr]}}}
{tr
{td {[raise exn]}}
{td {[[%lwt raise exn]]}}}}
{2 Backtrace support }
If an exception is raised inside a callback called by Lwt, the backtrace
provided by OCaml will not be very useful. It will end inside the Lwt
scheduler instead of continuing into the code that started the operations that
led to the callback call. To avoid this, and get good backtraces from Lwt, use
the syntax extension. The [let%lwt] construct will properly propagate
backtraces.
As always, to get backtraces from an OCaml program, you need to either declare
the environment variable [OCAMLRUNPARAM=b] or call
[Printexc.record_backtrace true] at the start of your program, and be
sure to compile it with [-g]. Most modern build systems add [-g] by
default.
{2 [let*] syntax }
To use Lwt with the [let*] syntax introduced in OCaml 4.08, you can open
the [Syntax] module:
{[
open Syntax
]}
Then, you can write
{[
let* () = Lwt_io.printl "Hello," in
let* () = Lwt_io.printl "world!" in
Lwt.return ()
]}
{2 Other modules of the core library }
The core library contains several modules that only depend on
[Lwt]. The following naming convention is used in [Lwt]: when a
function takes as argument a function, returning a promise, that is going
to be executed sequentially, it is suffixed with “[_s]”. And
when it is going to be executed concurrently, it is suffixed with
“[_p]”. For example, in the [Lwt_list] module we have:
{[
val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
]}
{3 Mutexes }
[Lwt_mutex] provides mutexes for [Lwt]. Its use is almost the
same as the [Mutex] module of the thread library shipped with
OCaml. In general, programs using [Lwt] do not need a lot of
mutexes, because callbacks run without preempting each other. They are
only useful for synchronising or sequencing complex operations spread over
multiple callback calls.
{3 Lists }
The [Lwt_list] module defines iteration and scanning functions
over lists, similar to the ones of the [List] module, but using
functions that return a promise. For example:
{[
val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
]}
In [iter_s f l], [iter_s] will call f on each elements
of [l], waiting for resolution between each element. On the
contrary, in [iter_p f l], [iter_p] will call f on all
elements of [l], only then wait for all the promises to resolve.
{3 Data streams }
[Lwt] streams are used in a lot of places in [Lwt] and its
submodules. They offer a high-level interface to manipulate data flows.
A stream is an object which returns elements sequentially and
lazily. Lazily means that the source of the stream is touched only for new
elements when needed. This module contains a lot of stream
transformation, iteration, and scanning functions.
The common way of creating a stream is by using
[Lwt_stream.from] or by using [Lwt_stream.create]:
{[
val from : (unit -> 'a option Lwt.t) -> 'a Lwt_stream.t
val create : unit -> 'a Lwt_stream.t * ('a option -> unit)
]}
As for streams of the standard library, [from] takes as
argument a function which is used to create new elements.
[create] returns a function used to push new elements
into the stream and the stream which will receive them.
For example:
{[
# let stream, push = Lwt_stream.create ();;
val stream : '_a Lwt_stream.t = <abstr>
val push : '_a option -> unit = <fun>
# push (Some 1);;
- : unit = ()
# push (Some 2);;
- : unit = ()
# push (Some 3);;
- : unit = ()
# Lwt.state (Lwt_stream.next stream);;
- : int Lwt.state = Lwt.Return 1
# Lwt.state (Lwt_stream.next stream);;
- : int Lwt.state = Lwt.Return 2
# Lwt.state (Lwt_stream.next stream);;
- : int Lwt.state = Lwt.Return 3
# Lwt.state (Lwt_stream.next stream);;
- : int Lwt.state = Lwt.Sleep
]}
Note that streams are consumable. Once you take an element from a
stream, it is removed from the stream. So, if you want to iterate two times
over a stream, you may consider “cloning” it, with
[Lwt_stream.clone]. Cloned stream will return the same
elements in the same order. Consuming one will not consume the other.
For example:
{[
# let s = Lwt_stream.of_list [1; 2];;
val s : int Lwt_stream.t = <abstr>
# let s' = Lwt_stream.clone s;;
val s' : int Lwt_stream.t = <abstr>
# Lwt.state (Lwt_stream.next s);;
- : int Lwt.state = Lwt.Return 1
# Lwt.state (Lwt_stream.next s);;
- : int Lwt.state = Lwt.Return 2
# Lwt.state (Lwt_stream.next s');;
- : int Lwt.state = Lwt.Return 1
# Lwt.state (Lwt_stream.next s');;
- : int Lwt.state = Lwt.Return 2
]}
{3 Mailbox variables }
The [Lwt_mvar] module provides mailbox variables. A mailbox
variable, also called a “mvar”, is a cell which may contain 0 or 1
element. If it contains no elements, we say that the mvar is empty,
if it contains one, we say that it is full. Adding an element to a
full mvar will block until one is taken. Taking an element from an
empty mvar will block until one is added.
Mailbox variables are commonly used to pass messages between chains of
callbacks being executed concurrently.
Note that a mailbox variable can be seen as a pushable stream with a
limited memory.
{1 Running an Lwt program }
An [Lwt] computation you have created will give you something of type
[Lwt.t], a promise. However, even though you have the promise, the
computation may not have run yet, and the promise might still be pending.
For example if your program is just:
{[
let _ = Lwt_io.printl "Hello, world!"
]}
you have no guarantee that the promise for writing ["Hello, world!"]
on the terminal will be resolved before the program exits. In order
to wait for the promise to resolve, you have to call the function
[Lwt_main.run]:
{[
val Lwt_main.run : 'a Lwt.t -> 'a
]}
This function waits for the given promise to resolve and returns
its result. In fact it does more than that; it also runs the
scheduler which is responsible for making asynchronous computations progress
when events are received from the outside world.
So basically, when you write a [Lwt] program, you must call
[Lwt_main.run] on your top-level, outer-most promise. For instance:
{[
let () = Lwt_main.run (Lwt_io.printl "Hello, world!")
]}
Note that you must not make nested calls to [Lwt_main.run]. It
cannot be used anywhere else to get the result of a promise.
{1 The [lwt.unix] library }
The package [lwt.unix] contains all [Unix]-dependent
modules of [Lwt]. Among all its features, it implements Lwt-friendly,
non-blocking versions of functions of the OCaml standard and Unix libraries.
{2 Unix primitives }
Module [Lwt_unix] provides non-blocking system calls. For example,
the [Lwt] counterpart of [Unix.read] is:
{[
val read : file_descr -> string -> int -> int -> int Lwt.t
]}
[Lwt_io] provides features similar to buffered channels of
the standard library (of type [in_channel] or
[out_channel]), but with non-blocking semantics.
[Lwt_gc] allows you to register a finalizer that returns a
promise. At the end of the program, [Lwt] will wait for all these
finalizers to resolve.
{2 The Lwt scheduler }
Operations doing I/O have to be resumed when some events are received by
the process, so they can resolve their associated pending promises.
For example, when you read from a file descriptor, you
may have to wait for the file descriptor to become readable if no
data are immediately available on it.
[Lwt] contains a scheduler which is responsible for managing
multiple operations waiting for events, and restarting them when needed.
This scheduler is implemented by the two modules [Lwt_engine]
and [Lwt_main]. [Lwt_engine] is a low-level module, it
provides a signature for custom I/O multiplexers as well as two built-in
implementations, [libev] and [select]. The signature is given by the
class [Lwt_engine.t].
[libev] is used by default on Linux, because it supports any
number of file descriptors, while [select] supports only 1024. [libev]
is also much more efficient. On Windows, [Unix.select] is used because
[libev] does not work properly. The user may change the backend in use at
any time.
If you see an [Invalid_argument] error on [Unix.select], it
may be because the 1024 file descriptor limit was exceeded. Try
switching to [libev], if possible.
The engine can also be used directly in order to integrate other
libraries with [Lwt]. For example, [GTK] needs to be notified
when some events are received. If you use [Lwt] with [GTK]
you need to use the [Lwt] scheduler to monitor [GTK]
sources. This is what is done by the [Lwt_glib] library.
The [Lwt_main] module contains the {e main loop} of
[Lwt]. It is run by calling the function [Lwt_main.run]:
{[
val Lwt_main.run : 'a Lwt.t -> 'a
]}
This function continuously runs the scheduler until the promise passed
as argument is resolved.
To make sure [Lwt] is compiled with [libev] support,
tell opam that the library is available on the system by installing the
{{: https://opam.ocaml.org/packages/conf-libev/conf-libev.4-11/ }conf-libev}
package. You may get the actual library with your system package manager:
{ul
{- [brew install libev] on MacOSX,}
{- [apt-get install libev-dev] on Debian/Ubuntu, or}
{- [yum install libev-devel] on CentOS, which requires to set
[export C_INCLUDE_PATH=/usr/include/libev/] and
[export LIBRARY_PATH=/usr/lib64/] before calling
[opam install conf-libev].}}
{2 Logging }
For logging, we recommend the [logs] package from opam, which includes an
Lwt-aware module [Logs_lwt].
{1 The Lwt.react library }
The [Lwt_react] module provides helpers for using the [react]
library with [Lwt]. It extends the [React] module by adding
[Lwt]-specific functions. It can be used as a replacement of
[React]. For example you can add at the beginning of your
program:
{[
open Lwt_react
]}
instead of:
{[
open React
]}
or:
{[
module React = Lwt_react
]}
Among the added functionalities we have [Lwt_react.E.next], which
takes an event and returns a promise which will be pending until the next
occurrence of this event. For example:
{[
# open Lwt_react;;
# let event, push = E.create ();;
val event : '_a React.event = <abstr>
val push : '_a -> unit = <fun>
# let p = E.next event;;
val p : '_a Lwt.t = <abstr>
# Lwt.state p;;
- : '_a Lwt.state = Lwt.Sleep
# push 42;;
- : unit = ()
# Lwt.state p;;
- : int Lwt.state = Lwt.Return 42
]}
Another interesting feature is the ability to limit events
(resp. signals) from occurring (resp. changing) too often. For example,
suppose you are doing a program which displays something on the screen
each time a signal changes. If at some point the signal changes 1000
times per second, you probably don't want to render it 1000 times per
second. For that you use [Lwt_react.S.limit]:
{[
val limit : (unit -> unit Lwt.t) -> 'a React.signal -> 'a React.signal
]}
[Lwt_react.S.limit f signal] returns a signal which varies as
[signal] except that two consecutive updates are separated by a
call to [f]. For example if [f] returns a promise which is pending
for 0.1 seconds, then there will be no more than 10 changes per
second:
{[
open Lwt_react
let draw x =
(* Draw the screen *)
…
let () =
(* The signal we are interested in: *)
let signal = … in
(* The limited signal: *)
let signal' = S.limit (fun () -> Lwt_unix.sleep 0.1) signal in
(* Redraw the screen each time the limited signal change: *)
S.notify_p draw signal'
]}
{1 Other libraries }
{2 Parallelise computations to other cores }
If you have some compute-intensive steps within your program, you can execute
them on a separate core. You can get performance benefits from the
parallelisation. In addition, whilst your compute-intensive function is running
on a different core, your normal I/O-bound tasks continue running on the
original core.
The module {!Lwt_domain} from the [lwt_domain] package provides all the
necessary helpers to achieve this. It is based on the [Domainslib] library
and uses similar concepts (such as tasks and pools).
First, you need to create a task pool:
{[
val setup_pool : ?name:string -> int -> pool
]}
Then you simple detach the function calls to the created pool:
{[
val detach : pool -> ('a -> 'b) -> 'a -> 'b Lwt.t
]}
The returned promise resolves as soon as the function returns.
{2 Detaching computation to preemptive threads }
It may happen that you want to run a function which will take time to
compute or that you want to use a blocking function that cannot be
used in a non-blocking way. For these situations, [Lwt] allows you to
{e detach} the computation to a preemptive thread.
This is done by the module [Lwt_preemptive] of the
[lwt.unix] package which maintains a pool of system
threads. The main function is:
{[
val detach : ('a -> 'b) -> 'a -> 'b Lwt.t
]}
[detach f x] will execute [f x] in another thread and
return a pending promise, usable from the main thread, which will be fulfilled
with the result of the preemptive thread.
If you want to trigger some [Lwt] operations from your detached thread,
you have to call back into the main thread using
[Lwt_preemptive.run_in_main]:
{[
val run_in_main : (unit -> 'a Lwt.t) -> 'a
]}
This is roughly the equivalent of [Lwt.main_run], but for detached
threads, rather than for the whole process. Note that you must not call
[Lwt_main.run] in a detached thread.
{2 SSL support }
The library [Lwt_ssl] allows use of SSL asynchronously.
{1 Writing stubs using [Lwt] }
{2 Thread-safe notifications }
If you want to notify the main thread from another thread, you can use the [Lwt]
thread safe notification system. First you need to create a notification identifier
(which is just an integer) from the OCaml side using the
[Lwt_unix.make_notification] function, then you can send it from either the
OCaml code with [Lwt_unix.send_notification] function, or from the C code using
the function [lwt_unix_send_notification] (defined in [lwt_unix_.h]).
Notifications are received and processed asynchronously by the main thread.
{2 Jobs }
For operations that cannot be executed asynchronously, [Lwt]
uses a system of jobs that can be executed in a different threads. A
job is composed of three functions:
{ul
{- A stub function to create the job. It must allocate a new job
structure and fill its [worker] and [result] fields. This
function is executed in the main thread.
The return type for the OCaml external must be of the form ['a job].}
{- A function which executes the job. This one may be executed asynchronously
in another thread. This function must not:
{ul
{- access or allocate OCaml block values (tuples, strings, …),}
{- call OCaml code.}}}
{- A function which reads the result of the job, frees resources and
returns the result as an OCaml value. This function is executed in
the main thread.}}
With [Lwt < 2.3.3], 4 functions (including 3 stubs) were
required. It is still possible to use this mode but it is
deprecated.
We show as example the implementation of [Lwt_unix.mkdir]. On the C
side we have:
{@c[/**/
/* Structure holding informations for calling [mkdir]. */
struct job_mkdir {
/* Informations used by lwt.
It must be the first field of the structure. */
struct lwt_unix_job job;
/* This field store the result of the call. */
int result;
/* This field store the value of [errno] after the call. */
int errno_copy;
/* Pointer to a copy of the path parameter. */
char* path;
/* Copy of the mode parameter. */
int mode;
/* Buffer for storing the path. */
char data[];
};
/* The function calling [mkdir]. */
static void worker_mkdir(struct job_mkdir* job)
{
/* Perform the blocking call. */
job->result = mkdir(job->path, job->mode);
/* Save the value of errno. */
job->errno_copy = errno;
}
/* The function building the caml result. */
static value result_mkdir(struct job_mkdir* job)
{
/* Check for errors. */
if (job->result < 0) {
/* Save the value of errno so we can use it
once the job has been freed. */
int error = job->errno_copy;
/* Copy the contents of job->path into a caml string. */
value string_argument = caml_copy_string(job->path);
/* Free the job structure. */
lwt_unix_free_job(&job->job);
/* Raise the error. */
unix_error(error, "mkdir", string_argument);
}
/* Free the job structure. */
lwt_unix_free_job(&job->job);
/* Return the result. */
return Val_unit;
}
/* The stub creating the job structure. */
CAMLprim value lwt_unix_mkdir_job(value path, value mode)
{
/* Get the length of the path parameter. */
mlsize_t len_path = caml_string_length(path) + 1;
/* Allocate a new job. */
struct job_mkdir* job =
(struct job_mkdir*)lwt_unix_new_plus(struct job_mkdir, len_path);
/* Set the offset of the path parameter inside the job structure. */
job->path = job->data;
/* Copy the path parameter inside the job structure. */
memcpy(job->path, String_val(path), len_path);
/* Initialize function fields. */
job->job.worker = (lwt_unix_job_worker)worker_mkdir;
job->job.result = (lwt_unix_job_result)result_mkdir;
/* Copy the mode parameter. */
job->mode = Int_val(mode);
/* Wrap the structure into a caml value. */
return lwt_unix_alloc_job(&job->job);
}
]}
and on the ocaml side:
{[
(* The stub for creating the job. *)
external mkdir_job : string -> int -> unit job = "lwt_unix_mkdir_job"
(* The ocaml function. *)
let mkdir name perms = Lwt_unix.run_job (mkdir_job name perms)
]}

2
unikernel/duniverse/lwt/docs/menu.wiki Normal file
View file

@ -0,0 +1,2 @@
= Lwt
==[[manual|Overview]]

74
unikernel/duniverse/lwt/dune-project Normal file
View file

@ -0,0 +1,74 @@
(lang dune 3.15)
(name lwt)
(generate_opam_files true)
(maintainers
"Raphaël Proust <code@bnwr.net>"
"Anton Bachin <antonbachin@yahoo.com>")
(authors "Jérôme Vouillon" "Jérémie Dimino")
(license MIT)
(source (github ocsigen/lwt))
(documentation "https://ocsigen.org/lwt")
(package
(name lwt_retry)
(synopsis "Utilities for retrying Lwt computations")
(authors "Shon Feder")
(maintainers
"Raphaël Proust <code@bnwr.net>"
"Shon Feder <shon.feder@gmail.com>")
(depends
(ocaml (>= 4.08))
(lwt (>= 5.3))))
(package
(name lwt_ppx)
(version 5.9.2)
(authors "Gabriel Radanne")
(synopsis "PPX syntax for Lwt, providing something similar to async/await from JavaScript")
(depends
(ocaml (>= 4.08))
(ppxlib (>= 0.36))
(lwt (>= 5.7))))
(package
(name lwt_ppx__ppx_let_tests)
(synopsis "DO NOT RELEASE! only for testing let_ppx")
(license NOTFORRELEASE) ;; trap for opam-repo ci
(allow_empty)
(depends
(ocaml (>= 5.1))
(ppx_let (and :with-test (>= v0.17.1)))))
(package
(name lwt_react)
(synopsis "Helpers for using React with Lwt")
(depends
(ocaml (>= 4.08))
(cppo (and :build (>= 1.1)))
(lwt (>= 3.0))
(react (>= 1.0))))
(package
(name lwt)
(version 5.9.2)
(synopsis "Promises and event-driven I/O")
(description "A promise is a value that may become determined in the future.
Lwt provides typed, composable promises. Promises that are resolved by I/O are
resolved by Lwt in parallel.
Meanwhile, OCaml code, including code creating and waiting on promises, runs in
a single thread by default. This reduces the need for locks or other
synchronization primitives. Code can be run in parallel on an opt-in basis.
")
(depends
(ocaml (>= 4.08))
(cppo (and :build (>= 1.1)))
(ocamlfind (and :dev (>= 1.7.3-1)))
(odoc (and :with-doc (>= 2.3)))
dune-configurator
ocplib-endian)
(depopts base-threads base-unix conf-libev))

58
unikernel/duniverse/lwt/lwt.opam Normal file
View file

@ -0,0 +1,58 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "5.9.2"
synopsis: "Promises and event-driven I/O"
description: """
A promise is a value that may become determined in the future.
Lwt provides typed, composable promises. Promises that are resolved by I/O are
resolved by Lwt in parallel.
Meanwhile, OCaml code, including code creating and waiting on promises, runs in
a single thread by default. This reduces the need for locks or other
synchronization primitives. Code can be run in parallel on an opt-in basis.
"""
maintainer: [
"Raphaël Proust <code@bnwr.net>" "Anton Bachin <antonbachin@yahoo.com>"
]
authors: ["Jérôme Vouillon" "Jérémie Dimino"]
license: "MIT"
homepage: "https://github.com/ocsigen/lwt"
doc: "https://ocsigen.org/lwt"
bug-reports: "https://github.com/ocsigen/lwt/issues"
depends: [
"dune" {>= "3.15"}
"ocaml" {>= "4.08"}
"cppo" {build & >= "1.1"}
"ocamlfind" {dev & >= "1.7.3-1"}
"odoc" {with-doc & >= "2.3"}
"dune-configurator"
"ocplib-endian"
]
depopts: ["base-threads" "base-unix" "conf-libev"]
dev-repo: "git+https://github.com/ocsigen/lwt.git"
build: [
["dune" "subst"] {dev}
[
"dune"
"exec"
"-p"
name
"src/unix/config/discover.exe"
"--"
"--save"
"--use-libev" "%{conf-libev:installed}%"
]
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
x-maintenance-intent:[ "(latest)" ]

25
unikernel/duniverse/lwt/lwt.opam.template Normal file
View file

@ -0,0 +1,25 @@
build: [
["dune" "subst"] {dev}
[
"dune"
"exec"
"-p"
name
"src/unix/config/discover.exe"
"--"
"--save"
"--use-libev" "%{conf-libev:installed}%"
]
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
x-maintenance-intent:[ "(latest)" ]

35
unikernel/duniverse/lwt/lwt_ppx.opam Normal file
View file

@ -0,0 +1,35 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
version: "5.9.2"
synopsis:
"PPX syntax for Lwt, providing something similar to async/await from JavaScript"
maintainer: [
"Raphaël Proust <code@bnwr.net>" "Anton Bachin <antonbachin@yahoo.com>"
]
authors: ["Gabriel Radanne"]
license: "MIT"
homepage: "https://github.com/ocsigen/lwt"
doc: "https://ocsigen.org/lwt"
bug-reports: "https://github.com/ocsigen/lwt/issues"
depends: [
"dune" {>= "3.15"}
"ocaml" {>= "4.08"}
"ppxlib" {>= "0.36"}
"lwt" {>= "5.7"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/ocsigen/lwt.git"

32
unikernel/duniverse/lwt/lwt_ppx__ppx_let_tests.opam Normal file
View file

@ -0,0 +1,32 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "DO NOT RELEASE! only for testing let_ppx"
maintainer: [
"Raphaël Proust <code@bnwr.net>" "Anton Bachin <antonbachin@yahoo.com>"
]
authors: ["Jérôme Vouillon" "Jérémie Dimino"]
license: "NOTFORRELEASE"
homepage: "https://github.com/ocsigen/lwt"
doc: "https://ocsigen.org/lwt"
bug-reports: "https://github.com/ocsigen/lwt/issues"
depends: [
"dune" {>= "3.15"}
"ocaml" {>= "5.1"}
"ppx_let" {with-test & >= "v0.17.1"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/ocsigen/lwt.git"

34
unikernel/duniverse/lwt/lwt_react.opam Normal file
View file

@ -0,0 +1,34 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Helpers for using React with Lwt"
maintainer: [
"Raphaël Proust <code@bnwr.net>" "Anton Bachin <antonbachin@yahoo.com>"
]
authors: ["Jérôme Vouillon" "Jérémie Dimino"]
license: "MIT"
homepage: "https://github.com/ocsigen/lwt"
doc: "https://ocsigen.org/lwt"
bug-reports: "https://github.com/ocsigen/lwt/issues"
depends: [
"dune" {>= "3.15"}
"ocaml" {>= "4.08"}
"cppo" {build & >= "1.1"}
"lwt" {>= "3.0"}
"react" {>= "1.0"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/ocsigen/lwt.git"

32
unikernel/duniverse/lwt/lwt_retry.opam Normal file
View file

@ -0,0 +1,32 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Utilities for retrying Lwt computations"
maintainer: [
"Raphaël Proust <code@bnwr.net>" "Shon Feder <shon.feder@gmail.com>"
]
authors: ["Shon Feder"]
license: "MIT"
homepage: "https://github.com/ocsigen/lwt"
doc: "https://ocsigen.org/lwt"
bug-reports: "https://github.com/ocsigen/lwt/issues"
depends: [
"dune" {>= "3.15"}
"ocaml" {>= "4.08"}
"lwt" {>= "5.3"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git+https://github.com/ocsigen/lwt.git"

9
unikernel/duniverse/lwt/src/core/dune Normal file
View file

@ -0,0 +1,9 @@
(library
(public_name lwt)
(synopsis "Monadic promises and concurrent I/O")
(wrapped false)
(instrumentation
(backend bisect_ppx)))
(documentation
(package lwt))

131
unikernel/duniverse/lwt/src/core/index.mld Normal file
View file

@ -0,0 +1,131 @@
{0 Lwt}
{1 Introduction}
Lwt is a concurrent programming library for OCaml. It provides a single data
type: the {e promise}, which is a value that will become determined in the
future. Creating a promise spawns a computation. When that computation is I/O,
Lwt runs it in parallel with your OCaml code.
OCaml code, including creating and waiting on promises, is run in a single
thread by default, so you don't have to worry about locking or preemption. You
can detach code to be run in separate threads on an opt-in basis.
Here is a simplistic Lwt program which requests the Google front page, and fails
if the request is not completed in five seconds:
{[
open Lwt.Syntax
let () =
let request =
let* addresses = Lwt_unix.getaddrinfo "google.com" "80" [] in
let google = Lwt_unix.((List.hd addresses).ai_addr) in
Lwt_io.(with_connection google (fun (incoming, outgoing) ->
let* () = write outgoing "GET / HTTP/1.1\r\n" in
let* () = write outgoing "Connection: close\r\n\r\n" in
let* response = read incoming in
Lwt.return (Some response)))
in
let timeout =
let* () = Lwt_unix.sleep 5. in
Lwt.return None
in
match Lwt_main.run (Lwt.pick [request; timeout]) with
| Some response -> print_string response
| None -> prerr_endline "Request timed out"; exit 1
(* ocamlfind opt -package lwt.unix -linkpkg example.ml && ./a.out *)
]}
In the program, functions such as [Lwt_io.write] create promises. The
[let%lwt ... in] construct is used to wait for a promise to become determined;
the code after [in] is scheduled to run in a "callback." [Lwt.pick] races
promises against each other, and behaves as the first one to complete.
[Lwt_main.run] forces the whole promise-computation network to be executed. All
the visible OCaml code is run in a single thread, but Lwt internally uses a
combination of worker threads and non-blocking file descriptors to resolve in
parallel the promises that do I/O.
{1 Tour}
Lwt compiles to native code on Linux, macOS, Windows, and other systems. It's
also routinely compiled to JavaScript for the front end and Node by js_of_ocaml.
In Lwt,
- The core library {!Lwt} provides promises...
- ...and a few pure-OCaml helpers, such as promise-friendly {{!Lwt_mutex}
mutexes}, {{!Lwt_condition} condition variables}, and {{!Lwt_mvar} mvars}.
- There is a big Unix binding, {!Lwt_unix}, that binds almost every Unix system
call. A higher-level module {!Lwt_io} provides nice I/O channels.
- {!Lwt_process} is for subprocess handling.
- {!Lwt_preemptive} spawns system threads.
{1 Installing}
+ Use your system package manager to install a development libev package. It is
often called [libev-dev] or [libev-devel].
+ [opam install conf-libev lwt]
{1 Additional Docs}
- {{!page-manual} Manual} ({{:https://ocsigen.org/lwt/} Online manual}).
- {{:https://github.com/dkim/rwo-lwt#readme} Concurrent Programming with Lwt} is
a nice source of Lwt examples. They are translations of code from Real World
OCaml, but are just as useful if you are not reading the book.
- {{:https://mirage.io/docs/tutorial-lwt} Mirage Lwt tutorial}.
- {{:https://baturin.org/code/lwt-counter-server/} Example server} written
with Lwt.
{1 API: Library [lwt]}
This is the system-independent, pure-OCaml core of Lwt. To link with it, use
[(libraries lwt)] in your [dune] file.
{!modules:
Lwt
Lwt_list
Lwt_stream
Lwt_result
Lwt_mutex
Lwt_condition
Lwt_mvar
Lwt_switch
Lwt_pool
}
{1 API: Library [lwt.unix]}
This is the system call and I/O library. Despite its name, it is implemented on
both Unix-like systems and Windows, although not all functions are available on
Windows. To link with this library, use [(libraries lwt.unix)] in your [dune]
file.
{!modules:
Lwt_unix
Lwt_main
Lwt_io
Lwt_process
Lwt_bytes
Lwt_preemptive
Lwt_fmt
Lwt_throttle
Lwt_timeout
Lwt_engine
Lwt_gc
Lwt_sys
}

3230
unikernel/duniverse/lwt/src/core/lwt.ml Normal file
View file

File diff suppressed because it is too large Load diff

2063
unikernel/duniverse/lwt/src/core/lwt.mli Normal file
View file

File diff suppressed because it is too large Load diff

68
unikernel/duniverse/lwt/src/core/lwt_condition.ml Normal file
View file

@ -0,0 +1,68 @@
(* OCaml promise library
* https://ocsigen.org/lwt
* Copyright (c) 2009, Metaweb Technologies, Inc.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it.
However, it is still used internally by Lwt. So, briefly disable warning 3
("deprecated"), and create a local, non-deprecated alias for
[Lwt_sequence] that can be referred to by the rest of the code in this
module without triggering any more warnings. *)
module Lwt_sequence = Lwt_sequence
type 'a t = 'a Lwt.u Lwt_sequence.t
let create = Lwt_sequence.create
let wait ?mutex cvar =
let waiter = (Lwt.add_task_r [@ocaml.warning "-3"]) cvar in
let () =
match mutex with
| Some m -> Lwt_mutex.unlock m
| None -> ()
in
Lwt.finalize
(fun () -> waiter)
(fun () ->
match mutex with
| Some m -> Lwt_mutex.lock m
| None -> Lwt.return_unit)
let signal cvar arg =
try
Lwt.wakeup_later (Lwt_sequence.take_l cvar) arg
with Lwt_sequence.Empty ->
()
let broadcast cvar arg =
let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in
Lwt_sequence.iter_node_l Lwt_sequence.remove cvar;
List.iter (fun wakener -> Lwt.wakeup_later wakener arg) wakeners
let broadcast_exn cvar exn =
let wakeners = Lwt_sequence.fold_r (fun x l -> x :: l) cvar [] in
Lwt_sequence.iter_node_l Lwt_sequence.remove cvar;
List.iter (fun wakener -> Lwt.wakeup_later_exn wakener exn) wakeners

68
unikernel/duniverse/lwt/src/core/lwt_condition.mli Normal file
View file

@ -0,0 +1,68 @@
(* OCaml promise library
* https://ocsigen.org/lwt
* Copyright (c) 2009, Metaweb Technologies, Inc.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** Conditions *)
(** Condition variables to synchronize between threads. *)
type 'a t
(** Condition variable type. The type parameter denotes the type of
value propagated from notifier to waiter. *)
val create : unit -> 'a t
(** [create ()] creates a new condition variable. *)
val wait : ?mutex:Lwt_mutex.t -> 'a t -> 'a Lwt.t
(** [wait mutex condvar] will cause the current thread to block,
awaiting notification for a condition variable, [condvar]. If
provided, the [mutex] must have been previously locked (within
the scope of [Lwt_mutex.with_lock], for example) and is
temporarily unlocked until the condition is notified. Upon
notification, [mutex] is re-locked before [wait] returns and
the thread's activity is resumed. When the awaited condition
is notified, the value parameter passed to [signal] is
returned. *)
val signal : 'a t -> 'a -> unit
(** [signal condvar value] notifies that a condition is ready. A
single waiting thread will be awoken and will receive the
notification value which will be returned from [wait]. Note
that condition notification is not "sticky", i.e. if there is
no waiter when [signal] is called, the notification will be
missed and the value discarded. *)
val broadcast : 'a t -> 'a -> unit
(** [broadcast condvar value] notifies all waiting threads. Each
will be awoken in turn and will receive the same notification
value. *)
val broadcast_exn : 'a t -> exn -> unit
(** [broadcast_exn condvar exn] fails all waiting threads with exception
[exn].
@since 2.6.0 *)

210
unikernel/duniverse/lwt/src/core/lwt_list.ml Normal file
View file

@ -0,0 +1,210 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(* A survey and measurements of more optimized implementations can be found at:
https://jsthomas.github.io/map-comparison.html
See discussion in https://github.com/ocsigen/lwt/pull/347. *)
let tail_recursive_map f l =
List.rev (List.rev_map f l)
let tail_recursive_mapi_rev f l =
let rec inner acc i = function
| [] -> acc
| hd::tl -> (inner [@ocaml.tailcall]) ((f i hd)::acc) (i + 1) tl
in
inner [] 0 l
open Lwt.Infix
let rec iter_s f l =
match l with
| [] ->
Lwt.return_unit
| x :: l ->
Lwt.apply f x >>= fun () ->
iter_s f l
let iter_p f l =
let ts = List.rev_map (Lwt.apply f) l in
Lwt.join ts
let rec iteri_s i f l =
match l with
| [] ->
Lwt.return_unit
| x :: l ->
Lwt.apply (f i) x >>= fun () ->
iteri_s (i + 1) f l
let iteri_s f l = iteri_s 0 f l
let iteri_p f l =
let f' i = Lwt.apply (f i) in
let ts = tail_recursive_mapi_rev f' l in
Lwt.join ts
let map_s f l =
let rec inner acc = function
| [] -> List.rev acc |> Lwt.return
| hd::tl ->
Lwt.apply f hd >>= fun r ->
(inner [@ocaml.tailcall]) (r::acc) tl
in
inner [] l
let rec _collect_rev acc = function
| [] ->
Lwt.return acc
| t::ts ->
t >>= fun i ->
(_collect_rev [@ocaml.tailcall]) (i::acc) ts
let map_p f l =
let ts = List.rev_map (Lwt.apply f) l in
_collect_rev [] ts
let filter_map_s f l =
let rec inner acc = function
| [] -> List.rev acc |> Lwt.return
| hd::tl ->
Lwt.apply f hd >>= function
| Some v -> (inner [@ocaml.tailcall]) (v::acc) tl
| None -> (inner [@ocaml.tailcall]) acc tl
in
inner [] l
let filter_map_p f l =
let rec _collect_optional_rev acc = function
| [] -> Lwt.return acc
| t::ts ->
t >>= function
| Some v -> (_collect_optional_rev [@ocaml.tailcall]) (v::acc) ts
| None -> (_collect_optional_rev [@ocaml.tailcall]) acc ts
in
let ts = List.rev_map (Lwt.apply f) l in
_collect_optional_rev [] ts
let mapi_s f l =
let rec inner acc i = function
| [] -> List.rev acc |> Lwt.return
| hd::tl ->
Lwt.apply (f i) hd >>= fun v ->
(inner [@ocaml.tailcall]) (v::acc) (i+1) tl
in
inner [] 0 l
let mapi_p f l =
let f' i = Lwt.apply (f i) in
let ts = tail_recursive_mapi_rev f' l in
_collect_rev [] ts
let rec rev_map_append_s acc f l =
match l with
| [] ->
Lwt.return acc
| x :: l ->
Lwt.apply f x >>= fun x ->
rev_map_append_s (x :: acc) f l
let rev_map_s f l =
rev_map_append_s [] f l
let rec rev_map_append_p acc f l =
match l with
| [] ->
acc
| x :: l ->
rev_map_append_p
(Lwt.apply f x >>= fun x ->
acc >|= fun l ->
x :: l) f l
let rev_map_p f l =
rev_map_append_p Lwt.return_nil f l
let rec fold_left_s f acc l =
match l with
| [] ->
Lwt.return acc
| x :: l ->
Lwt.apply (f acc) x >>= fun acc ->
(fold_left_s [@ocaml.tailcall]) f acc l
let fold_right_s f l acc =
let rec inner f a = function
| [] -> Lwt.return a
| hd::tl -> (Lwt.apply (f hd) a) >>= fun a' ->
(inner [@ocaml.tailcall]) f a' tl
in
inner f acc (List.rev l)
let rec for_all_s f l =
match l with
| [] ->
Lwt.return_true
| x :: l ->
Lwt.apply f x >>= function
| true ->
(for_all_s [@ocaml.tailcall]) f l
| false ->
Lwt.return_false
let for_all_p f l =
map_p f l >>= fun bl -> List.for_all (fun x -> x) bl |> Lwt.return
let rec exists_s f l =
match l with
| [] ->
Lwt.return_false
| x :: l ->
Lwt.apply f x >>= function
| true ->
Lwt.return_true
| false ->
(exists_s [@ocaml.tailcall]) f l
let exists_p f l =
map_p f l >>= fun bl -> List.exists (fun x -> x) bl |> Lwt.return
let rec find_s f l =
match l with
| [] ->
Lwt.fail Not_found
| x :: l ->
Lwt.apply f x >>= function
| true ->
Lwt.return x
| false ->
(find_s [@ocaml.tailcall]) f l
let _optionalize f x =
f x >>= fun b -> if b then Lwt.return (Some x) else Lwt.return_none
let filter_s f l =
filter_map_s (_optionalize f) l
let filter_p f l =
filter_map_p (_optionalize f) l
let partition_s f l =
let rec inner acc1 acc2 = function
| [] -> Lwt.return (List.rev acc1, List.rev acc2)
| hd::tl -> Lwt.apply f hd >>= fun b ->
if b then
inner (hd::acc1) acc2 tl
else
inner acc1 (hd::acc2) tl
in
inner [] [] l
let partition_p f l =
let g x = Lwt.apply f x >>= fun b -> Lwt.return (b, x) in
map_p g l >>= fun tl ->
let group1 = tail_recursive_map snd @@ List.filter fst tl in
let group2 =
tail_recursive_map snd @@ List.filter (fun x -> not @@ fst x) tl in
Lwt.return (group1, group2)

51
unikernel/duniverse/lwt/src/core/lwt_list.mli Normal file
View file

@ -0,0 +1,51 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** List helpers *)
(** Note: this module use the same naming convention as
{!Lwt_stream}. *)
(** {2 List iterators} *)
val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t
val iteri_s : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t
val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t
val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t
val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t
val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t
(** {2 List scanning} *)
val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t
(** {2 List searching} *)
val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a Lwt.t
val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t
val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t
val filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t
val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t
val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t
val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t

42
unikernel/duniverse/lwt/src/core/lwt_mutex.ml Normal file
View file

@ -0,0 +1,42 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it.
However, it is still used internally by Lwt. So, briefly disable warning 3
("deprecated"), and create a local, non-deprecated alias for
[Lwt_sequence] that can be referred to by the rest of the code in this
module without triggering any more warnings. *)
module Lwt_sequence = Lwt_sequence
open Lwt.Infix
type t = { mutable locked : bool; waiters : unit Lwt.u Lwt_sequence.t }
let create () = { locked = false; waiters = Lwt_sequence.create () }
let lock m =
if m.locked then
(Lwt.add_task_r [@ocaml.warning "-3"]) m.waiters
else begin
m.locked <- true;
Lwt.return_unit
end
let unlock m =
if m.locked then begin
if Lwt_sequence.is_empty m.waiters then
m.locked <- false
else
(* We do not use [Lwt.wakeup] here to avoid a stack overflow
when unlocking a lot of threads. *)
Lwt.wakeup_later (Lwt_sequence.take_l m.waiters) ()
end
let with_lock m f =
lock m >>= fun () ->
Lwt.finalize f (fun () -> unlock m; Lwt.return_unit)
let is_locked m = m.locked
let is_empty m = Lwt_sequence.is_empty m.waiters

44
unikernel/duniverse/lwt/src/core/lwt_mutex.mli Normal file
View file

@ -0,0 +1,44 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Cooperative locks for mutual exclusion *)
type t
(** Type of Lwt mutexes *)
val create : unit -> t
(** [create ()] creates a new mutex, which is initially unlocked *)
val lock : t -> unit Lwt.t
(** [lock mutex] lockcs the mutex, that is:
- if the mutex is unlocked, then it is marked as locked and
{!lock} returns immediately
- if it is locked, then {!lock} waits for all threads waiting on
the mutex to terminate, then it resumes when the last one
unlocks the mutex
Note: threads are woken up in the same order they try to lock the
mutex *)
val unlock : t -> unit
(** [unlock mutex] unlock the mutex if no threads is waiting on
it. Otherwise it will eventually removes the first one and
resumes it. *)
val is_locked : t -> bool
(** [locked mutex] returns whether [mutex] is currently locked *)
val is_empty : t -> bool
(** [is_empty mutex] returns [true] if they are no thread waiting on
the mutex, and [false] otherwise *)
val with_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t
(** [with_lock lock f] is used to lock a mutex within a block scope.
The function [f ()] is called with the mutex locked, and its
result is returned from the call to [with_lock]. If an exception
is raised from f, the mutex is also unlocked before the scope of
[with_lock] is exited. *)

100
unikernel/duniverse/lwt/src/core/lwt_mvar.ml Normal file
View file

@ -0,0 +1,100 @@
(* OCaml promise library
* https://ocsigen.org/lwt
* Copyright (c) 2009, Metaweb Technologies, Inc.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(* This code is adapted from
https://web.archive.org/web/20101001215425/http://eigenclass.org:80/hiki/lightweight-threads-with-lwt. *)
(* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it.
However, it is still used internally by Lwt. So, briefly disable warning 3
("deprecated"), and create a local, non-deprecated alias for
[Lwt_sequence] that can be referred to by the rest of the code in this
module without triggering any more warnings. *)
module Lwt_sequence = Lwt_sequence
type 'a t = {
mutable mvar_contents : 'a option;
(* Current contents *)
writers : ('a * unit Lwt.u) Lwt_sequence.t;
(* Threads waiting to put a value *)
readers : 'a Lwt.u Lwt_sequence.t;
(* Threads waiting for a value *)
}
let create_empty () =
{ mvar_contents = None;
writers = Lwt_sequence.create ();
readers = Lwt_sequence.create () }
let create v =
{ mvar_contents = Some v;
writers = Lwt_sequence.create ();
readers = Lwt_sequence.create () }
let put mvar v =
match mvar.mvar_contents with
| None ->
begin match Lwt_sequence.take_opt_l mvar.readers with
| None ->
mvar.mvar_contents <- Some v
| Some w ->
Lwt.wakeup_later w v
end;
Lwt.return_unit
| Some _ ->
let (res, w) = Lwt.task () in
let node = Lwt_sequence.add_r (v, w) mvar.writers in
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
res
let next_writer mvar =
match Lwt_sequence.take_opt_l mvar.writers with
| Some(v', w) ->
mvar.mvar_contents <- Some v';
Lwt.wakeup_later w ()
| None ->
mvar.mvar_contents <- None
let take_available mvar =
match mvar.mvar_contents with
| Some v ->
next_writer mvar;
Some v
| None ->
None
let take mvar =
match take_available mvar with
| Some v -> Lwt.return v
| None -> (Lwt.add_task_r [@ocaml.warning "-3"]) mvar.readers
let is_empty mvar =
match mvar.mvar_contents with
| Some _ -> false
| None -> true

67
unikernel/duniverse/lwt/src/core/lwt_mvar.mli Normal file
View file

@ -0,0 +1,67 @@
(* OCaml promise library
* https://ocsigen.org/lwt
* Copyright (c) 2009, Metaweb Technologies, Inc.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** Mailbox variables *)
(** “Mailbox” variables implement a synchronising variable, used for
communication between concurrent threads. *)
type 'a t
(** The type of a mailbox variable. Mailbox variables are used to
communicate values between threads in a synchronous way. The
type parameter specifies the type of the value propagated from
[put] to [take]. *)
val create : 'a -> 'a t
(** [create v] creates a new mailbox variable containing value [v]. *)
val create_empty : unit -> 'a t
(** [create ()] creates a new empty mailbox variable. *)
val put : 'a t -> 'a -> unit Lwt.t
(** [put mvar value] puts a value into a mailbox variable. This
value will remain in the mailbox until [take] is called to
remove it. If the mailbox is not empty, the current thread will
block until it is emptied. *)
val take : 'a t -> 'a Lwt.t
(** [take mvar] will take any currently available value from the
mailbox variable. If no value is currently available, the
current thread will block, awaiting a value to be [put] by
another thread. *)
val take_available : 'a t -> 'a option
(** [take_available mvar] immediately takes the value from [mvar] without
blocking, returning [None] if the mailbox is empty.
@since 3.2.0 *)
val is_empty : 'a t -> bool
(** [is_empty mvar] indicates if [put mvar] can be called without blocking.
@since 3.2.0 *)

173
unikernel/duniverse/lwt/src/core/lwt_pool.ml Normal file
View file

@ -0,0 +1,173 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it.
However, it is still used internally by Lwt. So, briefly disable warning 3
("deprecated"), and create a local, non-deprecated alias for
[Lwt_sequence] that can be referred to by the rest of the code in this
module without triggering any more warnings. *)
module Lwt_sequence = Lwt_sequence
open Lwt.Infix
type 'a t = {
create : unit -> 'a Lwt.t;
(* Create a new pool member. *)
check : 'a -> (bool -> unit) -> unit;
(* Check validity of a pool member when use resulted in failed promise. *)
validate : 'a -> bool Lwt.t;
(* Validate an existing free pool member before use. *)
dispose : 'a -> unit Lwt.t;
(* Dispose of a pool member. *)
cleared : bool ref ref;
(* Have the current pool elements been cleared out? *)
max : int;
(* Size of the pool. *)
mutable count : int;
(* Number of elements in the pool. *)
list : 'a Queue.t;
(* Available pool members. *)
waiters : 'a Lwt.u Lwt_sequence.t;
(* Promise resolvers waiting for a free member. *)
}
let create m ?(validate = fun _ -> Lwt.return_true) ?(check = fun _ f -> f true) ?(dispose = fun _ -> Lwt.return_unit) create =
{ max = m;
create = create;
validate = validate;
check = check;
dispose = dispose;
cleared = ref (ref false);
count = 0;
list = Queue.create ();
waiters = Lwt_sequence.create () }
(* Create a pool member. *)
let create_member p =
Lwt.catch
(fun () ->
(* Must be done before p.create to prevent other resolvers from
creating new members if the limit is reached. *)
p.count <- p.count + 1;
p.create ())
(fun exn ->
(* Creation failed, so don't increment count. *)
p.count <- p.count - 1;
Lwt.fail exn)
(* Release a pool member. *)
let release p c =
match Lwt_sequence.take_opt_l p.waiters with
| Some wakener ->
(* A promise resolver is waiting, give it the pool member. *)
Lwt.wakeup_later wakener c
| None ->
(* No one is waiting, queue it. *)
Queue.push c p.list
(* Dispose of a pool member. *)
let dispose p c =
p.dispose c >>= fun () ->
p.count <- p.count - 1;
Lwt.return_unit
(* Create a new member when one is thrown away. *)
let replace_disposed p =
match Lwt_sequence.take_opt_l p.waiters with
| None ->
(* No one is waiting, do not create a new member to avoid
losing an error if creation fails. *)
()
| Some wakener ->
Lwt.on_any
(Lwt.apply p.create ())
(fun c ->
Lwt.wakeup_later wakener c)
(fun exn ->
(* Creation failed, notify the waiter of the failure. *)
Lwt.wakeup_later_exn wakener exn)
(* Verify a member is still valid before using it. *)
let validate_and_return p c =
Lwt.try_bind
(fun () ->
p.validate c)
(function
| true ->
Lwt.return c
| false ->
(* Remove this member and create a new one. *)
dispose p c >>= fun () ->
create_member p)
(fun e ->
(* Validation failed: create a new member if at least one
resolver is waiting. *)
dispose p c >>= fun () ->
replace_disposed p;
Lwt.reraise e)
(* Acquire a pool member. *)
let acquire p =
if Queue.is_empty p.list then
(* No more available member. *)
if p.count < p.max then
(* Limit not reached: create a new one. *)
create_member p
else
(* Limit reached: wait for a free one. *)
(Lwt.add_task_r [@ocaml.warning "-3"]) p.waiters >>= validate_and_return p
else
(* Take the first free member and validate it. *)
let c = Queue.take p.list in
validate_and_return p c
(* Release a member when use resulted in failed promise if the member
is still valid. *)
let check_and_release p c cleared =
let ok = ref false in
p.check c (fun result -> ok := result);
if cleared || not !ok then (
(* Element is not ok or the pool was cleared - dispose of it *)
dispose p c
)
else (
(* Element is ok - release it back to the pool *)
release p c;
Lwt.return_unit
)
let use p f =
acquire p >>= fun c ->
(* Capture the current cleared state so we can see if it changes while this
element is in use *)
let cleared = !(p.cleared) in
let promise =
Lwt.catch
(fun () -> f c)
(fun e ->
check_and_release p c !cleared >>= fun () ->
Lwt.fail e)
in
promise >>= fun _ ->
if !cleared then (
(* p was cleared while promise was resolving - dispose of this element *)
dispose p c >>= fun () ->
promise
)
else (
release p c;
promise
)
let clear p =
let elements = Queue.fold (fun l element -> element :: l) [] p.list in
Queue.clear p.list;
(* Indicate to any currently in-use elements that we cleared the pool *)
let old_cleared = !(p.cleared) in
old_cleared := true;
p.cleared := ref false;
Lwt_list.iter_s (dispose p) elements
let wait_queue_length p = Lwt_sequence.length p.waiters

101
unikernel/duniverse/lwt/src/core/lwt_pool.mli Normal file
View file

@ -0,0 +1,101 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** External resource pools.
This module provides an abstraction for managing collections of resources.
One example use case is for managing a pool of database connections, where
instead of establishing a new connection each time you need one (which is
expensive), you can keep a pool of opened connections and reuse ones that
are free.
It also provides the capability of:
- specifying the maximum number of resources that the pool can manage
simultaneously,
- checking whether a resource is still valid before/after use, and
- performing cleanup logic before dropping a resource.
The following example illustrates how it is used with an imaginary
[Db] module:
{[
let uri = "postgresql://localhost:5432"
(* Create a database connection pool with max size of 10. *)
let pool =
Lwt_pool.create 10
~dispose:(fun connection -> Db.close connection |> Lwt.return)
(fun () -> Db.connect uri |> Lwt.return)
(* Use the pool in queries. *)
let create_user name =
Lwt_pool.use pool (fun connection ->
connection
|> Db.insert "users" [("name", name)]
|> Lwt.return
)
]}
Note that this is {e not} intended to keep a pool of system threads.
If you want to have such pool, consider using {!Lwt_preemptive}. *)
type 'a t
(** A pool containing elements of type ['a]. *)
val create :
int ->
?validate : ('a -> bool Lwt.t) ->
?check : ('a -> (bool -> unit) -> unit) ->
?dispose : ('a -> unit Lwt.t) ->
(unit -> 'a Lwt.t) -> 'a t
(** [create n ?check ?validate ?dispose f] creates a new pool with at most
[n] elements. [f] is used to create a new pool element. Elements are
created on demand and re-used until disposed of.
@param validate is called each time a pool element is accessed by {!use},
before the element is provided to {!use}'s callback. If
[validate element] resolves to [true] the element is considered valid and
is passed to the callback for use as-is. If [validate element] resolves
to [false] the tested pool element is passed to [dispose] then dropped,
with a new one is created to take [element]'s place in the pool.
[validate] is available since Lwt 3.2.0.
@param check is called after the resolution of {!use}'s callback when the
resolution is a failed promise. [check element is_ok] must call [is_ok]
exactly once with [true] if [element] is still valid and [false]
otherwise. If [check] calls [is_ok false] then [dispose] will be run
on [element] and the element will not be returned to the pool.
@param dispose is used as described above and by {!clear} to dispose of
all elements in a pool. [dispose] is {b not} guaranteed to be called on
the elements in a pool when the pool is garbage collected. {!clear}
should be used if the elements of the pool need to be explicitly disposed
of. *)
val use : 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t
(** [use p f] requests one free element of the pool [p] and gives it to
the function [f]. The element is put back into the pool after the
promise created by [f] completes.
In the case that [p] is exhausted and the maximum number of elements
is reached, [use] will wait until one becomes free. *)
val clear : 'a t -> unit Lwt.t
(** [clear p] will clear all elements in [p], calling the [dispose] function
associated with [p] on each of the cleared elements. Any elements from [p]
which are currently in use will be disposed of once they are released.
The next call to [use p] after [clear p] guarantees a freshly created pool
element.
Disposals are performed sequentially in an undefined order.
@since 3.2.0 *)
val wait_queue_length : _ t -> int
(** [wait_queue_length p] returns the number of {!use} requests currently
waiting for an element of the pool [p] to become available.
@since 3.2.0 *)

98
unikernel/duniverse/lwt/src/core/lwt_pqueue.ml Normal file
View file

@ -0,0 +1,98 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
module type OrderedType =
sig
type t
val compare: t -> t -> int
end
module type S =
sig
type elt
type t
val empty: t
val is_empty: t -> bool
val add: elt -> t -> t
val union: t -> t -> t
val find_min: t -> elt
val lookup_min: t -> elt option
val remove_min: t -> t
val size: t -> int
end
module Make(Ord: OrderedType) : (S with type elt = Ord.t) =
struct
type elt = Ord.t
type t = tree list
and tree = Node of elt * int * tree list
let root (Node (x, _, _)) = x
let rank (Node (_, r, _)) = r
let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) =
let c = Ord.compare x1 x2 in
if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2)
let rec ins t =
function
[] ->
[t]
| (t'::_) as ts when rank t < rank t' ->
t::ts
| t'::ts ->
ins (link t t') ts
let empty = []
let is_empty ts = ts = []
let add x ts = ins (Node (x, 0, [])) ts
let rec union ts ts' =
match ts, ts' with
([], _) -> ts'
| (_, []) -> ts
| (t1::ts1, t2::ts2) ->
if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2)
else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2
else ins (link t1 t2) (union ts1 ts2)
let rec find_min =
function
[] -> raise Not_found
| [t] -> root t
| t::ts ->
let x = find_min ts in
let c = Ord.compare (root t) x in
if c < 0 then root t else x
let rec lookup_min =
function
| [] -> None
| [t] -> Some (root t)
| t::ts ->
match lookup_min ts with
| None -> None
| Some x as result ->
let c = Ord.compare (root t) x in
if c < 0 then Some (root t) else result
let rec get_min =
function
[] -> assert false
| [t] -> (t, [])
| t::ts ->
let (t', ts') = get_min ts in
let c = Ord.compare (root t) (root t') in
if c < 0 then (t, ts) else (t', t::ts')
let remove_min =
function
[] -> raise Not_found
| ts ->
let (Node (_, _, c), ts) = get_min ts in
union (List.rev c) ts
let rec size l =
let sizetree (Node (_,_,tl)) = 1 + size tl in
List.fold_left (fun s t -> s + sizetree t) 0 l
end

76
unikernel/duniverse/lwt/src/core/lwt_pqueue.mli Normal file
View file

@ -0,0 +1,76 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Functional priority queues (deprecated).
A priority queue maintains, in the abstract sense, a set of elements in
order, and supports fast lookup and removal of the first (“minimum”)
element. This is used in Lwt for organizing threads that are waiting for
timeouts.
The priority queues in this module preserve “duplicates”: elements that
compare equal in their order.
@deprecated This module is an internal implementation detail of Lwt, and may
be removed from the API at some point in the future. For alternatives, see,
for example: {{: https://usr.lmf.cnrs.fr/~jcf/software.en.html#heap} Heaps}
by Jean-Cristophe Filliatre,
{{: https://simon.cedeela.fr/~simon/software/containers/CCHeap.html} containers},
{{: https://ocaml-batteries-team.github.io/batteries-included/hdoc2/BatHeap.html}
Batteries}, or {{:https://github.com/pqwy/psq} psq}. *)
[@@@ocaml.deprecated
" This module is an implementation detail of Lwt. See
https://ocsigen.org/lwt/latest/api/Lwt_pqueue"]
(** Signature pairing an element type with an ordering function. *)
module type OrderedType =
sig
type t
val compare: t -> t -> int
end
(** Signature of priority queues. *)
module type S =
sig
type elt
(** Type of elements contained in the priority queue. *)
type t
(** Type of priority queues. *)
val empty: t
(** The empty priority queue. Contains no elements. *)
val is_empty: t -> bool
(** [is_empty q] evaluates to [true] iff [q] is empty. *)
val add: elt -> t -> t
(** [add e q] evaluates to a new priority queue, which contains all the
elements of [q], and the additional element [e]. *)
val union: t -> t -> t
(** [union q q'] evaluates to a new priority queue, which contains all the
elements of both [q] and [q']. *)
val find_min: t -> elt
(** [find_min q] evaluates to the minimum element of [q] if it is not empty,
and raises [Not_found] otherwise. *)
val lookup_min: t -> elt option
(** [lookup_min q] evaluates to [Some e], where [e] is the minimum element
of [q], if [q] is not empty, and evaluates to [None] otherwise. *)
val remove_min: t -> t
(** [remove_min q] evaluates to a new priority queue, which contains all the
elements of [q] except for its minimum element. Raises [Not_found] if
[q] is empty. *)
val size: t -> int
(** [size q] evaluates to the number of elements in [q]. *)
end
(** Generates priority queue types from ordered types. *)
module Make(Ord: OrderedType) : S with type elt = Ord.t

131
unikernel/duniverse/lwt/src/core/lwt_result.ml Normal file
View file

@ -0,0 +1,131 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Module [Lwt_result]: explicit error handling *)
open Result
type (+'a, +'b) t = ('a, 'b) Result.t Lwt.t
let return x = Lwt.return (Ok x)
let fail e = Lwt.return (Error e)
let lift = Lwt.return
let ok x = Lwt.map (fun y -> Ok y) x
let error x = Lwt.map (fun y -> Error y) x
let map f e =
Lwt.map
(function
| Error e -> Error e
| Ok x -> Ok (f x))
e
let map_error f e =
Lwt.map
(function
| Error e -> Error (f e)
| Ok x -> Ok x)
e
let map_err f e = map_error f e
let catch e =
Lwt.catch
(fun () -> ok (e ()))
fail
let get_exn e =
Lwt.bind e
(function
| Ok x -> Lwt.return x
| Error e -> Lwt.fail e)
let bind e f =
Lwt.bind e
(function
| Error e -> Lwt.return (Error e)
| Ok x -> f x)
let bind_error e f =
Lwt.bind e
(function
| Error e -> f e
| Ok x -> Lwt.return (Ok x))
let bind_lwt e f =
Lwt.bind e
(function
| Ok x -> ok (f x)
| Error e -> fail e)
let bind_result e f =
Lwt.map
(function
| Error e -> Error e
| Ok x -> f x)
e
let bind_lwt_error e f =
Lwt.bind e
(function
| Error e -> Lwt.bind (f e) fail
| Ok x -> return x)
let bind_lwt_err e f = bind_lwt_error e f
let both a b =
let s = ref None in
let set_once e =
match !s with
| None -> s:= Some e
| Some _ -> ()
in
let (a,b) = map_error set_once a,map_error set_once b in
let some_assert = function
| None -> assert false
| Some e -> Error e
in
Lwt.map
(function
| Ok x, Ok y -> Ok (x,y)
| Error _, Ok _
| Ok _,Error _
| Error _, Error _ -> some_assert !s)
(Lwt.both a b)
let iter f r =
Lwt.bind r
(function
| Ok x -> f x
| Error _ -> Lwt.return_unit)
let iter_error f r =
Lwt.bind r
(function
| Error e -> f e
| Ok _ -> Lwt.return_unit)
module Infix = struct
let (>>=) = bind
let (>|=) e f = map f e
end
module Let_syntax = struct
module Let_syntax = struct
let return = return
let map t ~f = map f t
let bind t ~f = bind t f
let both = both
module Open_on_rhs = struct
end
end
end
module Syntax = struct
let (let*) = bind
let (and*) = both
let (let+) x f = map f x
let (and+) = both
end
include Infix

126
unikernel/duniverse/lwt/src/core/lwt_result.mli Normal file
View file

@ -0,0 +1,126 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Explicit error handling
@since 2.6.0 *)
(** This module provides helpers for values of type [('a, 'b) result Lwt.t].
The module is experimental and may change in the future. *)
type (+'a, +'b) t = ('a, 'b) result Lwt.t
val return : 'a -> ('a, _) t
val fail : 'b -> (_, 'b) t
val lift : ('a, 'b) result -> ('a, 'b) t
val ok : 'a Lwt.t -> ('a, _) t
val error : 'b Lwt.t -> (_, 'b) t
(** @since 5.6.0 *)
val catch : (unit -> 'a Lwt.t) -> ('a, exn) t
(** [catch x] behaves like [return y] if [x ()] evaluates to [y],
and like [fail e] if [x ()] raises [e] *)
val get_exn : ('a, exn) t -> 'a Lwt.t
(** [get_exn] is the opposite of {!catch}: it unwraps the result type,
returning the value in case of success, calls {!Lwt.fail} in
case of error. *)
val map : ('a -> 'b) -> ('a,'e) t -> ('b,'e) t
val map_error : ('e1 -> 'e2) -> ('a,'e1) t -> ('a,'e2) t
(** @since 5.6.0 *)
val bind : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t
val bind_error : ('a,'e1) t -> ('e1 -> ('a,'e2) t) -> ('a,'e2) t
(** @since 5.6.0 *)
val bind_lwt : ('a,'e) t -> ('a -> 'b Lwt.t) -> ('b,'e) t
val bind_lwt_error : ('a,'e1) t -> ('e1 -> 'e2 Lwt.t) -> ('a,'e2) t
(** @since 5.6.0 *)
val bind_result : ('a,'e) t -> ('a -> ('b,'e) result) -> ('b,'e) t
val both : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t
(** [Lwt.both p_1 p_2] returns a promise that is pending until {e both} promises
[p_1] and [p_2] become {e resolved}.
If only [p_1] is [Error e], the promise is resolved with [Error e],
If only [p_2] is [Error e], the promise is resolved with [Error e],
If both [p_1] and [p_2] resolve with [Error _], the promise is resolved with
the error that occurred first. *)
val iter : ('a -> unit Lwt.t) -> ('a, 'e) t -> unit Lwt.t
(** [iter f r] is [f v] if [r] is a promise resolved with [Ok v], and
{!Lwt.return_unit} otherwise.
@since Lwt 5.6.0
*)
val iter_error : ('e -> unit Lwt.t) -> ('a, 'e) t -> unit Lwt.t
(** [iter_error f r] is [f v] if [r] is a promise resolved with [Error v],
and {!Lwt.return_unit} otherwise.
@since Lwt 5.6.0
*)
module Infix : sig
val (>|=) : ('a,'e) t -> ('a -> 'b) -> ('b,'e) t
val (>>=) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t
end
module Let_syntax : sig
module Let_syntax : sig
val return : 'a -> ('a, _) t
(** See {!Lwt_result.return}. *)
val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t
(** See {!Lwt_result.map}. *)
val bind : ('a, 'e) t -> f:('a -> ('b, 'e) t) -> ('b, 'e) t
(** See {!Lwt_result.bind}. *)
val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t
(** See {!Lwt_result.both}. *)
module Open_on_rhs : sig
end
end
end
(** {3 Let syntax} *)
module Syntax : sig
(** {1 Monadic syntax} *)
val (let*) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t
(** Syntax for {!bind}. *)
val (and*) : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t
(** Syntax for {!both}. *)
(** {1 Applicative syntax} *)
val (let+) : ('a,'e) t -> ('a -> 'b) -> ('b, 'e) t
(** Syntax for {!map}. *)
val (and+) : ('a,'e) t -> ('b,'e) t -> ('a * 'b,'e) t
(** Syntax for {!both}. *)
end
include module type of Infix
(** {3 Deprecated} *)
val map_err : ('e1 -> 'e2) -> ('a,'e1) t -> ('a,'e2) t [@@deprecated "Alias to map_error"]
(** @deprecated Alias to [map_error] since 5.6.0. *)
val bind_lwt_err : ('a,'e1) t -> ('e1 -> 'e2 Lwt.t) -> ('a,'e2) t [@@deprecated "Alias to bind_lwt_error"]
(** @deprecated Alias to [bind_lwt_error] since 5.6.0. *)

318
unikernel/duniverse/lwt/src/core/lwt_seq.ml Normal file
View file

@ -0,0 +1,318 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
open Lwt.Syntax
open Lwt.Infix
type +'a node = Nil | Cons of 'a * 'a t
and 'a t = unit -> 'a node Lwt.t
let return_nil = Lwt.return Nil
let empty : 'a t = fun () -> return_nil
let return (x : 'a) : 'a t = fun () -> Lwt.return (Cons (x, empty))
let return_lwt (x : 'a Lwt.t) : 'a t = fun () ->
let+ x = x in
Cons (x, empty)
let cons x t () = Lwt.return (Cons (x, t))
let cons_lwt x t () =
let+ x = x in
Cons (x, t)
(* A note on recursing through the seqs:
When traversing a seq, the first time we evaluate a suspended node we are
on the left of the first bind (>>=). In that case, we use apply to capture
exceptions into promise rejection.
This is only needed on the first iteration because we are within a callback
passed to Lwt on the right-hand side of a bind after that.
Throughout this file we use the same code pattern to achieve this: we
shadow the recursive traversal function with an identical-but-for-the-apply
non-recursive copy. *)
let rec append seq1 seq2 () =
seq1 () >>= function
| Nil -> seq2 ()
| Cons (x, next) -> Lwt.return (Cons (x, append next seq2))
let append seq1 seq2 () =
Lwt.apply seq1 () >>= function
| Nil -> seq2 ()
| Cons (x, next) -> Lwt.return (Cons (x, append next seq2))
let rec map f seq () =
seq () >|= function
| Nil -> Nil
| Cons (x, next) ->
let x = f x in
Cons (x, map f next)
let map f seq () =
Lwt.apply seq () >|= function
| Nil -> Nil
| Cons (x, next) ->
let x = f x in
Cons (x, map f next)
let rec map_s f seq () =
seq () >>= function
| Nil -> return_nil
| Cons (x, next) ->
let+ x = f x in
Cons (x, map_s f next)
let map_s f seq () =
Lwt.apply seq () >>= function
| Nil -> return_nil
| Cons (x, next) ->
let+ x = f x in
Cons (x, map_s f next)
let rec filter_map f seq () =
seq () >>= function
| Nil -> return_nil
| Cons (x, next) -> (
let x = f x in
match x with
| None -> filter_map f next ()
| Some y -> Lwt.return (Cons (y, filter_map f next) ))
let filter_map f seq () =
Lwt.apply seq () >>= function
| Nil -> return_nil
| Cons (x, next) -> (
let x = f x in
match x with
| None -> filter_map f next ()
| Some y -> Lwt.return (Cons (y, filter_map f next) ))
let rec filter_map_s f seq () =
seq () >>= function
| Nil -> return_nil
| Cons (x, next) -> (
let* x = f x in
match x with
| None -> filter_map_s f next ()
| Some y -> Lwt.return (Cons (y, filter_map_s f next) ))
let filter_map_s f seq () =
Lwt.apply seq () >>= function
| Nil -> return_nil
| Cons (x, next) -> (
let* x = f x in
match x with
| None -> filter_map_s f next ()
| Some y -> Lwt.return (Cons (y, filter_map_s f next) ))
let rec filter f seq () =
seq () >>= function
| Nil -> return_nil
| Cons (x, next) ->
let ok = f x in
if ok then Lwt.return (Cons (x, filter f next)) else filter f next ()
let filter f seq () =
Lwt.apply seq () >>= function
| Nil -> return_nil
| Cons (x, next) ->
let ok = f x in
if ok then Lwt.return (Cons (x, filter f next)) else filter f next ()
let rec filter_s f seq () =
seq () >>= function
| Nil -> return_nil
| Cons (x, next) ->
let* ok = f x in
if ok then Lwt.return (Cons (x, filter_s f next)) else filter_s f next ()
let filter_s f seq () =
Lwt.apply seq () >>= function
| Nil -> return_nil
| Cons (x, next) ->
let* ok = f x in
if ok then Lwt.return (Cons (x, filter_s f next)) else filter_s f next ()
let rec flat_map f seq () =
seq () >>= function
| Nil -> return_nil
| Cons (x, next) ->
flat_map_app f (f x) next ()
(* this is [append seq (flat_map f tail)] *)
and flat_map_app f seq tail () =
seq () >>= function
| Nil -> flat_map f tail ()
| Cons (x, next) -> Lwt.return (Cons (x, flat_map_app f next tail))
let flat_map f seq () =
Lwt.apply seq () >>= function
| Nil -> return_nil
| Cons (x, next) ->
flat_map_app f (f x) next ()
let fold_left f acc seq =
let rec aux f acc seq =
seq () >>= function
| Nil -> Lwt.return acc
| Cons (x, next) ->
let acc = f acc x in
aux f acc next
in
let aux f acc seq =
Lwt.apply seq () >>= function
| Nil -> Lwt.return acc
| Cons (x, next) ->
let acc = f acc x in
aux f acc next
in
aux f acc seq
let fold_left_s f acc seq =
let rec aux f acc seq =
seq () >>= function
| Nil -> Lwt.return acc
| Cons (x, next) ->
let* acc = f acc x in
aux f acc next
in
let aux f acc seq =
Lwt.apply seq () >>= function
| Nil -> Lwt.return acc
| Cons (x, next) ->
let* acc = f acc x in
aux f acc next
in
aux f acc seq
let iter f seq =
let rec aux seq =
seq () >>= function
| Nil -> Lwt.return_unit
| Cons (x, next) ->
f x;
aux next
in
let aux seq =
Lwt.apply seq () >>= function
| Nil -> Lwt.return_unit
| Cons (x, next) ->
f x;
aux next
in
aux seq
let iter_s f seq =
let rec aux seq =
seq () >>= function
| Nil -> Lwt.return_unit
| Cons (x, next) ->
let* () = f x in
aux next
in
let aux seq =
Lwt.apply seq () >>= function
| Nil -> Lwt.return_unit
| Cons (x, next) ->
let* () = f x in
aux next
in
aux seq
let iter_p f seq =
let rec aux acc seq =
seq () >>= function
| Nil -> Lwt.join acc
| Cons (x, next) ->
let p = f x in
aux (p::acc) next
in
let aux acc seq =
Lwt.apply seq () >>= function
| Nil -> Lwt.join acc
| Cons (x, next) ->
let p = f x in
aux (p::acc) next
in
aux [] seq
let iter_n ?(max_concurrency = 1) f seq =
begin
if max_concurrency <= 0 then
let message =
Printf.sprintf
"Lwt_seq.iter_n: max_concurrency must be > 0, %d given"
max_concurrency
in
invalid_arg message
end;
let rec loop running available seq =
begin
if available > 0 then (
Lwt.return (running, available)
)
else (
Lwt.nchoose_split running >>= fun (complete, running) ->
Lwt.return (running, available + List.length complete)
)
end >>= fun (running, available) ->
seq () >>= function
| Nil ->
Lwt.join running
| Cons (elt, seq) ->
loop (f elt :: running) (pred available) seq
in
(* because the recursion is more complicated here, we apply the seq directly at
the call-site instead *)
loop [] max_concurrency (fun () -> Lwt.apply seq ())
let rec unfold f u () =
match f u with
| None -> return_nil
| Some (x, u') -> Lwt.return (Cons (x, unfold f u'))
| exception exc when Lwt.Exception_filter.run exc -> Lwt.reraise exc
let rec unfold_lwt f u () =
let* x = f u in
match x with
| None -> return_nil
| Some (x, u') -> Lwt.return (Cons (x, unfold_lwt f u'))
let unfold_lwt f u () =
let* x = Lwt.apply f u in
match x with
| None -> return_nil
| Some (x, u') -> Lwt.return (Cons (x, unfold_lwt f u'))
let rec of_list l () =
Lwt.return (match l with [] -> Nil | h :: t -> Cons (h, of_list t))
let to_list (seq : 'a t) =
let rec aux f seq =
Lwt.bind (seq ()) (function
| Nil -> Lwt.return (f [])
| Cons (h, t) -> aux (fun x -> f (h :: x)) t)
in
aux (fun x -> x) (Lwt.apply seq)
let rec of_seq seq () =
match seq () with
| Seq.Nil -> return_nil
| Seq.Cons (x, next) ->
Lwt.return (Cons (x, (of_seq next)))
| exception exn when Lwt.Exception_filter.run exn -> Lwt.reraise exn
let rec of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () ->
match seq () with
| Seq.Nil -> return_nil
| Seq.Cons (x, next) ->
let+ x = x in
let next = of_seq_lwt next in
Cons (x, next)
let of_seq_lwt (seq: 'a Lwt.t Seq.t): 'a t = fun () ->
match seq () with
| Seq.Nil -> return_nil
| Seq.Cons (x, next) ->
let+ x = x in
let next = of_seq_lwt next in
Cons (x, next)
| exception exc when Lwt.Exception_filter.run exc -> Lwt.reraise exc

161
unikernel/duniverse/lwt/src/core/lwt_seq.mli Normal file
View file

@ -0,0 +1,161 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** @since 5.5.0 *)
type 'a t = unit -> 'a node Lwt.t
(** The type of delayed lists containing elements of type ['a].
Note that the concrete list node ['a node] is delayed under a closure,
not a [lazy] block, which means it might be recomputed every time
we access it. *)
and +'a node = Nil | Cons of 'a * 'a t
(** A fully-evaluated list node, either empty or containing an element
and a delayed tail. *)
val empty : 'a t
(** The empty sequence, containing no elements. *)
val return : 'a -> 'a t
(** The singleton sequence containing only the given element. *)
val return_lwt : 'a Lwt.t -> 'a t
(** The singleton sequence containing only the given promised element. *)
val cons : 'a -> 'a t -> 'a t
(** [cons x xs] is the sequence containing the element [x] followed by
the sequence [xs] *)
val cons_lwt : 'a Lwt.t -> 'a t -> 'a t
(** [cons x xs] is the sequence containing the element promised by [x] followed
by the sequence [xs] *)
val append : 'a t -> 'a t -> 'a t
(** [append xs ys] is the sequence [xs] followed by the sequence [ys] *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** [map f seq] returns a new sequence whose elements are the elements of
[seq], transformed by [f].
This transformation is lazy, it only applies when the result is traversed. *)
val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t
(** [map_s f seq] is like [map f seq] but [f] is a function that returns a
promise.
Note that there is no concurrency between the promises from the underlying
sequence [seq] and the promises from applying the function [f]. In other
words, the next promise-element of the underlying sequence ([seq]) is only
created when the current promise-element of the returned sequence (as mapped
by [f]) has resolved. This scheduling is true for all the [_s] functions of
this module. *)
val filter : ('a -> bool) -> 'a t -> 'a t
(** Remove from the sequence the elements that do not satisfy the
given predicate.
This transformation is lazy, it only applies when the result is
traversed. *)
val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t
(** [filter_s] is like [filter] but the predicate returns a promise.
See {!map_s} for additional details about scheduling. *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
(** Apply the function to every element; if [f x = None] then [x] is dropped;
if [f x = Some y] then [y] is returned.
This transformation is lazy, it only applies when the result is
traversed. *)
val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t
(** [filter_map_s] is like [filter] but the predicate returns a promise.
See {!map_s} for additional details about scheduling. *)
val flat_map : ('a -> 'b t) -> 'a t -> 'b t
(** Map each element to a subsequence, then return each element of this
sub-sequence in turn.
This transformation is lazy, it only applies when the result is
traversed. *)
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a Lwt.t
(** Traverse the sequence from left to right, combining each element with the
accumulator using the given function.
The traversal happens immediately and will not terminate (i.e., the promise
will not resolve) on infinite sequences. *)
val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t
(** [fold_left_s] is like [fold_left] but the function returns a promise.
See {!map_s} for additional details about scheduling. *)
val iter : ('a -> unit) -> 'a t -> unit Lwt.t
(** Iterate on the sequence, calling the (imperative) function on every element.
The sequence's next node is evaluated only once the function has finished
processing the current element. More formally: the promise for the [n+1]th
node of the sequence is created only once the promise returned by [f] on the
[n]th element of the sequence has resolved.
The traversal happens immediately and will not terminate (i.e., the promise
will not resolve) on infinite sequences. *)
val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
(** [iter_s] is like [iter] but the function returns a promise.
See {!map_s} for additional details about scheduling. *)
val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
(** Iterate on the sequence, calling the (imperative) function on every element.
The sequence's next node is evaluated as soon as the previous node is
resolved.
The traversal happens immediately and will not terminate (i.e., the promise
will not resolve) on infinite sequences. *)
val iter_n : ?max_concurrency:int -> ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
(** [iter_n ~max_concurrency f s]
Iterates on the sequence [s], calling the (imperative) function [f] on every
element.
The sum total of unresolved promises returned by [f] never exceeds
[max_concurrency]. Node suspensions are evaluated only when there is capacity
for [f]-promises to be evaluated. Consequently, there might be significantly
fewer than [max_concurrency] promises being evaluated concurrently; especially
if the node suspensions take longer to evaluate than the [f]-promises.
The traversal happens immediately and will not terminate (i.e., the promise
will not resolve) on infinite sequences.
@param max_concurrency defaults to [1].
@raise Invalid_argument if [max_concurrency < 1]. *)
val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t
(** Build a sequence from a step function and an initial value.
[unfold f u] returns [empty] if the promise [f u] resolves to [None],
or [fun () -> Lwt.return (Cons (x, unfold f y))] if the promise [f u] resolves
to [Some (x, y)]. *)
val unfold_lwt : ('b -> ('a * 'b) option Lwt.t) -> 'b -> 'a t
(** [unfold_lwt] is like [unfold] but the step function returns a promise. *)
val to_list : 'a t -> 'a list Lwt.t
(** Convert a sequence to a list, preserving order.
The traversal happens immediately and will not terminate (i.e., the promise
will not resolve) on infinite sequences. *)
val of_list : 'a list -> 'a t
(** Convert a list to a sequence, preserving order. *)
val of_seq : 'a Seq.t -> 'a t
(** Convert from ['a Stdlib.Seq.t] to ['a Lwt_seq.t].
This transformation is lazy, it only applies when the result is
traversed. *)
val of_seq_lwt : 'a Lwt.t Seq.t -> 'a t
(** Convert from ['a Lwt.t Stdlib.Seq.t] to ['a Lwt_seq.t].
This transformation is lazy, it only applies when the result is
traversed. *)

230
unikernel/duniverse/lwt/src/core/lwt_sequence.ml Normal file
View file

@ -0,0 +1,230 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
exception Empty
type 'a t = {
mutable prev : 'a t;
mutable next : 'a t;
}
type 'a node = {
node_prev : 'a t;
node_next : 'a t;
mutable node_data : 'a;
mutable node_active : bool;
}
external seq_of_node : 'a node -> 'a t = "%identity"
external node_of_seq : 'a t -> 'a node = "%identity"
(* +-----------------------------------------------------------------+
| Operations on nodes |
+-----------------------------------------------------------------+ *)
let get node =
node.node_data
let set node data =
node.node_data <- data
let remove node =
if node.node_active then begin
node.node_active <- false;
let seq = seq_of_node node in
seq.prev.next <- seq.next;
seq.next.prev <- seq.prev
end
(* +-----------------------------------------------------------------+
| Operations on sequences |
+-----------------------------------------------------------------+ *)
let create () =
let rec seq = { prev = seq; next = seq } in
seq
let clear seq =
seq.prev <- seq;
seq.next <- seq
let is_empty seq = seq.next == seq
let length seq =
let rec loop curr len =
if curr == seq then
len
else
let node = node_of_seq curr in loop node.node_next (len + 1)
in
loop seq.next 0
let add_l data seq =
let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in
seq.next.prev <- seq_of_node node;
seq.next <- seq_of_node node;
node
let add_r data seq =
let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in
seq.prev.next <- seq_of_node node;
seq.prev <- seq_of_node node;
node
let take_l seq =
if is_empty seq then
raise Empty
else begin
let node = node_of_seq seq.next in
remove node;
node.node_data
end
let take_r seq =
if is_empty seq then
raise Empty
else begin
let node = node_of_seq seq.prev in
remove node;
node.node_data
end
let take_opt_l seq =
if is_empty seq then
None
else begin
let node = node_of_seq seq.next in
remove node;
Some node.node_data
end
let take_opt_r seq =
if is_empty seq then
None
else begin
let node = node_of_seq seq.prev in
remove node;
Some node.node_data
end
let transfer_l s1 s2 =
s2.next.prev <- s1.prev;
s1.prev.next <- s2.next;
s2.next <- s1.next;
s1.next.prev <- s2;
s1.prev <- s1;
s1.next <- s1
let transfer_r s1 s2 =
s2.prev.next <- s1.next;
s1.next.prev <- s2.prev;
s2.prev <- s1.prev;
s1.prev.next <- s2;
s1.prev <- s1;
s1.next <- s1
let iter_l f seq =
let rec loop curr =
if curr != seq then begin
let node = node_of_seq curr in
if node.node_active then f node.node_data;
loop node.node_next
end
in
loop seq.next
let iter_r f seq =
let rec loop curr =
if curr != seq then begin
let node = node_of_seq curr in
if node.node_active then f node.node_data;
loop node.node_prev
end
in
loop seq.prev
let iter_node_l f seq =
let rec loop curr =
if curr != seq then begin
let node = node_of_seq curr in
if node.node_active then f node;
loop node.node_next
end
in
loop seq.next
let iter_node_r f seq =
let rec loop curr =
if curr != seq then begin
let node = node_of_seq curr in
if node.node_active then f node;
loop node.node_prev
end
in
loop seq.prev
let fold_l f seq acc =
let rec loop curr acc =
if curr == seq then
acc
else
let node = node_of_seq curr in
if node.node_active then
loop node.node_next (f node.node_data acc)
else
loop node.node_next acc
in
loop seq.next acc
let fold_r f seq acc =
let rec loop curr acc =
if curr == seq then
acc
else
let node = node_of_seq curr in
if node.node_active then
loop node.node_prev (f node.node_data acc)
else
loop node.node_prev acc
in
loop seq.prev acc
let find_node_l f seq =
let rec loop curr =
if curr != seq then
let node = node_of_seq curr in
if node.node_active then
if f node.node_data then
node
else
loop node.node_next
else
loop node.node_next
else
raise Not_found
in
loop seq.next
let find_node_r f seq =
let rec loop curr =
if curr != seq then
let node = node_of_seq curr in
if node.node_active then
if f node.node_data then
node
else
loop node.node_prev
else
loop node.node_prev
else
raise Not_found
in
loop seq.prev
let find_node_opt_l f seq =
try Some (find_node_l f seq) with Not_found -> None
let find_node_opt_r f seq =
try Some (find_node_r f seq) with Not_found -> None

150
unikernel/duniverse/lwt/src/core/lwt_sequence.mli Normal file
View file

@ -0,0 +1,150 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Mutable sequence of elements (deprecated) *)
(** A sequence is an object holding a list of elements which support
the following operations:
- adding an element to the left or the right in time and space O(1)
- taking an element from the left or the right in time and space O(1)
- removing a previously added element from a sequence in time and space O(1)
- removing an element while the sequence is being transversed.
@deprecated This module should be an internal implementation detail of Lwt,
and may be removed from the API at some point in the future. Use package
{{:https://github.com/mirage/lwt-dllist} [lwt-dllist]} instead.
*)
[@@@ocaml.deprecated
" Use package lwt-dllist. See
https://github.com/mirage/lwt-dllist"]
type 'a t
(** Type of a sequence holding values of type ['a] *)
type 'a node
(** Type of a node holding one value of type ['a] in a sequence *)
(** {2 Operation on nodes} *)
val get : 'a node -> 'a
(** Returns the contents of a node *)
val set : 'a node -> 'a -> unit
(** Change the contents of a node *)
val remove : 'a node -> unit
(** Removes a node from the sequence it is part of. It does nothing
if the node has already been removed. *)
(** {2 Operations on sequence} *)
val create : unit -> 'a t
(** [create ()] creates a new empty sequence *)
val clear : 'a t -> unit
(** Removes all nodes from the given sequence. The nodes are not actually
mutated to note their removal. Only the sequence's pointers are updated. *)
val is_empty : 'a t -> bool
(** Returns [true] iff the given sequence is empty *)
val length : 'a t -> int
(** Returns the number of elements in the given sequence. This is a
O(n) operation where [n] is the number of elements in the
sequence. *)
val add_l : 'a -> 'a t -> 'a node
(** [add_l x s] adds [x] to the left of the sequence [s] *)
val add_r : 'a -> 'a t -> 'a node
(** [add_r x s] adds [x] to the right of the sequence [s] *)
exception Empty
(** Exception raised by [take_l] and [take_r] and when the sequence
is empty *)
val take_l : 'a t -> 'a
(** [take_l x s] remove and returns the leftmost element of [s]
@raise Empty if the sequence is empty *)
val take_r : 'a t -> 'a
(** [take_r x s] remove and returns the rightmost element of [s]
@raise Empty if the sequence is empty *)
val take_opt_l : 'a t -> 'a option
(** [take_opt_l x s] remove and returns [Some x] where [x] is the
leftmost element of [s] or [None] if [s] is empty *)
val take_opt_r : 'a t -> 'a option
(** [take_opt_r x s] remove and returns [Some x] where [x] is the
rightmost element of [s] or [None] if [s] is empty *)
val transfer_l : 'a t -> 'a t -> unit
(** [transfer_l s1 s2] removes all elements of [s1] and add them at
the left of [s2]. This operation runs in constant time and
space. *)
val transfer_r : 'a t -> 'a t -> unit
(** [transfer_r s1 s2] removes all elements of [s1] and add them at
the right of [s2]. This operation runs in constant time and
space. *)
(** {2 Sequence iterators} *)
(** Note: it is OK to remove a node while traversing a sequence *)
val iter_l : ('a -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all elements of [s] starting from
the left *)
val iter_r : ('a -> unit) -> 'a t -> unit
(** [iter_r f s] applies [f] on all elements of [s] starting from
the right *)
val iter_node_l : ('a node -> unit) -> 'a t -> unit
(** [iter_node_l f s] applies [f] on all nodes of [s] starting from
the left *)
val iter_node_r : ('a node -> unit) -> 'a t -> unit
(** [iter_node_r f s] applies [f] on all nodes of [s] starting from
the right *)
val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(** [fold_l f s] is:
{[
fold_l f s x = f en (... (f e2 (f e1 x)))
]}
where [e1], [e2], ..., [en] are the elements of [s]
*)
val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(** [fold_r f s] is:
{[
fold_r f s x = f e1 (f e2 (... (f en x)))
]}
where [e1], [e2], ..., [en] are the elements of [s]
*)
val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option
(** [find_node_opt_l f s] returns [Some x], where [x] is the first node of
[s] starting from the left that satisfies [f] or [None] if none
exists. *)
val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option
(** [find_node_opt_r f s] returns [Some x], where [x] is the first node of
[s] starting from the right that satisfies [f] or [None] if none
exists. *)
val find_node_l : ('a -> bool) -> 'a t -> 'a node
(** [find_node_l f s] returns the first node of [s] starting from the left
that satisfies [f] or raises [Not_found] if none exists. *)
val find_node_r : ('a -> bool) -> 'a t -> 'a node
(** [find_node_r f s] returns the first node of [s] starting from the right
that satisfies [f] or raises [Not_found] if none exists. *)

1117
unikernel/duniverse/lwt/src/core/lwt_stream.ml Normal file
View file

File diff suppressed because it is too large Load diff

391
unikernel/duniverse/lwt/src/core/lwt_stream.mli Normal file
View file

@ -0,0 +1,391 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Data streams *)
type 'a t
(** A stream holding values of type ['a].
Naming convention: in this module, all functions applying a function
to each element of a stream are suffixed by:
- [_s] when the function returns a thread and calls are serialised
- [_p] when the function returns a thread and calls are parallelised *)
(** {2 Construction} *)
val from : (unit -> 'a option Lwt.t) -> 'a t
(** [from f] creates a stream from the given input function. [f] is
called each time more input is needed, and the stream ends when
[f] returns [None].
If [f], or the thread produced by [f], raises an exception, that exception
is forwarded to the consumer of the stream (for example, a caller of
{!get}). Note that this does not end the stream. A subsequent attempt to
read from the stream will cause another call to [f], which may succeed
with a value. *)
val from_direct : (unit -> 'a option) -> 'a t
(** [from_direct f] does the same as {!from} but with a function
that does not return a thread. It is preferred that this
function be used rather than wrapping [f] into a function which
returns a thread.
The behavior when [f] raises an exception is the same as for {!from},
except that [f] does not produce a thread. *)
exception Closed
(** Exception raised by the push function of a push-stream when
pushing an element after the end of stream ([= None]) has been
pushed. *)
val create : unit -> 'a t * ('a option -> unit)
(** [create ()] returns a new stream and a push function.
To notify the stream's consumer of errors, either use a separate
communication channel, or use a {!Stdlib.result} stream. There is
no way to push an exception into a push-stream. *)
val create_with_reference : unit -> 'a t * ('a option -> unit) * ('b -> unit)
(** [create_with_reference ()] returns a new stream and a push
function. The last function allows a reference to be set to an
external source. This prevents the external source from being
garbage collected.
For example, to convert a reactive event to a stream:
{[
let stream, push, set_ref = Lwt_stream.create_with_reference () in
set_ref (map_event push event)
]}
*)
exception Full
(** Exception raised by the push function of a bounded push-stream
when the stream queue is full and a thread is already waiting to
push an element. *)
(** Type of sources for bounded push-streams. *)
class type ['a] bounded_push = object
method size : int
(** Size of the stream. *)
method resize : int -> unit
(** Change the size of the stream queue. Note that the new size
can smaller than the current stream queue size.
It raises {!Stdlib.Invalid_argument} if [size < 0]. *)
method push : 'a -> unit Lwt.t
(** Pushes a new element to the stream. If the stream is full then
it will block until one element is consumed. If another thread
is already blocked on [push], it raises {!Lwt_stream.Full}. *)
method close : unit
(** Closes the stream. Any thread currently blocked on a call to
the [push] method fails with {!Lwt_stream.Closed}. *)
method count : int
(** Number of elements in the stream queue. *)
method blocked : bool
(** Is a thread is blocked on a call to the [push] method? *)
method closed : bool
(** Is the stream closed? *)
method set_reference : 'a. 'a -> unit
(** Set the reference to an external source. *)
end
val create_bounded : int -> 'a t * 'a bounded_push
(** [create_bounded size] returns a new stream and a bounded push
source. The stream can hold a maximum of [size] elements. When
this limit is reached, pushing a new element will block until
one is consumed.
Note that you cannot clone or parse (with {!parse}) a bounded
stream. These functions will raise [Invalid_argument] if you try
to do so.
It raises [Invalid_argument] if [size < 0]. *)
val return : 'a -> 'a t
(** [return a] creates a stream containing the value [a] and being immediately
closed stream (in the sense of {!is_closed}).
@since 5.5.0 *)
val return_lwt : 'a Lwt.t -> 'a t
(** [return_lwt l] creates a stream returning the value that [l] resolves to.
The value is pushed into the stream immediately after the promise becomes
resolved and the stream is then immediately closed (in the sense of
{!is_closed}).
If, instead, [l] becomes rejected, then the stream is closed without any
elements in it. Attempting to fetch elements from it will raise {!Empty}.
@since 5.5.0 *)
val of_seq : 'a Seq.t -> 'a t
(** [of_seq s] creates a stream returning all elements of [s]. The elements are
evaluated from [s] and pushed onto the stream as the stream is consumed.
@since 4.2.0 *)
val of_lwt_seq : 'a Lwt_seq.t -> 'a t
(** [of_lwt_seq s] creates a stream returning all elements of [s]. The elements
are evaluated from [s] and pushed onto the stream as the stream is consumed.
@since 5.5.0 *)
val of_list : 'a list -> 'a t
(** [of_list l] creates a stream returning all elements of [l]. The elements are
pushed into the stream immediately, resulting in a closed stream (in the
sense of {!is_closed}). *)
val of_array : 'a array -> 'a t
(** [of_array a] creates a stream returning all elements of [a]. The elements
are pushed into the stream immediately, resulting in a closed stream (in the
sense of {!is_closed}). *)
val of_string : string -> char t
(** [of_string str] creates a stream returning all characters of [str]. The
characters are pushed into the stream immediately, resulting in a closed
stream (in the sense of {!is_closed}). *)
val clone : 'a t -> 'a t
(** [clone st] clone the given stream. Operations on each stream
will not affect the other.
For example:
{[
# let st1 = Lwt_stream.of_list [1; 2; 3];;
val st1 : int Lwt_stream.t = <abstr>
# let st2 = Lwt_stream.clone st1;;
val st2 : int Lwt_stream.t = <abstr>
# lwt x = Lwt_stream.next st1;;
val x : int = 1
# lwt y = Lwt_stream.next st2;;
val y : int = 1
]}
It raises [Invalid_argument] if [st] is a bounded
push-stream. *)
(** {2 Destruction} *)
val to_list : 'a t -> 'a list Lwt.t
(** Returns the list of elements of the given stream *)
val to_string : char t -> string Lwt.t
(** Returns the word composed of all characters of the given
stream *)
(** {2 Data retrieval} *)
exception Empty
(** Exception raised when trying to retrieve data from an empty
stream. *)
val peek : 'a t -> 'a option Lwt.t
(** [peek st] returns the first element of the stream, if any,
without removing it. *)
val npeek : int -> 'a t -> 'a list Lwt.t
(** [npeek n st] returns at most the first [n] elements of [st],
without removing them. *)
val get : 'a t -> 'a option Lwt.t
(** [get st] removes and returns the first element of the stream, if
any. *)
val nget : int -> 'a t -> 'a list Lwt.t
(** [nget n st] removes and returns at most the first [n] elements of
[st]. *)
val get_while : ('a -> bool) -> 'a t -> 'a list Lwt.t
val get_while_s : ('a -> bool Lwt.t) -> 'a t -> 'a list Lwt.t
(** [get_while f st] returns the longest prefix of [st] where all
elements satisfy [f]. *)
val next : 'a t -> 'a Lwt.t
(** [next st] removes and returns the next element of the stream or
fails with {!Empty}, if the stream is empty. *)
val last_new : 'a t -> 'a Lwt.t
(** [last_new st] returns the last element that can be obtained
without sleeping, or wait for one if none is available.
It fails with {!Empty} if the stream has no more elements. *)
val junk : 'a t -> unit Lwt.t
(** [junk st] removes the first element of [st]. *)
val njunk : int -> 'a t -> unit Lwt.t
(** [njunk n st] removes at most the first [n] elements of the
stream. *)
val junk_while : ('a -> bool) -> 'a t -> unit Lwt.t
val junk_while_s : ('a -> bool Lwt.t) -> 'a t -> unit Lwt.t
(** [junk_while f st] removes all elements at the beginning of the
streams which satisfy [f]. *)
val junk_available : 'a t -> unit
(** [junk_available st] removes all elements that are ready to be read
without yielding from [st]. *)
val get_available : 'a t -> 'a list
(** [get_available st] returns all available elements of [l] without
blocking. *)
val get_available_up_to : int -> 'a t -> 'a list
(** [get_available_up_to n st] returns up to [n] elements of [l]
without blocking. *)
val is_empty : 'a t -> bool Lwt.t
(** [is_empty st] returns whether the given stream is empty. *)
val is_closed : 'a t -> bool
(** [is_closed st] returns whether the given stream has been closed. A closed
stream is not necessarily empty. It may still contain unread elements. If
[is_closed s = true], then all subsequent reads until the end of the
stream are guaranteed not to block.
@since 2.6.0 *)
val closed : 'a t -> unit Lwt.t
(** [closed st] returns a thread that will sleep until the stream has been
closed.
@since 2.6.0 *)
(** {3 Deprecated} *)
val junk_old : 'a t -> unit Lwt.t [@@deprecated "Use junk_available instead"]
(** @deprecated [junk_old st] is [Lwt.return (junk_available st)]. *)
(** {2 Stream transversal} *)
(** Note: all the following functions are destructive.
For example:
{[
# let st1 = Lwt_stream.of_list [1; 2; 3];;
val st1 : int Lwt_stream.t = <abstr>
# let st2 = Lwt_stream.map string_of_int st1;;
val st2 : string Lwt_stream.t = <abstr>
# lwt x = Lwt_stream.next st1;;
val x : int = 1
# lwt y = Lwt_stream.next st2;;
val y : string = "2"
]}
*)
val choose : 'a t list -> 'a t
(** [choose l] creates an stream from a list of streams. The
resulting stream will return elements returned by any stream of
[l] in an unspecified order. *)
val map : ('a -> 'b) -> 'a t -> 'b t
val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t
(** [map f st] maps the value returned by [st] with [f] *)
val filter : ('a -> bool) -> 'a t -> 'a t
val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t
(** [filter f st] keeps only values, [x], such that [f x] is [true] *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t
(** [filter_map f st] filter and map [st] at the same time *)
val map_list : ('a -> 'b list) -> 'a t -> 'b t
val map_list_s : ('a -> 'b list Lwt.t) -> 'a t -> 'b t
(** [map_list f st] applies [f] on each element of [st] and flattens
the lists returned *)
val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b Lwt.t
val fold_s : ('a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t
(** [fold f s x] fold_like function for streams. *)
val iter : ('a -> unit) -> 'a t -> unit Lwt.t
val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
(** [iter f s] iterates over all elements of the stream. *)
val iter_n : ?max_concurrency:int -> ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t
(** [iter_n ?max_concurrency f s] iterates over all elements of the stream [s].
Iteration is performed concurrently with up to [max_threads] concurrent
instances of [f].
Iteration is {b not} guaranteed to be in order as this function will
attempt to always process [max_concurrency] elements from [s] at once.
@param max_concurrency defaults to [1].
@raise Invalid_argument if [max_concurrency < 1].
@since 3.3.0 *)
val find : ('a -> bool) -> 'a t -> 'a option Lwt.t
val find_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t
(** [find f s] find an element in a stream. *)
val find_map : ('a -> 'b option) -> 'a t -> 'b option Lwt.t
val find_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b option Lwt.t
(** [find_map f s] find and map at the same time. *)
val combine : 'a t -> 'b t -> ('a * 'b) t
(** [combine s1 s2] combines two streams. The stream will end when
either stream ends. *)
val append : 'a t -> 'a t -> 'a t
(** [append s1 s2] returns a stream which returns all elements of
[s1], then all elements of [s2] *)
val concat : 'a t t -> 'a t
(** [concat st] returns the concatenation of all streams of [st]. *)
val flatten : 'a list t -> 'a t
(** [flatten st = map_list (fun l -> l) st] *)
val wrap_exn : 'a t -> ('a, exn) result t
(** [wrap_exn s] is a stream [s'] such that each time [s] yields a value [v],
[s'] yields [Result.Ok v], and when the source of [s] raises an exception
[e], [s'] yields [Result.Error e].
Note that push-streams (as returned by {!create}) never raise exceptions.
If the stream source keeps raising the same exception [e] each time the
stream is read, [s'] is unbounded. Reading it will produce [Result.Error e]
indefinitely.
@since 2.7.0 *)
(** {2 Parsing} *)
val parse : 'a t -> ('a t -> 'b Lwt.t) -> 'b Lwt.t
(** [parse st f] parses [st] with [f]. If [f] raise an exception,
[st] is restored to its previous state.
It raises [Invalid_argument] if [st] is a bounded
push-stream. *)
(** {2 Misc} *)
val hexdump : char t -> string t
(** [hexdump byte_stream] returns a stream which is the same as the
output of [hexdump -C].
Basically, here is a simple implementation of [hexdump -C]:
{[
let () = Lwt_main.run begin
Lwt_io.write_lines
Lwt_io.stdout
(Lwt_stream.hexdump (Lwt_io.read_lines Lwt_io.stdin))
end
]}
*)

60
unikernel/duniverse/lwt/src/core/lwt_switch.ml Normal file
View file

@ -0,0 +1,60 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
exception Off
type on_switch = {
mutable hooks : (unit -> unit Lwt.t) list;
}
type state =
| St_on of on_switch
| St_off
type t = { mutable state : state }
let create () = { state = St_on { hooks = [] } }
let is_on switch =
match switch.state with
| St_on _ -> true
| St_off -> false
let check = function
| Some{ state = St_off } -> raise Off
| Some {state = St_on _} | None -> ()
let add_hook switch hook =
match switch with
| Some { state = St_on os } ->
os.hooks <- hook :: os.hooks
| Some { state = St_off } ->
raise Off
| None ->
()
let add_hook_or_exec switch hook =
match switch with
| Some { state = St_on os } ->
os.hooks <- hook :: os.hooks;
Lwt.return_unit
| Some { state = St_off } ->
hook ()
| None ->
Lwt.return_unit
let turn_off switch =
match switch.state with
| St_on { hooks = hooks } ->
switch.state <- St_off;
Lwt.join (List.map (fun hook -> Lwt.apply hook ()) hooks)
| St_off ->
Lwt.return_unit
let with_switch fn =
let switch = create () in
Lwt.finalize
(fun () -> fn switch)
(fun () -> turn_off switch)

98
unikernel/duniverse/lwt/src/core/lwt_switch.mli Normal file
View file

@ -0,0 +1,98 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Lwt switches *)
(** Switch has two goals:
- being able to free multiple resources at the same time,
- offer a better alternative than always returning an id to free
some resource.
For example, consider the following interface:
{[
type id
val free : id -> unit Lwt.t
val f : unit -> id Lwt.t
val g : unit -> id Lwt.t
val h : unit -> id Lwt.t
]}
Now you want to call [f], [g] and [h] in parallel. You can
simply do:
{[
lwt idf = f () and idg = g () and idh = h () in
...
]}
However, one may want to handle possible failures of [f ()], [g ()]
and [h ()], and disable all allocated resources if one of
these three threads fails. This may be hard since you have to
remember which one failed and which one returned correctly.
Now if we change the interface a little bit:
{[
val f : ?switch : Lwt_switch.t -> unit -> id Lwt.t
val g : ?switch : Lwt_switch.t -> unit -> id Lwt.t
val h : ?switch : Lwt_switch.t -> unit -> id Lwt.t
]}
the code becomes:
{[
Lwt_switch.with_switch (fun switch ->
lwt idf = f ~switch ()
and idg = g ~switch ()
and idh = h ~switch () in
...
)
]}
*)
type t
(** Type of switches. *)
val create : unit -> t
(** [create ()] creates a new switch. *)
val with_switch : (t -> 'a Lwt.t) -> 'a Lwt.t
(** [with_switch fn] is [fn switch], where [switch] is a fresh switch
that is turned off when the callback thread finishes (whether it
succeeds or fails).
@since 2.6.0 *)
val is_on : t -> bool
(** [is_on switch] returns [true] if the switch is currently on, and
[false] otherwise. *)
val turn_off : t -> unit Lwt.t
(** [turn_off switch] turns off the switch. It calls all registered
hooks, waits for all of them to terminate, then returns. If
one of the hooks failed, it will fail with the exception raised
by the hook. If the switch is already off, it does nothing. *)
exception Off
(** Exception raised when trying to add a hook to a switch that is
already off. *)
val check : t option -> unit
(** [check switch] does nothing if [switch] is [None] or contains an
switch that is currently on, and raises {!Off} otherwise. *)
val add_hook : t option -> (unit -> unit Lwt.t) -> unit
(** [add_hook switch f] registers [f] so it will be called when
{!turn_off} is invoked. It does nothing if [switch] is
[None]. If [switch] contains an switch that is already off then
{!Off} is raised. *)
val add_hook_or_exec : t option -> (unit -> unit Lwt.t) -> unit Lwt.t
(** [add_hook_or_exec switch f] is the same as {!add_hook} except
that if the switch is already off, [f] is called immediately. *)

10
unikernel/duniverse/lwt/src/ppx/dune Normal file
View file

@ -0,0 +1,10 @@
(library
(public_name lwt_ppx)
(synopsis "Lwt PPX syntax extension")
(libraries ppxlib)
(ppx_runtime_libraries lwt)
(kind ppx_rewriter)
(preprocess
(pps ppxlib.metaquot))
(instrumentation
(backend bisect_ppx)))

362
unikernel/duniverse/lwt/src/ppx/ppx_lwt.ml Normal file
View file

@ -0,0 +1,362 @@
open! Ppxlib
open Ast_builder.Default
(** {2 Convenient stuff} *)
let with_loc f {txt ; loc } =
f ~loc txt
(** Test if a case is a catchall. *)
let is_catchall case =
let rec is_catchall_pat p = match p.ppat_desc with
| Ppat_any | Ppat_var _ -> true
| Ppat_alias (p, _) | Ppat_constraint (p,_) -> is_catchall_pat p
| _ -> false
in
case.pc_guard = None && is_catchall_pat case.pc_lhs
(** Add a wildcard case in there is none. Useful for exception handlers. *)
let add_wildcard_case cases =
let has_wildcard =
List.exists is_catchall cases
in
if not has_wildcard
then cases
@ (let loc = Location.none in
[case ~lhs:[%pat? exn] ~guard:None ~rhs:[%expr Lwt.reraise exn]])
else cases
(** {3 Internal names} *)
let lwt_prefix = "__ppx_lwt_"
(** {2 Here we go!} *)
let default_loc = ref Location.none
let sequence = ref true
let strict_seq = ref true
let used_no_sequence_option = ref false
let used_no_strict_sequence_option = ref false
let no_sequence_option () =
sequence := false;
used_no_sequence_option := true
let no_strict_sequence_option () =
strict_seq := false;
used_no_strict_sequence_option := true
(** let%lwt related functions *)
let gen_name i = lwt_prefix ^ string_of_int i
(** [p = x] ≡ [__ppx_lwt_$i = x] *)
let gen_bindings l =
let aux i binding =
{ binding with
pvb_pat = pvar ~loc:binding.pvb_expr.pexp_loc (gen_name i)
}
in
List.mapi aux l
(** [p = x] and e ≡ [Lwt.bind __ppx_lwt_$i (fun p -> e)] *)
let gen_binds e_loc l e =
let rec aux i bindings =
match bindings with
| [] -> e
| binding :: t ->
let name = (* __ppx_lwt_$i, at the position of $x$ *)
evar ~loc:binding.pvb_expr.pexp_loc (gen_name i)
in
let fun_ =
let loc = e_loc in
[%expr (fun [%p binding.pvb_pat] -> [%e aux (i+1) t])]
in
let new_exp =
let loc = e_loc in
[%expr
Lwt.backtrace_bind
(fun exn -> try Lwt.reraise exn with exn -> exn)
[%e name]
[%e fun_]
]
in
{ new_exp with pexp_attributes = binding.pvb_attributes }
in aux 0 l
let lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc =
let pat= let loc = ext_loc in [%pat? ()] in
let lhs, rhs = mapper#expression lhs, mapper#expression rhs in
let loc = exp.pexp_loc in
[%expr
Lwt.backtrace_bind
(fun exn -> try Lwt.reraise exn with exn -> exn)
[%e lhs]
(fun [%p pat] -> [%e rhs])
]
(** For expressions only *)
(* We only expand the first level after a %lwt.
After that, we call the mapper to expand sub-expressions. *)
let lwt_expression mapper exp attributes ext_loc =
default_loc := exp.pexp_loc;
let pexp_attributes = attributes @ exp.pexp_attributes in
match exp.pexp_desc with
(* $e$;%lwt $e'$ ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *)
| Pexp_sequence (lhs, rhs) ->
Some (lwt_sequence mapper ~exp ~lhs ~rhs ~ext_loc)
(* [let%lwt $p$ = $e$ in $e'$] ≡ [Lwt.bind $e$ (fun $p$ -> $e'$)] *)
| Pexp_let (Nonrecursive, vbl , e) ->
let new_exp =
pexp_let
~loc:!default_loc
Nonrecursive
(gen_bindings vbl)
(gen_binds exp.pexp_loc vbl e)
in
Some (mapper#expression { new_exp with pexp_attributes })
(* [match%lwt $e$ with $c$] ≡ [Lwt.bind $e$ (function $c$)]
[match%lwt $e$ with exception $x$ | $c$] ≡
[Lwt.try_bind (fun () -> $e$) (function $c$) (function $x$)] *)
| Pexp_match (e, cases) ->
let exns, cases =
cases |> List.partition (
function
| {pc_lhs = [%pat? exception [%p? _]]; _} -> true
| _ -> false)
in
if cases = [] then
Location.raise_errorf ~loc:exp.pexp_loc
"match%%lwt must contain at least one non-exception pattern." ;
let exns =
exns |> List.map (
function
| {pc_lhs = [%pat? exception [%p? pat]]; _} as case ->
{ case with pc_lhs = pat }
| _ -> assert false)
in
let exns = add_wildcard_case exns in
let new_exp =
match exns with
| [] ->
let loc = !default_loc in
[%expr Lwt.bind [%e e] [%e pexp_function_cases ~loc cases]]
| _ ->
let loc = !default_loc in
[%expr Lwt.try_bind (fun () -> [%e e])
[%e pexp_function_cases ~loc cases]
[%e pexp_function_cases ~loc exns]]
in
Some (mapper#expression { new_exp with pexp_attributes })
(* [assert%lwt $e$] ≡
[try Lwt.return (assert $e$) with exn -> Lwt.reraise exn] *)
| Pexp_assert e ->
let new_exp =
let loc = !default_loc in
[%expr try Lwt.return (assert [%e e]) with exn -> Lwt.reraise exn]
in
Some (mapper#expression { new_exp with pexp_attributes })
(* [while%lwt $cond$ do $body$ done] ≡
[let rec __ppx_lwt_loop () =
if $cond$ then Lwt.bind $body$ __ppx_lwt_loop
else Lwt.return_unit
in __ppx_lwt_loop]
*)
| Pexp_while (cond, body) ->
let new_exp =
let loc = !default_loc in
[%expr
let rec __ppx_lwt_loop () =
if [%e cond] then Lwt.bind [%e body] __ppx_lwt_loop
else Lwt.return_unit
in __ppx_lwt_loop ()
]
in
Some (mapper#expression { new_exp with pexp_attributes })
(* [for%lwt $p$ = $start$ (to|downto) $end$ do $body$ done] ≡
[let __ppx_lwt_bound = $end$ in
let rec __ppx_lwt_loop $p$ =
if $p$ COMP __ppx_lwt_bound then Lwt.return_unit
else Lwt.bind $body$ (fun () -> __ppx_lwt_loop ($p$ OP 1))
in __ppx_lwt_loop $start$]
*)
| Pexp_for ({ppat_desc = Ppat_var p_var; _} as p, start, bound, dir, body) ->
let comp, op =
let loc = !default_loc in
match dir with
| Upto -> evar ~loc ">", evar ~loc "+"
| Downto -> evar ~loc "<", evar ~loc "-"
in
let p' = with_loc evar p_var in
let exp_bound = let loc = bound.pexp_loc in [%expr __ppx_lwt_bound] in
let pat_bound = let loc = bound.pexp_loc in [%pat? __ppx_lwt_bound] in
let new_exp =
let loc = !default_loc in
[%expr
let [%p pat_bound] : int = [%e bound] in
let rec __ppx_lwt_loop [%p p] =
if [%e comp] [%e p'] [%e exp_bound] then Lwt.return_unit
else Lwt.bind [%e body] (fun () -> __ppx_lwt_loop ([%e op] [%e p'] 1))
in __ppx_lwt_loop [%e start]
]
in
Some (mapper#expression { new_exp with pexp_attributes })
(* [try%lwt $e$ with $c$] ≡
[Lwt.catch (fun () -> $e$) (function $c$)]
*)
| Pexp_try (expr, cases) ->
let cases = add_wildcard_case cases in
let new_exp =
let loc = !default_loc in
[%expr
Lwt.backtrace_catch
(fun exn -> try Lwt.reraise exn with exn -> exn)
(fun () -> [%e expr])
[%e pexp_function_cases ~loc cases]
]
in
Some (mapper#expression { new_exp with pexp_attributes })
(* [if%lwt $c$ then $e1$ else $e2$] ≡
[match%lwt $c$ with true -> $e1$ | false -> $e2$]
[if%lwt $c$ then $e1$] ≡
[match%lwt $c$ with true -> $e1$ | false -> Lwt.return_unit]
*)
| Pexp_ifthenelse (cond, e1, e2) ->
let e2 =
match e2 with
| None -> let loc = !default_loc in [%expr Lwt.return_unit]
| Some e -> e
in
let cases =
let loc = !default_loc in
[
case ~lhs:[%pat? true] ~guard:None ~rhs:e1 ;
case ~lhs:[%pat? false] ~guard:None ~rhs:e2 ;
]
in
let new_exp =
let loc = !default_loc in
[%expr Lwt.bind [%e cond] [%e pexp_function_cases ~loc cases]]
in
Some (mapper#expression { new_exp with pexp_attributes })
| _ ->
None
let warned = ref false
class mapper = object (self)
inherit Ast_traverse.map as super
method! structure = begin fun structure ->
if !warned then
super#structure structure
else begin
warned := true;
let structure = super#structure structure in
let loc = Location.in_file !Ocaml_common.Location.input_name in
let warn_if condition message structure =
if condition then
(pstr_attribute ~loc (attribute_of_warning loc message))::structure
else
structure
in
structure
|> warn_if (!used_no_strict_sequence_option)
("-no-strict-sequence is a deprecated Lwt PPX option\n" ^
" See https://github.com/ocsigen/lwt/issues/495")
|> warn_if (!used_no_sequence_option)
("-no-sequence is a deprecated Lwt PPX option\n" ^
" See https://github.com/ocsigen/lwt/issues/495")
end
end
method! expression = (fun expr ->
match expr with
| { pexp_desc=
Pexp_extension (
{txt="lwt"; loc= ext_loc},
PStr[{pstr_desc= Pstr_eval (exp, _);_}]);
_
}->
begin match lwt_expression self exp expr.pexp_attributes ext_loc with
| Some expr' -> expr'
| None -> expr
end
(* [($e$)[%finally $f$]] ≡
[Lwt.finalize (fun () -> $e$) (fun () -> $f$)] *)
| [%expr [%e? exp ] [%finally [%e? finally]] ]
| [%expr [%e? exp ] [%lwt.finally [%e? finally]] ] ->
let new_exp =
let loc = !default_loc in
[%expr
Lwt.backtrace_finalize
(fun exn -> try Lwt.reraise exn with exn -> exn)
(fun () -> [%e exp])
(fun () -> [%e finally])
]
in
super#expression
{ new_exp with
pexp_attributes = expr.pexp_attributes @ exp.pexp_attributes
}
| [%expr [%finally [%e? _ ]]]
| [%expr [%lwt.finally [%e? _ ]]] ->
Location.raise_errorf ~loc:expr.pexp_loc
"Lwt's finally should be used only with the syntax: \"(<expr>)[%%finally ...]\"."
| _ ->
super#expression expr)
method! structure_item = (fun stri ->
default_loc := stri.pstr_loc;
match stri with
| [%stri let%lwt [%p? var] = [%e? exp]] ->
let warning =
estring ~loc:!default_loc
("let%lwt should not be used at the module item level.\n" ^
"Replace let%lwt x = e by let x = Lwt_main.run (e)")
in
let loc = !default_loc in
[%stri
let [%p var] =
(Lwt_main.run [@ocaml.ppwarning [%e warning]])
[%e super#expression exp]]
| x -> super#structure_item x);
end
let args =
[
"-no-sequence",
Arg.Unit no_sequence_option,
" has no effect (deprecated)";
"-no-strict-sequence",
Arg.Unit no_strict_sequence_option,
" has no effect (deprecated)";
]
let () =
let mapper = new mapper in
Driver.register_transformation "ppx_lwt"
~impl:mapper#structure
~intf:mapper#signature ;
List.iter (fun (key, spec, doc) -> Driver.add_arg key spec ~doc) args

164
unikernel/duniverse/lwt/src/ppx/ppx_lwt.mli Normal file
View file

@ -0,0 +1,164 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Ppx syntax extension for Lwt *)
(** {2 Ppx extensions}
This Ppx extension adds various syntactic shortcut for lwt programming.
It needs {{:https://github.com/ocaml-ppx/ppx_tools}ppx_tools}.
To use it, simply use the ocamlfind package [lwt_ppx].
This extension adds the following syntax:
- lwt-binding:
{[
let%lwt ch = get_char stdin in
code
]}
is the same as [bind (get_char stdin) (fun ch -> code)].
Moreover, it supports parallel binding:
{[
let%lwt x = do_something1 ()
and y = do_something2 in
code
]}
will run [do_something1 ()] and [do_something2 ()], then
bind their results to [x] and [y]. It is the same as:
{[
let t1 = do_something1
and t2 = do_something2 in
bind t1 (fun x -> bind t2 (fun y -> code))
]}
Due to a {{:https://github.com/ocaml/ocaml/issues/7758} bug} in the OCaml
parser, if you'd like to put a type constraint on the variable, please write
{[
let (foo : int) = do_something in
code
]}
Not using parentheses will confuse the OCaml parser.
- exception catching:
{[
try%lwt
<expr>
with
<branches>
]}
For example:
{[
try%lwt
f x
with
| Failure msg ->
prerr_endline msg;
return ()
]}
is expanded to:
{[
catch (fun () -> f x)
(function
| Failure msg ->
prerr_endline msg;
return ()
| exn ->
Lwt.reraise exn)
]}
Note that the [exn -> Lwt.reraise exn] branch is automatically added
when needed.
- finalizer:
{[
(<expr>) [%finally <expr>]
]}
You can use [[%lwt.finally ...]] instead of [[%finally ...]].
- assertion:
{[
assert%lwt <expr>
]}
- for loop:
{[
for%lwt i = <expr> to <expr> do
<expr>
done
]}
and:
{[
for%lwt i = <expr> downto <expr> do
<expr>
done
]}
- while loop:
{[
while%lwt <expr> do
<expr>
done
]}
- pattern matching:
{[
match%lwt <expr> with
| <patt_1> -> <expr_1>
...
| <patt_n> -> <expr_n>
]}
Exception cases are also supported:
{[
match%lwt <expr> with
| exception <exn> -> <expr_1>
| <patt_2> -> <expr_2>
...
| <patt_n> -> <expr_n>
]}
- conditional:
{[
if%lwt <expr> then
<expr_1>
else
<expr_2>
]}
and
{[
if%lwt <expr> then <expr_1>
]}
*)
class mapper : Ppxlib.Ast_traverse.map

7
unikernel/duniverse/lwt/src/react/dune Normal file
View file

@ -0,0 +1,7 @@
(library
(public_name lwt_react)
(synopsis "Reactive programming helpers for Lwt")
(wrapped false)
(libraries lwt react)
(instrumentation
(backend bisect_ppx)))

489
unikernel/duniverse/lwt/src/react/lwt_react.ml Normal file
View file

@ -0,0 +1,489 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
open Lwt.Infix
type 'a event = 'a React.event
type 'a signal = 'a React.signal
module E = struct
include React.E
(* +---------------------------------------------------------------+
| Lwt-specific utilities |
+---------------------------------------------------------------+ *)
let finalise f _ = f ()
let with_finaliser f event =
let r = ref () in
Gc.finalise (finalise f) r;
map (fun x -> ignore (Sys.opaque_identity r); x) event
let next ev =
let waiter, wakener = Lwt.task () in
let ev = map (fun x -> Lwt.wakeup wakener x) (once ev) in
Lwt.on_cancel waiter (fun () -> stop ev);
waiter
let limit f e =
(* Thread which prevents [e] from occurring while it is sleeping *)
let limiter = ref Lwt.return_unit in
(* The occurrence that is delayed until the limiter returns. *)
let delayed = ref None in
(* The resulting event. *)
let event, push = create () in
let iter =
fmap
(fun x ->
if Lwt.is_sleeping !limiter then begin
(* The limiter is sleeping, we queue the event for later
delivering. *)
match !delayed with
| Some cell ->
(* An occurrence is already queued, replace it. *)
cell := x;
None
| None ->
let cell = ref x in
delayed := Some cell;
Lwt.on_success !limiter (fun () ->
if Lwt.is_sleeping !limiter then
delayed := None
else
let x = !cell in
delayed := None;
limiter := f ();
push x);
None
end else begin
(* Set the limiter for future events. *)
limiter := f ();
(* Send the occurrence now. *)
push x;
None
end)
e
in
select [iter; event]
let cancel_thread t () =
Lwt.cancel t
let from f =
let event, push = create () in
let rec loop () =
f () >>= fun x ->
push x;
loop ()
in
let t = Lwt.pause () >>= loop in
with_finaliser (cancel_thread t) event
let to_stream event =
let stream, push, set_ref = Lwt_stream.create_with_reference () in
set_ref (map (fun x -> push (Some x)) event);
stream
let of_stream stream =
let event, push = create () in
let t =
Lwt.pause () >>= fun () ->
Lwt_stream.iter
(fun v ->
try push v
with exn when Lwt.Exception_filter.run exn ->
!Lwt.async_exception_hook exn)
stream in
with_finaliser (cancel_thread t) event
let delay thread =
match Lwt.poll thread with
| Some e ->
e
| None ->
let event, send = create () in
Lwt.on_success thread (fun e -> send e; stop event);
switch never event
let keeped = ref []
let keep e =
keeped := map ignore e :: !keeped
(* +---------------------------------------------------------------+
| Event transformations |
+---------------------------------------------------------------+ *)
let run_p e =
let event, push = create () in
let iter = fmap (fun t -> Lwt.on_success t (fun v -> push v); None) e in
select [iter; event]
let run_s e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter =
fmap
(fun t ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> t))
(fun v -> push v);
None) e
in
select [iter; event]
let map_p f e =
let event, push = create () in
let iter = fmap (fun x -> Lwt.on_success (f x) (fun v -> push v); None) e in
select [iter; event]
let map_s f e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter =
fmap
(fun x ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> f x))
(fun v -> push v);
None) e
in
select [iter; event]
let app_p ef e =
let event, push = create () in
let iter =
fmap
(fun (f, x) ->
Lwt.on_success (f x) (fun v -> push v);
None)
(app (map (fun f x -> (f, x)) ef) e)
in
select [iter; event]
let app_s ef e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter =
fmap
(fun (f, x) ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> f x))
(fun v -> push v);
None)
(app (map (fun f x -> (f, x)) ef) e)
in
select [iter; event]
let filter_p f e =
let event, push = create () in
let iter = fmap (fun x -> Lwt.on_success (f x) (function true -> push x | false -> ()); None) e in
select [iter; event]
let filter_s f e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) e in
select [iter; event]
let fmap_p f e =
let event, push = create () in
let iter = fmap (fun x -> Lwt.on_success (f x) (function Some x -> push x | None -> ()); None) e in
select [iter; event]
let fmap_s f e =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) e in
select [iter; event]
let diff_s f e =
let previous = ref None in
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter =
fmap
(fun x ->
match !previous with
| None ->
previous := Some x;
None
| Some y ->
previous := Some x;
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> f x y))
(fun v -> push v);
None)
e
in
select [iter; event]
let accum_s ef acc =
let acc = ref acc in
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun f -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc)) (fun x -> acc := x; push x); None) ef in
select [iter; event]
let fold_s f acc e =
let acc = ref acc in
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter = fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f !acc x)) (fun x -> acc := x; push x); None) e in
select [iter; event]
let rec rev_fold f acc = function
| [] ->
Lwt.return acc
| x :: l ->
rev_fold f acc l >>= fun acc ->
f acc x
let merge_s f acc el =
let event, push = create () in
let mutex = Lwt_mutex.create () in
let iter =
fmap
(fun l ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l))
(fun v -> push v);
None)
(merge (fun acc x -> x :: acc) [] el)
in
select [iter; event]
end
module S = struct
include React.S
(* +---------------------------------------------------------------+
| Lwt-specific utilities |
+---------------------------------------------------------------+ *)
let finalise f _ = f ()
let with_finaliser f signal =
let r = ref () in
Gc.finalise (finalise f) r;
map
(fun x -> ignore (Sys.opaque_identity r); x)
signal
let limit ?eq f s =
(* Thread which prevent [s] to changes while it is sleeping *)
let limiter = ref (f ()) in
(* The occurrence that is delayed until the limiter returns. *)
let delayed = ref None in
(* The resulting event. *)
let event, push = E.create () in
let iter =
E.fmap
(fun x ->
if Lwt.is_sleeping !limiter then begin
(* The limiter is sleeping, we queue the event for later
delivering. *)
match !delayed with
| Some cell ->
(* An occurrence is already queued, replace it. *)
cell := x;
None
| None ->
let cell = ref x in
delayed := Some cell;
Lwt.on_success !limiter (fun () ->
if Lwt.is_sleeping !limiter then
delayed := None
else
let x = !cell in
delayed := None;
limiter := f ();
push x);
None
end else begin
(* Set the limiter for future events. *)
limiter := f ();
(* Send the occurrence now. *)
push x;
None
end)
(changes s)
in
hold ?eq (value s) (E.select [iter; event])
let keeped = ref []
let keep s =
keeped := map ignore s :: !keeped
(* +---------------------------------------------------------------+
| Signal transformations |
+---------------------------------------------------------------+ *)
let run_s ?eq s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter =
E.fmap
(fun t ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> t))
(fun v -> push v);
None)
(changes s)
in
Lwt_mutex.with_lock mutex (fun () -> value s) >>= fun x ->
Lwt.return (hold ?eq x (E.select [iter; event]))
let map_s ?eq f s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter =
E.fmap
(fun x ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> f x)) (fun v -> push v);
None)
(changes s)
in
Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x ->
Lwt.return (hold ?eq x (E.select [iter; event]))
let app_s ?eq sf s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter =
E.fmap
(fun (f, x) ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> f x))
(fun v -> push v);
None)
(E.app (E.map (fun f x -> (f, x)) (changes sf)) (changes s))
in
Lwt_mutex.with_lock mutex (fun () -> (value sf) (value s)) >>= fun x ->
Lwt.return (hold ?eq x (E.select [iter; event]))
let filter_s ?eq f i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function true -> push x | false -> ()); None) (changes s) in
let x = value s in
Lwt_mutex.with_lock mutex (fun () -> f x) >>= function
| true ->
Lwt.return (hold ?eq x (E.select [iter; event]))
| false ->
Lwt.return (hold ?eq i (E.select [iter; event]))
let fmap_s ?eq f i s =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter = E.fmap (fun x -> Lwt.on_success (Lwt_mutex.with_lock mutex (fun () -> f x)) (function Some x -> push x | None -> ()); None) (changes s) in
Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= function
| Some x ->
Lwt.return (hold ?eq x (E.select [iter; event]))
| None ->
Lwt.return (hold ?eq i (E.select [iter; event]))
let diff_s f s =
let previous = ref (value s) in
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter =
E.fmap
(fun x ->
let y = !previous in
previous := x;
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> f x y))
(fun v -> push v);
None)
(changes s)
in
E.select [iter; event]
let sample_s f e s =
E.map_s (fun x -> f x (value s)) e
let accum_s ?eq ef i =
hold ?eq i (E.accum_s ef i)
let fold_s ?eq f i e =
hold ?eq i (E.fold_s f i e)
let rec rev_fold f acc = function
| [] ->
Lwt.return acc
| x :: l ->
rev_fold f acc l >>= fun acc ->
f acc x
let merge_s ?eq f acc sl =
let s = merge (fun acc x -> x :: acc) [] sl in
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter =
E.fmap
(fun l ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc l))
(fun v -> push v);
None)
(changes s)
in
Lwt_mutex.with_lock mutex (fun () -> rev_fold f acc (value s)) >>= fun x ->
Lwt.return (hold ?eq x (E.select [iter; event]))
let l1_s ?eq f s1 =
map_s ?eq f s1
let l2_s ?eq f s1 s2 =
(* Some details about the use of [fun _ _ -> false] on
https://github.com/ocsigen/lwt/pull/893#pullrequestreview-783083496 *)
map_s ?eq (fun (x1, x2) -> f x1 x2) (l2 ~eq:(fun _ _ -> false) (fun x1 x2 -> (x1, x2)) s1 s2)
let l3_s ?eq f s1 s2 s3 =
map_s ?eq (fun (x1, x2, x3) -> f x1 x2 x3) (l3 ~eq:(fun _ _ -> false) (fun x1 x2 x3-> (x1, x2, x3)) s1 s2 s3)
let l4_s ?eq f s1 s2 s3 s4 =
map_s ?eq (fun (x1, x2, x3, x4) -> f x1 x2 x3 x4) (l4 ~eq:(fun _ _ -> false) (fun x1 x2 x3 x4-> (x1, x2, x3, x4)) s1 s2 s3 s4)
let l5_s ?eq f s1 s2 s3 s4 s5 =
map_s ?eq (fun (x1, x2, x3, x4, x5) -> f x1 x2 x3 x4 x5) (l5 ~eq:(fun _ _ -> false) (fun x1 x2 x3 x4 x5-> (x1, x2, x3, x4, x5)) s1 s2 s3 s4 s5)
let l6_s ?eq f s1 s2 s3 s4 s5 s6 =
map_s ?eq (fun (x1, x2, x3, x4, x5, x6) -> f x1 x2 x3 x4 x5 x6) (l6 ~eq:(fun _ _ -> false) (fun x1 x2 x3 x4 x5 x6-> (x1, x2, x3, x4, x5, x6)) s1 s2 s3 s4 s5 s6)
(* +---------------------------------------------------------------+
| Monadic interface |
+---------------------------------------------------------------+ *)
let return =
const
let bind_s ?eq s f =
let event, push = E.create () in
let mutex = Lwt_mutex.create () in
let iter =
E.fmap
(fun x ->
Lwt.on_success
(Lwt_mutex.with_lock mutex (fun () -> f x))
(fun v -> push v);
None)
(changes s)
in
Lwt_mutex.with_lock mutex (fun () -> f (value s)) >>= fun x ->
Lwt.return (switch ?eq (hold ~eq:( == ) x (E.select [iter; event])))
end

184
unikernel/duniverse/lwt/src/react/lwt_react.mli Normal file
View file

@ -0,0 +1,184 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** React utilities *)
(** This module is an overlay for the [React] module. You can open it
instead of the [React] module in order to get all of [React]'s functions
plus Lwt ones.
This module is provided by OPAM package [lwt_react]. Link with ocamlfind
package [lwt_react]. *)
type 'a event = 'a React.event
(** Type of events. *)
type 'a signal = 'a React.signal
(** Type of signals. *)
module E : sig
include module type of React.E
(** {2 Lwt-specific utilities} *)
val with_finaliser : (unit -> unit) -> 'a event -> 'a event
(** [with_finaliser f e] returns an event [e'] which behave as
[e], except that [f] is called when [e'] is garbage
collected. *)
val next : 'a event -> 'a Lwt.t
(** [next e] returns the next occurrence of [e].
Avoid trying to create an “asynchronous loop” by calling [next e] again in
a callback attached to the promise returned by [next e]:
- The callback is called within the React update step, so calling [next e]
within it will return a promise that is fulfilled with the same value as
the current occurrence.
- If you instead arrange for the React update step to end (for example, by
calling [Lwt.pause ()] within the callback), multiple React update steps
may occur before the callback calls [next e] again, so some occurrences
can be effectively “lost.”
To robustly asynchronously process occurrences of [e] in a loop, use
[to_stream e], and repeatedly call {!Lwt_stream.next} on the resulting
stream. *)
val limit : (unit -> unit Lwt.t) -> 'a event -> 'a event
(** [limit f e] limits the rate of [e] with [f].
For example, to limit the rate of an event to 1 per second you
can use: [limit (fun () -> Lwt_unix.sleep 1.0) event]. *)
val from : (unit -> 'a Lwt.t) -> 'a event
(** [from f] creates an event which occurs each time [f ()]
returns a value. If [f] raises an exception, the event is just
stopped. *)
val to_stream : 'a event -> 'a Lwt_stream.t
(** Creates a stream holding all values occurring on the given
event *)
val of_stream : 'a Lwt_stream.t -> 'a event
(** [of_stream stream] creates an event which occurs each time a
value is available on the stream.
If updating the event causes an exception at any point during the update
step, the exception is passed to [!]{!Lwt.async_exception_hook}, which
terminates the process by default. *)
val delay : 'a event Lwt.t -> 'a event
(** [delay promise] is an event which does not occur until
[promise] resolves. Then it behaves as the event returned by
[promise]. *)
val keep : 'a event -> unit
(** [keep e] keeps a reference to [e] so it will never be garbage
collected. *)
(** {2 Threaded versions of React transformation functions} *)
(** The following functions behave as their [React] counterpart,
except that they take functions that may yield.
As usual the [_s] suffix is used when calls are serialized, and
the [_p] suffix is used when they are not.
Note that [*_p] functions may not preserve event order. *)
val app_s : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
val app_p : ('a -> 'b Lwt.t) event -> 'a event -> 'b event
val map_s : ('a -> 'b Lwt.t) -> 'a event -> 'b event
val map_p: ('a -> 'b Lwt.t) -> 'a event -> 'b event
val filter_s : ('a -> bool Lwt.t) -> 'a event -> 'a event
val filter_p : ('a -> bool Lwt.t) -> 'a event -> 'a event
val fmap_s : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
val fmap_p : ('a -> 'b option Lwt.t) -> 'a event -> 'b event
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a event -> 'b event
val accum_s : ('a -> 'a Lwt.t) event -> 'a -> 'a event
val fold_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a event
val merge_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event list -> 'a event
val run_s : 'a Lwt.t event -> 'a event
val run_p : 'a Lwt.t event -> 'a event
end
module S : sig
include module type of React.S
(** {2 Monadic interface} *)
val return : 'a -> 'a signal
(** Same as [const]. *)
val bind : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal) -> 'b signal
(** [bind ?eq s f] is initially [f x] where [x] is the current
value of [s]. Each time [s] changes to a new value [y], [bind
signal f] is set to [f y], until the next change of
[signal]. *)
val bind_s : ?eq : ('b -> 'b -> bool) -> 'a signal -> ('a -> 'b signal Lwt.t) -> 'b signal Lwt.t
(** Same as {!bind} except that [f] returns a promise. Calls to [f]
are serialized. *)
(** {2 Lwt-specific utilities} *)
val with_finaliser : (unit -> unit) -> 'a signal -> 'a signal
(** [with_finaliser f s] returns a signal [s'] which behaves as
[s], except that [f] is called when [s'] is garbage
collected. *)
val limit : ?eq : ('a -> 'a -> bool) -> (unit -> unit Lwt.t) -> 'a signal -> 'a signal
(** [limit f s] limits the rate of [s] update with [f].
For example, to limit it to 1 per second, you can use: [limit
(fun () -> Lwt_unix.sleep 1.0) s]. *)
val keep : 'a signal -> unit
(** [keep s] keeps a reference to [s] so it will never be garbage
collected. *)
(** {2 Threaded versions of React transformation functions} *)
(** The following functions behave as their [React] counterpart,
except that they take functions that may yield.
The [_s] suffix means that calls are serialized.
*)
val app_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) signal -> 'a signal -> 'b signal Lwt.t
val map_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t
val filter_s : ?eq : ('a -> 'a -> bool) -> ('a -> bool Lwt.t) -> 'a -> 'a signal -> 'a signal Lwt.t
val fmap_s : ?eq:('b -> 'b -> bool) -> ('a -> 'b option Lwt.t) -> 'b -> 'a signal -> 'b signal Lwt.t
val diff_s : ('a -> 'a -> 'b Lwt.t) -> 'a signal -> 'b event
val sample_s : ('b -> 'a -> 'c Lwt.t) -> 'b event -> 'a signal -> 'c event
val accum_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'a Lwt.t) event -> 'a -> 'a signal
val fold_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b event -> 'a signal
val merge_s : ?eq : ('a -> 'a -> bool) -> ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b signal list -> 'a signal Lwt.t
val l1_s : ?eq : ('b -> 'b -> bool) -> ('a -> 'b Lwt.t) -> 'a signal -> 'b signal Lwt.t
val l2_s : ?eq : ('c -> 'c -> bool) -> ('a -> 'b -> 'c Lwt.t) -> 'a signal -> 'b signal -> 'c signal Lwt.t
val l3_s : ?eq : ('d -> 'd -> bool) -> ('a -> 'b -> 'c -> 'd Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal Lwt.t
val l4_s : ?eq : ('e -> 'e -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal Lwt.t
val l5_s : ?eq : ('f -> 'f -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal Lwt.t
val l6_s : ?eq : ('g -> 'g -> bool) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g Lwt.t) -> 'a signal -> 'b signal -> 'c signal -> 'd signal -> 'e signal -> 'f signal -> 'g signal Lwt.t
val run_s : ?eq : ('a -> 'a -> bool) -> 'a Lwt.t signal -> 'a signal Lwt.t
end

7
unikernel/duniverse/lwt/src/retry/dune Normal file
View file

@ -0,0 +1,7 @@
(library
(public_name lwt_retry)
(synopsis "A utility for retrying Lwt computations")
(wrapped false)
(libraries lwt lwt.unix)
(instrumentation
(backend bisect_ppx)))

67
unikernel/duniverse/lwt/src/retry/lwt_retry.ml Normal file
View file

@ -0,0 +1,67 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
open Lwt.Syntax
let default_sleep_duration n' =
let base_sleep_time = 2.0 in
let n = Int.to_float n' in
n *. base_sleep_time *. Float.pow 2.0 n
type ('retry, 'fatal) error =
[ `Retry of 'retry
| `Fatal of 'fatal
]
let pp_opaque fmt _ = Format.fprintf fmt "<opaque>"
let pp_error ?(retry = pp_opaque) ?(fatal = pp_opaque) fmt err =
match err with
| `Retry r -> Format.fprintf fmt "`Retry %a" retry r
| `Fatal f -> Format.fprintf fmt "`Fatal %a" fatal f
let equal_error ~retry ~fatal a b =
match a, b with
| `Retry a', `Retry b' -> retry a' b'
| `Fatal a', `Fatal b' -> fatal a' b'
| _ -> false
type ('ok, 'retry, 'fatal) attempt = ('ok, ('retry, 'fatal) error * int) result
let on_error
(f : unit -> ('ok, ('retry, 'fatal) error) result Lwt.t)
: ('ok, 'retry, 'fatal) attempt Lwt_stream.t
=
let i = ref 0 in
let stop = ref false in
Lwt_stream.from begin fun () ->
incr i;
if !stop then
Lwt.return None
else
let+ result = f () in
match result with
| Error (`Retry _ as retry) -> Some (Error (retry, !i))
| Error (`Fatal _ as fatal) -> stop := true; Some (Error (fatal, !i))
| Ok _ as ok -> stop := true; Some ok
end
let with_sleep ?(duration=default_sleep_duration) (attempts : _ attempt Lwt_stream.t) : _ attempt Lwt_stream.t =
attempts
|> Lwt_stream.map_s begin function
| Ok _ as ok -> Lwt.return ok
| Error (_, n) as err ->
let* () = Lwt_unix.sleep @@ duration n in
Lwt.return err
end
let n_times n attempts =
if n < 0 then invalid_arg "Lwt_retry.n_times: n must be non-negative";
(* The first attempt is a try, and re-tries start counting from n + 1 *)
let retries = n + 1 in
let+ attempts = Lwt_stream.nget retries attempts in
match List.rev attempts with
| last :: _ -> last
| _ -> failwith "Lwt_retry.n_times: impossible"

157
unikernel/duniverse/lwt/src/retry/lwt_retry.mli Normal file
View file

@ -0,0 +1,157 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Utilities for retrying Lwt computations
These utilities are useful for dealing with failure-prone computations that
are expected to succeed after some number of repeated attempts. E.g.,
{[
let flaky_computation () = match try_to_get_resource () with
| Flaky_error msg -> Error (`Retry msg)
| Fatal_error err -> Error (`Fatal err)
| Success result -> Ok result
let error_tolerant_computation () =
Lwt_retry.(flaky_computation
|> on_error (* Retry when [`Retry]able results are produced. *)
|> with_sleep (* Add a delay between attempts, with an exponential backoff. *)
|> n_times 10 (* Try up to 10 times, so long as errors are retryable. *)
)
]}
This library provides a few combinators, but retry attempts are produced on
demand in an {!type:Lwt_stream.t}, and they can be consumed and traversed
using the {!module:Lwt_stream} functions directly. *)
type ('retry, 'fatal) error =
[ `Retry of 'retry
| `Fatal of 'fatal
]
(** The type of errors that a retryable computation can produce.
- [`Retry r] when [r] represents an error that can be retried.
- [`Fatal f] when [f] represents an error that cannot be retried. *)
type ('ok, 'retry, 'fatal) attempt = ('ok, ('retry, 'fatal) error * int) result
(** A [('ok, 'retry, 'fatal) attempt] is the [result] of a retryable computation,
with its the erroneous results enumerated.
- [Ok v] is a successfully computed value [v]
- [Error (err, n)] is the {!type:error} [err] produced on the [n]th
attempt
The enumeration of attempts is 1-based, because making 0 attempts means
making no attempts all, making 1 attempt means {i trying} once, and (when
[i>0]) making [n] attempts means trying once and then {i retrying} up to
[n-1] times. *)
val pp_error :
?retry:(Format.formatter -> 'retry -> unit) ->
?fatal:(Format.formatter -> 'fatal -> unit) ->
Format.formatter -> ('retry, 'fatal) error -> unit
(** [pp_error ~retry ~fatal] is a pretty printer for {!type:error}s that formats
fatal and retryable errors according to the provided printers.
If a printers is not provided, values of the type are represented as
["<opaque>"]. *)
val equal_error :
retry:('retry -> 'retry -> bool) ->
fatal:('fatal -> 'fatal -> bool) ->
('retry, 'fatal) error ->
('retry, 'fatal) error ->
bool
val on_error :
(unit -> ('ok, ('retry, 'fatal) error) result Lwt.t) ->
('ok, 'retry, 'fatal) attempt Lwt_stream.t
(** [Lwt_retry.on_error f] is a stream of attempts to compute [f], with attempts
made on demand. Attempts will be added to the stream when results are
requested until the computation either succeeds or produces a fatal error.
Examples
{[
# let success () = Lwt.return_ok ();;
val success : unit -> (unit, 'a) result Lwt.t = <fun>
# Lwt_retry.(success |> on_error) |> Lwt_stream.to_list;;
- : (unit, 'a, 'b) Lwt_retry.attempt list = [Ok ()]
# let fatal_failure () = Lwt.return_error (`Fatal ());;
val fatal_failure : unit -> ('a, [> `Fatal of unit ]) result Lwt.t = <fun>
# Lwt_retry.(fatal_failure |> on_error) |> Lwt_stream.to_list;;
- : ('a, 'b, unit) Lwt_retry.attempt list = [Error (`Fatal (), 1)]
# let retryable_error () = Lwt.return_error (`Retry ());;
val retryable_error : unit -> ('a, [> `Retry of unit ]) result Lwt.t = <fun>
# Lwt_retry.(retryable_error |> on_error) |> Lwt_stream.nget 3;;
- : ('a, unit, 'b) Lwt_retry.attempt list =
[Error (`Retry (), 1); Error (`Retry (), 2); Error (`Retry (), 3)]
]}*)
val with_sleep :
?duration:(int -> float) ->
('ok, 'retry, 'fatal) attempt Lwt_stream.t ->
('ok, 'retry, 'fatal) attempt Lwt_stream.t
(** [with_sleep ~duration attempts] is the stream of [attempts] with a sleep of
[duration n] seconds added before computing each [n]th retryable attempt.
@param duration the optional sleep duration calculation, defaulting to
{!val:default_sleep_duration}.
Examples
{[
# let f () = Lwt.return_error (`Retry ());;
# let attempts_with_sleeps = Lwt_retry.(f |> on_error |> with_sleep);;
# Lwt_stream.get attempts_with_sleeps;;
(* computed immediately *)
Some (Error (`Retry (), 1))
# Lwt_stream.get attempts_with_sleeps;;
(* computed after 3 seconds *)
Some (Error (`Retry (), 2))
# Lwt_stream.get attempts_with_sleeps;;
(* computed after 9 seconds *)
Some (Error (`Retry (), 3))
(* a stream with a constant 1s sleep between attempts *)
# let attempts_with_constant_sleeps =
Lwt_retry.(f |> on_error |> with_sleep ~duration:(fun _ -> 1.0));;
]} *)
val default_sleep_duration : int -> float
(** [default_sleep_duration n] is an exponential backoff computed as [n] * 2 *
(2 ^ [n]), which gives the sequence [ [0.; 4.; 16.; 48.; 128.; 320.; 768.;
1792.; ...] ]. *)
val n_times :
int ->
('ok, 'retry, 'fatal) attempt Lwt_stream.t ->
('ok, 'retry, 'fatal) attempt Lwt.t
(** [n_times n attempts] is [Ok v] if one of the [attempts] succeeds within [n]
retries (or [n+1] attempts), [Error (`Fatal f, n+1)] if any of the attempts
results in the fatal error, or [Error (`Retry r, n+1)] if all [n] retries are
exhausted and the [n+1]th attempt results in a retry error.
In particular [n_times 0 attempts] will *try* 1 attempt but *re-try* 0, so
it is guaranteed to produce some result.
[n_times] forces up to [n] elements of the on-demand stream of attempts.
Examples
{[
# let f () =
let i = ref 0 in
fun () -> Lwt.return_error (if !i < 3 then (incr i; `Retry ()) else `Fatal "error!");;
# Lwt_retry.(f () |> on_error |> n_times 0);;
Error (`Retry (), 1)
# Lwt_retry.(f () |> on_error |> n_times 4);;
Error (`Fatal "error!", 3)
]} *)

875
unikernel/duniverse/lwt/src/unix/config/discover.ml Normal file
View file

@ -0,0 +1,875 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Lwt_unix feature discovery script.
This program tests system features, and outputs four files:
- [src/unix/lwt_features.h]: feature test results for consumption by C code.
- [src/unix/lwt_features.ml]: test results for consumption by OCaml code.
- [src/unix/unix_c_flags.sexp]: C compiler flags for Lwt_unix C sources.
- [src/unix/unix_c_library_flags.sexp]: C linker flags for Lwt_unix.
[src/unix/lwt_features.h] contains only basic [#define] macros. It is
included in [src/unix/lwt_config.h], which computes a few more useful
macros. [src/unix/lwt_config.h] is the file that is then directly included
by all the C sources.
[src/unix/lwt_features.ml] is included by [src/unix/lwt_config.ml] in the
same way.
You can examine the generated [lwt_features.h] by running [dune build] and
looking in [_build/default/src/unix/lwt_features.h], and similarly for
[lwt_features.ml].
This program tries to detect everything automatically. If it is not behaving
correctly, its behavior can be tweaked by passing it arguments. There are
four ways to do so:
- By editing [src/unix/dune], to pass arguments to [discover.exe] on the
command line.
- By setting the environment variable [LWT_DISCOVER_ARGUMENTS]. The syntax
is the same as the command line.
- By writing a file [src/unix/discover_arguments]. The syntax is again the
same as the command line.
- By running [dune exec src/unix/config/discover.exe -- --save] with
additional arguments. Those arguments will be written to
[src/unix/discover_arguments] for the build to use later.
The possible arguments can be found by running
{v
dune exec src/unix/config/discover.exe -- --help
v}
In addition, the environment variables [LIBEV_CFLAGS], [LIBEV_LIBS],
[PTHREAD_CFLAGS], and [PTHREAD_LIBS] can be used to override the flags used
for compiling with libev and pthreads.
This [discover.ml] was added in Lwt 4.3.0, so if you pass arguments to
[discover.ml], 4.3.0 is the minimal required version of Lwt.
The code is broken up into sections, each of which is an OCaml module. If
your text editor supports code folding, it will make reading this file much
easier if you fold the structures.
Add feature tests at the end of module [Features]. For most cases, what to
do should be clear from the feature tests that are already in that
module. *)
module Configurator = Configurator.V1
let split = Configurator.Flags.extract_blank_separated_words
let uppercase = String.uppercase_ascii
(* Command-line arguments and environment variables. *)
module Arguments :
sig
val use_libev : bool option ref
val use_pthread : bool option ref
val android_target : bool option ref
val libev_default : bool option ref
val verbose : bool ref
val args : (Arg.key * Arg.spec * Arg.doc) list
val parse_environment_variable : unit -> unit
val parse_arguments_file : unit -> unit
end =
struct
let use_libev = ref None
let use_pthread = ref None
let android_target = ref None
let libev_default = ref None
let verbose = ref false
let set reference =
Arg.Bool (fun value -> reference := Some value)
let args = [
"--use-libev", set use_libev,
"BOOLEAN whether to check for libev";
"--use-pthread", set use_pthread,
"BOOLEAN whether to check for libpthread";
"--android-target", set android_target,
"BOOLEAN whether to compile for Android";
"--libev-default", set libev_default,
"BOOLEAN whether to use the libev backend by default";
"--verbose", Arg.Set verbose,
"BOOLEAN show results of feature detection";
]
let environment_variable = "LWT_DISCOVER_ARGUMENTS"
let arguments_file = "discover_arguments"
let parse arguments =
try
Arg.parse_argv
~current:(ref 0)
(Array.of_list ((Filename.basename Sys.argv.(0))::(split arguments)))
(Arg.align args)
(fun s ->
raise (Arg.Bad (Printf.sprintf "Unrecognized argument '%s'" s)))
(Printf.sprintf
"Environment variable usage: %s=[OPTIONS]" environment_variable)
with
| Arg.Bad s ->
prerr_string s;
exit 2
| Arg.Help s ->
print_string s;
exit 0
let parse_environment_variable () =
match Sys.getenv environment_variable with
| exception Not_found ->
()
| arguments ->
parse arguments
let parse_arguments_file () =
try
let channel = open_in arguments_file in
parse (input_line channel);
close_in channel
with _ ->
()
end
module C_library_flags :
sig
val detect :
?env_var:string ->
?package:string ->
?header:string ->
Configurator.t ->
library:string ->
unit
val ws2_32_lib : Configurator.t -> unit
val c_flags : unit -> string list
val link_flags : unit -> string list
val add_link_flags : string list -> unit
end =
struct
let c_flags = ref ["-Wall"; "-fdiagnostics-color=always"]
let link_flags = ref []
let extend c_flags' link_flags' =
c_flags := !c_flags @ c_flags';
link_flags := !link_flags @ link_flags'
let add_link_flags flags =
extend [] flags
let (//) = Filename.concat
let default_search_paths = [
"/usr";
"/usr/local";
"/usr/pkg";
"/opt";
"/opt/local";
"/sw";
"/mingw";
]
let path_separator =
if Sys.win32 then
';'
else
':'
let paths_from_environment_variable variable =
match Sys.getenv variable with
| exception Not_found ->
[]
| paths ->
Configurator.Flags.extract_words paths ~is_word_char:((<>) path_separator)
|> List.map Filename.dirname
let search_paths =
lazy begin
paths_from_environment_variable "C_INCLUDE_PATH" @
paths_from_environment_variable "LIBRARY_PATH" @
default_search_paths
end
let default argument fallback =
match argument with
| Some value -> value
| None -> fallback
let detect ?env_var ?package ?header context ~library =
let env_var = default env_var ("LIB" ^ uppercase library) in
let package = default package ("lib" ^ library) in
let header = default header (library ^ ".h") in
let flags_from_env_var =
let c_flags_var = env_var ^ "_CFLAGS" in
let link_flags_var = env_var ^ "_LIBS" in
match Sys.getenv c_flags_var, Sys.getenv link_flags_var with
| exception Not_found ->
None
| "", "" ->
None
| values ->
Some values
in
match flags_from_env_var with
| Some (c_flags', link_flags') ->
extend (split c_flags') (split link_flags')
| None ->
let flags_from_pkg_config =
match Configurator.Pkg_config.get context with
| None ->
None
| Some pkg_config ->
Configurator.Pkg_config.query pkg_config ~package
in
match flags_from_pkg_config with
| Some flags ->
extend flags.cflags flags.libs
| None ->
try
let path =
List.find
(fun path -> Sys.file_exists (path // "include" // header))
(Lazy.force search_paths)
in
extend
["-I" ^ (path // "include")]
["-L" ^ (path // "lib"); "-l" ^ library]
with Not_found ->
()
let ws2_32_lib context =
if Configurator.ocaml_config_var_exn context "os_type" = "Win32" then
let unicode = ["-DUNICODE"; "-D_UNICODE"] in
if Configurator.ocaml_config_var_exn context "ccomp_type" = "msvc" then
extend unicode ["ws2_32.lib"]
else
extend unicode ["-lws2_32"]
else
extend ["-fPIC"; "-pthread"] ["-fPIC"; "-pthread"]
let c_flags () =
!c_flags
let link_flags () =
!link_flags
end
module Output :
sig
type t = {
name : string;
found : bool;
}
val write_c_header : ?extra:string list -> Configurator.t -> t list -> unit
val write_ml_file : ?extra:t list -> t list -> unit
val write_flags_files : unit -> unit
end =
struct
type t = {
name : string;
found : bool;
}
module C_define = Configurator.C_define
let c_header = "lwt_features.h"
let ml_file = "lwt_features.ml"
let c_flags_file = "unix_c_flags.sexp"
let link_flags_file = "unix_c_library_flags.sexp"
let write_c_header ?(extra = []) context macros =
macros
|> List.filter (fun {found; _} -> found)
|> List.map (fun {name; _} -> name, C_define.Value.Switch true)
|> (@) (List.map (fun s -> s, C_define.Value.Switch true) extra)
|> C_define.gen_header_file context ~fname:c_header
let write_ml_file ?(extra = []) macros =
macros
|> List.map (fun {name; found} -> Printf.sprintf "let _%s = %b" name found)
|> (@) (List.map
(fun {name; found} -> Printf.sprintf "let %s = %b" name found) extra)
|> Configurator.Flags.write_lines ml_file
let write_flags_files () =
Configurator.Flags.write_sexp
c_flags_file (C_library_flags.c_flags ());
Configurator.Flags.write_sexp
link_flags_file (C_library_flags.link_flags ());
end
module Features :
sig
val detect : Configurator.t -> Output.t list
end =
struct
type t = {
pretty_name : string;
macro_name : string;
detect : Configurator.t -> bool option;
}
let features = ref []
let feature the_feature =
features := !features @ [the_feature]
let verbose =
Printf.ksprintf (fun s ->
if !Arguments.verbose then
print_string s)
let dots feature to_column =
String.make (to_column - String.length feature.pretty_name) '.'
let right_column = 40
let detect context =
!features
|> List.map begin fun feature ->
verbose "%s " feature.pretty_name;
match feature.detect context with
| None ->
verbose "%s skipped\n" (dots feature right_column);
Output.{name = feature.macro_name; found = false}
| Some found ->
begin
if found then
verbose "%s available\n" (dots feature (right_column - 2))
else
verbose "%s unavailable\n" (dots feature (right_column - 4))
end;
Output.{name = feature.macro_name; found}
end
let compiles ?(werror = false) ?(link_flags = []) context code =
let c_flags = C_library_flags.c_flags () in
let c_flags =
if werror then
"-Werror"::c_flags
else
c_flags
in
let link_flags = link_flags @ (C_library_flags.link_flags ()) in
Configurator.c_test context ~c_flags ~link_flags code
|> fun result -> Some result
let skip_if_windows context k =
match Configurator.ocaml_config_var_exn context "os_type" with
| "Win32" -> None
| _ -> k ()
let skip_if_android _context k =
match !Arguments.android_target with
| Some true -> None
| _ -> k ()
let () = feature {
pretty_name = "libev";
macro_name = "HAVE_LIBEV";
detect = fun context ->
let detect_esy_wants_libev () =
match Sys.getenv "cur__target_dir" with
| exception Not_found -> None
| _ ->
match Sys.getenv "LIBEV_CFLAGS", Sys.getenv "LIBEV_LIBS" with
| exception Not_found -> Some false
| "", "" -> Some false
| _ -> Some true
in
let should_look_for_libev =
match !Arguments.use_libev with
| Some argument ->
argument
| None ->
match detect_esy_wants_libev () with
| Some result ->
result
| None ->
(* we're not under esy *)
let os = Configurator.ocaml_config_var_exn context "os_type" in
os <> "Win32" && !Arguments.android_target <> Some true
in
if not should_look_for_libev then
None
else begin
let code = {|
#include <ev.h>
int main(void)
{
ev_default_loop(0);
return 0;
}
|}
in
match compiles context code ~link_flags:["-lev"] with
| Some true ->
C_library_flags.add_link_flags ["-lev"];
Some true
| _ ->
C_library_flags.detect context ~library:"ev";
compiles context code
end
}
let () = feature {
pretty_name = "pthread";
macro_name = "HAVE_PTHREAD";
detect = fun context ->
if !Arguments.use_pthread = Some false then
None
else begin
skip_if_windows context @@ fun () ->
let code = {|
#include <pthread.h>
int main(void)
{
pthread_create(0, 0, 0, 0);
return 0;
}
|}
in
(* On some platforms, pthread is included in the standard library, but
linking with -lpthread fails. So, try to link the test code without
any flags first.
If that fails and we are not targeting Android, try to link with
-lpthread. If *that* fails, search for libpthread in the filesystem.
When targeting Android, compiling without -lpthread is the only way
to link with pthread, and we don't to search for libpthread, because
if we find it, it is likely the host's libpthread. *)
match compiles context code with
| Some true -> Some true
| no ->
if !Arguments.android_target = Some true then
no
else begin
match compiles context code ~link_flags:["-lpthread"] with
| Some true ->
C_library_flags.add_link_flags ["-lpthread"];
Some true
| _ ->
C_library_flags.detect context ~library:"pthread";
compiles context code
end
end
}
let () = feature {
pretty_name = "eventfd";
macro_name = "HAVE_EVENTFD";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context {|
#include <sys/eventfd.h>
int main(void)
{
eventfd(0, 0);
return 0;
}
|}
}
let () = feature {
pretty_name = "fd passing";
macro_name = "HAVE_FD_PASSING";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context {|
#include <sys/types.h>
#include <sys/socket.h>
int main(void)
{
struct msghdr msg;
msg.msg_controllen = 0;
msg.msg_control = 0;
return 0;
}
|}
}
let () = feature {
pretty_name = "sched_getcpu";
macro_name = "HAVE_GETCPU";
detect = fun context ->
skip_if_windows context @@ fun () ->
skip_if_android context @@ fun () ->
compiles context {|
#define _GNU_SOURCE
#include <sched.h>
int main(void)
{
sched_getcpu();
return 0;
}
|}
}
let () = feature {
pretty_name = "affinity getting/setting";
macro_name = "HAVE_AFFINITY";
detect = fun context ->
skip_if_windows context @@ fun () ->
skip_if_android context @@ fun () ->
compiles context {|
#define _GNU_SOURCE
#include <sched.h>
int main(void)
{
sched_getaffinity(0, 0, 0);
return 0;
}
|}
}
let get_credentials struct_name = {|
#define _GNU_SOURCE
#include <sys/types.h>
#include <sys/socket.h>
int main(void)
{
struct |} ^ struct_name ^ {| cred;
socklen_t cred_len = sizeof(cred);
getsockopt(0, SOL_SOCKET, SO_PEERCRED, &cred, &cred_len);
return 0;
}
|}
let () = feature {
pretty_name = "credentials getting (Linux)";
macro_name = "HAVE_GET_CREDENTIALS_LINUX";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context (get_credentials "ucred")
}
let () = feature {
pretty_name = "credentials getting (NetBSD)";
macro_name = "HAVE_GET_CREDENTIALS_NETBSD";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context (get_credentials "sockcred")
}
let () = feature {
pretty_name = "credentials getting (OpenBSD)";
macro_name = "HAVE_GET_CREDENTIALS_OPENBSD";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context (get_credentials "sockpeercred")
}
let () = feature {
pretty_name = "credentials getting (FreeBSD)";
macro_name = "HAVE_GET_CREDENTIALS_FREEBSD";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context (get_credentials "cmsgcred")
}
let () = feature {
pretty_name = "getpeereid";
macro_name = "HAVE_GETPEEREID";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context {|
#include <sys/types.h>
#include <unistd.h>
int main(void)
{
uid_t euid;
gid_t egid;
getpeereid(0, &euid, &egid);
return 0;
}
|}
}
let () = feature {
pretty_name = "fdatasync";
macro_name = "HAVE_FDATASYNC";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context {|
#include <unistd.h>
int main(void)
{
int (*fdatasyncp)(int) = fdatasync;
fdatasyncp(0);
return 0;
}
|}
}
let () = feature {
pretty_name = "netdb_reentrant";
macro_name = "HAVE_NETDB_REENTRANT";
detect = fun context ->
skip_if_windows context @@ fun () ->
skip_if_android context @@ fun () ->
compiles context {|
#define _POSIX_PTHREAD_SEMANTICS
#include <netdb.h>
#include <stddef.h>
int main(void)
{
int x;
x =
gethostbyname_r(
(const char*)NULL,
(struct hostent*)NULL,
(char*)NULL,
(int)0,
(struct hostent**)NULL,
(int*)NULL);
x =
gethostbyaddr_r(
(const void*)NULL,
(int)0,
(int)0,
(struct hostent*)NULL,
(char*)NULL,
(int)0,
(struct hostent**)NULL,
(int*)NULL);
x =
getservbyname_r(
(const char*)NULL,
(const char*)NULL,
(struct servent*)NULL,
(char*)NULL,
(int)0,
(struct servent**)NULL);
x =
getservbyport_r(
(int)0,
(const char*)NULL,
(struct servent*)NULL,
(char*)NULL,
(int)0,
(struct servent**)NULL);
x =
getprotoent_r(
(struct protoent*)NULL,
(char*)NULL,
(int)0,
(struct protoent**)NULL);
x =
getprotobyname_r(
(const char*)NULL,
(struct protoent*)NULL,
(char*)NULL,
(int)0,
(struct protoent**)NULL);
x =
getprotobynumber_r(
(int)0,
(struct protoent*)NULL,
(char*)NULL,
(int)0,
(struct protoent**)NULL);
return 0;
}
|}
}
let () = feature {
pretty_name = "reentrant gethost*";
macro_name = "HAVE_REENTRANT_HOSTENT";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context {|
#define _GNU_SOURCE
#include <stddef.h>
#include <caml/config.h>
/* Helper functions for not re-entrant functions */
#if !defined(HAS_GETHOSTBYADDR_R) || \
(HAS_GETHOSTBYADDR_R != 7 && HAS_GETHOSTBYADDR_R != 8)
#define NON_R_GETHOSTBYADDR 1
#endif
#if !defined(HAS_GETHOSTBYNAME_R) || \
(HAS_GETHOSTBYNAME_R != 5 && HAS_GETHOSTBYNAME_R != 6)
#define NON_R_GETHOSTBYNAME 1
#endif
int main(void)
{
#if defined(NON_R_GETHOSTBYNAME) || defined(NON_R_GETHOSTBYNAME)
#error "not available"
#else
return 0;
#endif
}
|}
}
let nanosecond_stat projection = {|
#define _GNU_SOURCE
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
int main(void) {
struct stat *buf;
double a, m, c;
a = (double)buf->st_a|} ^ projection ^ {|;
m = (double)buf->st_m|} ^ projection ^ {|;
c = (double)buf->st_c|} ^ projection ^ {|;
return 0;
}
|}
let () = feature {
pretty_name = "st_mtim.tv_nsec";
macro_name = "HAVE_ST_MTIM_TV_NSEC";
detect = fun context ->
compiles context (nanosecond_stat "tim.tv_nsec")
}
let () = feature {
pretty_name = "st_mtimespec.tv_nsec";
macro_name = "HAVE_ST_MTIMESPEC_TV_NSEC";
detect = fun context ->
compiles context (nanosecond_stat "timespec.tv_nsec")
}
let () = feature {
pretty_name = "st_mtimensec";
macro_name = "HAVE_ST_MTIMENSEC";
detect = fun context ->
compiles context (nanosecond_stat "timensec")
}
let () = feature {
pretty_name = "BSD mincore";
macro_name = "HAVE_BSD_MINCORE";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles ~werror:true context {|
#include <unistd.h>
#include <sys/mman.h>
int main(void)
{
int (*mincore_ptr)(const void*, size_t, char*) = mincore;
return (int)(mincore_ptr == NULL);
}
|}
}
let () = feature {
pretty_name = "accept4";
macro_name = "HAVE_ACCEPT4";
detect = fun context ->
skip_if_windows context @@ fun () ->
compiles context {|
#define _GNU_SOURCE
#include <sys/socket.h>
#include <stddef.h>
int main(void)
{
accept4(0, NULL, 0, 0);
return 0;
}
|}
}
end
let () =
begin match List.partition ((=) "--save") (Array.to_list Sys.argv) with
| ["--save"], rest ->
Configurator.Flags.write_lines
"src/unix/discover_arguments" [String.concat " " (List.tl rest)];
exit 0
| _ ->
()
end;
Configurator.main ~args:Arguments.args ~name:"lwt" begin fun context ->
(* Parse arguments from additional sources. *)
Arguments.parse_environment_variable ();
Arguments.parse_arguments_file ();
(* Detect features. *)
let macros = Features.detect context in
(* Link with ws2_32.lib on Windows. *)
C_library_flags.ws2_32_lib context;
(* Write lwt_features.h. *)
let extra =
match Configurator.ocaml_config_var_exn context "os_type" with
| "Win32" -> ["LWT_ON_WINDOWS"]
| _ -> []
in
Output.write_c_header ~extra context macros;
(* Write lwt_features.ml. *)
let libev_default =
match !Arguments.libev_default with
| Some argument ->
argument
| None ->
true
in
Output.write_ml_file
~extra:[
{
name = "android";
found = !Arguments.android_target = Some true;
};
{
name = "libev_default";
found = libev_default;
};
] macros;
(* Write unix_c_flags.sexp and unix_c_library_flags.sexp. *)
Output.write_flags_files ()
end

4
unikernel/duniverse/lwt/src/unix/config/dune Normal file
View file

@ -0,0 +1,4 @@
(executable
(name discover)
(modules discover)
(libraries dune.configurator))

196
unikernel/duniverse/lwt/src/unix/dune Normal file
View file

@ -0,0 +1,196 @@
(rule
(targets lwt_process.ml)
(deps
(:ml lwt_process.cppo.ml))
(action
(chdir
%{project_root}
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{ml} -o %{targets}))))
(rule
(targets lwt_unix.ml)
(deps
(:ml lwt_unix.cppo.ml))
(action
(chdir
%{project_root}
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{ml} -o %{targets}))))
(rule
(targets lwt_unix.mli)
(deps
(:ml lwt_unix.cppo.mli))
(action
(chdir
%{project_root}
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{ml} -o %{targets}))))
(rule
(mode fallback)
(targets discover_arguments)
(action
(with-stdout-to
%{targets}
(echo ""))))
(rule
(targets
unix_c_flags.sexp
unix_c_library_flags.sexp
lwt_features.h
lwt_features.ml)
(deps
(:exe config/discover.exe)
discover_arguments)
(action
(run %{exe})))
(copy_files unix_c/*)
(copy_files windows_c/*.c)
(library
(name lwt_unix)
(public_name lwt.unix)
(synopsis "Unix support for Lwt")
(wrapped false)
(libraries bigarray lwt ocplib-endian.bigstring threads unix)
(install_c_headers lwt_features lwt_config lwt_unix)
(foreign_stubs
(language c)
(names
lwt_unix_stubs
lwt_libev_stubs
lwt_process_stubs
unix_readable
unix_writable
unix_madvise
unix_get_page_size
windows_get_page_size
unix_mincore
unix_read
unix_pread
windows_read
windows_pread
unix_bytes_read
windows_bytes_read
unix_write
unix_pwrite
windows_write
windows_pwrite
unix_bytes_write
windows_bytes_write
unix_readv_writev_utils
unix_iov_max
unix_writev
unix_writev_job
unix_readv
unix_readv_job
unix_send
unix_bytes_send
unix_recv
unix_bytes_recv
unix_recvfrom
unix_bytes_recvfrom
unix_sendto
unix_sendto_byte
unix_bytes_sendto
unix_bytes_sendto_byte
unix_recv_send_utils
unix_recv_msg
unix_send_msg
unix_send_msg_byte
unix_get_credentials
unix_mcast_utils
unix_mcast_set_loop
unix_mcast_set_ttl
unix_mcast_modify_membership
unix_wait4
unix_get_cpu
unix_get_affinity
unix_set_affinity
unix_guess_blocking_job
unix_wait_mincore_job
unix_open_job
unix_read_job
unix_pread_job
windows_read_job
windows_pread_job
unix_bytes_read_job
windows_bytes_read_job
unix_write_job
windows_write_job
unix_pwrite_job
windows_pwrite_job
unix_bytes_write_job
windows_bytes_write_job
unix_stat_job_utils
unix_stat_job
unix_stat_64_job
unix_lstat_job
unix_lstat_64_job
unix_fstat_job
unix_fstat_64_job
unix_utimes_job
unix_isatty_job
unix_opendir_job
unix_closedir_job
unix_valid_dir
unix_invalidate_dir
unix_rewinddir_job
unix_readdir_job
unix_readdir_n_job
unix_readlink_job
unix_lockf_job
unix_getlogin_job
unix_get_pw_gr_nam_id_job
unix_get_network_information_utils
unix_gethostname_job
unix_gethostbyname_job
unix_gethostbyaddr_job
unix_getprotoby_getservby_job
unix_getaddrinfo_job
unix_getnameinfo_job
unix_bind_job
unix_getcwd_job
unix_termios_conversion
unix_tcgetattr_job
unix_tcsetattr_job
windows_is_socket
windows_fsync_job
windows_system_job
windows_not_available
unix_not_available
unix_access_job
unix_chdir_job
unix_chmod_job
unix_chown_job
unix_chroot_job
unix_close_job
unix_fchmod_job
unix_fchown_job
unix_fdatasync_job
unix_fsync_job
unix_ftruncate_job
unix_link_job
unix_lseek_job
unix_mkdir_job
unix_mkfifo_job
unix_rename_job
unix_rmdir_job
unix_symlink_job
unix_tcdrain_job
unix_tcflow_job
unix_tcflush_job
unix_tcsendbreak_job
unix_truncate_job
unix_unlink_job
unix_somaxconn
windows_somaxconn
unix_accept4)
(flags
(:include unix_c_flags.sexp)))
(c_library_flags
(:include unix_c_library_flags.sexp))
(instrumentation
(backend bisect_ppx)))

230
unikernel/duniverse/lwt/src/unix/lwt_bytes.ml Normal file
View file

@ -0,0 +1,230 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
open Bigarray
type t = (char, int8_unsigned_elt, c_layout) Array1.t
let create size = Array1.create char c_layout size
let length bytes = Array1.dim bytes
external get : t -> int -> char = "%caml_ba_ref_1"
external set : t -> int -> char -> unit = "%caml_ba_set_1"
external unsafe_get : t -> int -> char = "%caml_ba_unsafe_ref_1"
external unsafe_set : t -> int -> char -> unit = "%caml_ba_unsafe_set_1"
external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc"
[@@ocaml.warning "-3"]
let fill bytes ofs len ch =
if ofs < 0 || len < 0 || ofs > length bytes - len then
invalid_arg "Lwt_bytes.fill"
else
unsafe_fill bytes ofs len ch
(* +-----------------------------------------------------------------+
| Blitting |
+-----------------------------------------------------------------+ *)
[@@@ocaml.warning "-3"]
external unsafe_blit_from_bytes : Bytes.t -> int -> t -> int -> int -> unit = "lwt_unix_blit_from_bytes" "noalloc"
external unsafe_blit_from_string : string -> int -> t -> int -> int -> unit = "lwt_unix_blit_from_string" "noalloc"
external unsafe_blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit = "lwt_unix_blit_to_bytes" "noalloc"
external unsafe_blit : t -> int -> t -> int -> int -> unit = "lwt_unix_blit" "noalloc"
[@@@ocaml.warning "+3"]
let blit_from_string src_buf src_ofs dst_buf dst_ofs len =
if (len < 0
|| src_ofs < 0 || src_ofs > String.length src_buf - len
|| dst_ofs < 0 || dst_ofs > length dst_buf - len) then
invalid_arg "Lwt_bytes.blit_from_string"
else
unsafe_blit_from_string src_buf src_ofs dst_buf dst_ofs len
let blit_from_bytes src_buf src_ofs dst_buf dst_ofs len =
if (len < 0
|| src_ofs < 0 || src_ofs > Bytes.length src_buf - len
|| dst_ofs < 0 || dst_ofs > length dst_buf - len) then
invalid_arg "Lwt_bytes.blit_from_bytes"
else
unsafe_blit_from_bytes src_buf src_ofs dst_buf dst_ofs len
let blit_to_bytes src_buf src_ofs dst_buf dst_ofs len =
if (len < 0
|| src_ofs < 0 || src_ofs > length src_buf - len
|| dst_ofs < 0 || dst_ofs > Bytes.length dst_buf - len) then
invalid_arg "Lwt_bytes.blit_to_bytes"
else
unsafe_blit_to_bytes src_buf src_ofs dst_buf dst_ofs len
let blit src_buf src_ofs dst_buf dst_ofs len =
if (len < 0
|| src_ofs < 0 || src_ofs > length src_buf - len
|| dst_ofs < 0 || dst_ofs > length dst_buf - len) then
invalid_arg "Lwt_bytes.blit"
else
unsafe_blit src_buf src_ofs dst_buf dst_ofs len
let of_bytes buf =
let len = Bytes.length buf in
let bytes = create len in
unsafe_blit_from_bytes buf 0 bytes 0 len;
bytes
let of_string str = of_bytes (Bytes.unsafe_of_string str)
let to_bytes bytes =
let len = length bytes in
let str = Bytes.create len in
unsafe_blit_to_bytes bytes 0 str 0 len;
str
let to_string bytes = Bytes.unsafe_to_string (to_bytes bytes)
let proxy = Array1.sub
let extract buf ofs len =
if ofs < 0 || len < 0 || ofs > length buf - len then
invalid_arg "Lwt_bytes.extract"
else begin
let buf' = create len in
blit buf ofs buf' 0 len;
buf'
end
let copy buf =
let len = length buf in
let buf' = create len in
blit buf 0 buf' 0 len;
buf'
(* +-----------------------------------------------------------------+
| IOs |
+-----------------------------------------------------------------+ *)
open Lwt_unix
let read =
Lwt_unix.read_bigarray "Lwt_bytes.read" [@ocaml.warning "-3"]
let write =
Lwt_unix.write_bigarray "Lwt_bytes.write" [@ocaml.warning "-3"]
external stub_recv : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_recv"
let recv fd buf pos len flags =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.recv"
else
wrap_syscall Read fd (fun () -> stub_recv (unix_file_descr fd) buf pos len flags)
external stub_send : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int = "lwt_unix_bytes_send"
let send fd buf pos len flags =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.send"
else
wrap_syscall Write fd (fun () -> stub_send (unix_file_descr fd) buf pos len flags)
type io_vector = {
iov_buffer : t;
iov_offset : int;
iov_length : int;
}
let io_vector ~buffer ~offset ~length = ({
iov_buffer = buffer;
iov_offset = offset;
iov_length = length;
} : io_vector)
let convert_io_vectors old_io_vectors =
let io_vectors = IO_vectors.create () in
old_io_vectors
|> List.iter (fun ({iov_buffer; iov_offset; iov_length} : io_vector) ->
IO_vectors.append_bigarray io_vectors iov_buffer iov_offset iov_length);
io_vectors
let recv_msg ~socket ~io_vectors =
Lwt_unix.recv_msg ~socket ~io_vectors:(convert_io_vectors io_vectors)
let send_msg ~socket ~io_vectors ~fds =
Lwt_unix.send_msg ~socket ~io_vectors:(convert_io_vectors io_vectors) ~fds
external stub_recvfrom : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr = "lwt_unix_bytes_recvfrom"
let recvfrom fd buf pos len flags =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.recvfrom"
else
wrap_syscall Read fd (fun () -> stub_recvfrom (unix_file_descr fd) buf pos len flags)
external stub_sendto : Unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int = "lwt_unix_bytes_sendto_byte" "lwt_unix_bytes_sendto"
let sendto fd buf pos len flags addr =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.sendto"
else
wrap_syscall Write fd (fun () -> stub_sendto (unix_file_descr fd) buf pos len flags addr)
(* +-----------------------------------------------------------------+
| Memory mapped files |
+-----------------------------------------------------------------+ *)
let map_file ~fd ?pos ~shared ?(size=(-1)) () =
Unix.map_file fd ?pos char c_layout shared [|size|]
|> Bigarray.array1_of_genarray
external mapped : t -> bool = "lwt_unix_mapped" "noalloc"
[@@ocaml.warning "-3"]
type advice =
| MADV_NORMAL
| MADV_RANDOM
| MADV_SEQUENTIAL
| MADV_WILLNEED
| MADV_DONTNEED
| MADV_MERGEABLE
| MADV_UNMERGEABLE
| MADV_HUGEPAGE
| MADV_NOHUGEPAGE
external stub_madvise : t -> int -> int -> advice -> unit = "lwt_unix_madvise"
let madvise buf pos len advice =
if pos < 0 || len < 0 || pos > length buf - len then
invalid_arg "Lwt_bytes.madvise"
else
stub_madvise buf pos len advice
external get_page_size : unit -> int = "lwt_unix_get_page_size"
let page_size = get_page_size ()
external stub_mincore : t -> int -> int -> bool array -> unit = "lwt_unix_mincore"
let mincore buffer offset states =
if (offset mod page_size <> 0
|| offset < 0
|| length buffer - offset < (Array.length states - 1) * page_size + 1)
then
invalid_arg "Lwt_bytes.mincore"
else
stub_mincore buffer offset (Array.length states * page_size) states
external wait_mincore_job : t -> int -> unit job = "lwt_unix_wait_mincore_job"
let wait_mincore buffer offset =
if offset < 0 || offset >= length buffer then
invalid_arg "Lwt_bytes.wait_mincore"
else begin
let state = [|false|] in
mincore buffer (offset - (offset mod page_size)) state;
if state.(0) then
Lwt.return_unit
else
run_job (wait_mincore_job buffer offset)
end

192
unikernel/duniverse/lwt/src/unix/lwt_bytes.mli Normal file
View file

@ -0,0 +1,192 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Byte arrays *)
type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
(** Type of array of bytes. *)
val create : int -> t
(** Creates a new byte array of the given size. *)
val length : t -> int
(** Returns the length of the given byte array. *)
(** {2 Access} *)
val get : t -> int -> char
(** [get buffer offset] returns the byte at offset [offset] in
[buffer]. *)
val set : t -> int -> char -> unit
(** [get buffer offset value] changes the value of the byte at
offset [offset] in [buffer] to [value]. *)
val unsafe_get : t -> int -> char
(** Same as {!get} but without bounds checking. *)
val unsafe_set : t -> int -> char -> unit
(** Same as {!set} but without bounds checking. *)
(** {2 Conversions} *)
val of_bytes : bytes -> t
(** [of_bytes buf] returns a newly allocated byte array with the
same contents as [buf]. *)
val of_string : string -> t
(** [of_string buf] returns a newly allocated byte array with the
same contents as [buf]. *)
val to_bytes : t -> bytes
(** [to_bytes buf] returns newly allocated bytes with the same
contents as [buf]. *)
val to_string : t -> string
(** [to_string buf] returns a newly allocated string with the same
contents as [buf]. *)
(** {2 Copying} *)
val blit : t -> int -> t -> int -> int -> unit
(** [blit buf1 ofs1 buf2 ofs2 len] copies [len] bytes from [buf1]
starting at offset [ofs1] to [buf2] starting at offset [ofs2]. *)
val blit_from_string : string -> int -> t -> int -> int -> unit
(** Same as {!blit} but the first buffer is a [String.t] instead of a byte
array. *)
val blit_from_bytes : bytes -> int -> t -> int -> int -> unit
(** Same as {!blit} but the first buffer is a [Bytes.t] instead of a byte
array. *)
val blit_to_bytes : t -> int -> bytes -> int -> int -> unit
(** Same as {!blit} but the second buffer is a [Bytes.t] instead of a byte
array. *)
val unsafe_blit : t -> int -> t -> int -> int -> unit
(** Same as {!blit} but without bound checking. *)
val unsafe_blit_from_bytes : bytes -> int -> t -> int -> int -> unit
(** Same as {!Lwt_bytes.blit_from_bytes} but without bounds checking. *)
val unsafe_blit_from_string : string -> int -> t -> int -> int -> unit
(** Same as {!Lwt_bytes.blit_from_string} but without bounds checking. *)
val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
(** Same as {!Lwt_bytes.blit_to_bytes} but without bounds checking. *)
val proxy : t -> int -> int -> t
(** [proxy buffer offset length] creates a ``proxy''. The returned
byte array share the data of [buffer] but with different
bounds. *)
val extract : t -> int -> int -> t
(** [extract buffer offset length] creates a new byte array of
length [length] and copy the [length] bytes of [buffer] at
[offset] into it. *)
val copy : t -> t
(** [copy buffer] creates a copy of the given byte array. *)
(** {2 Filling} *)
val fill : t -> int -> int -> char -> unit
(** [fill buffer offset length value] puts [value] in all [length]
bytes of [buffer] starting at offset [offset]. *)
external unsafe_fill : t -> int -> int -> char -> unit = "lwt_unix_fill_bytes" "noalloc"
[@@ocaml.warning "-3"]
(** Same as {!fill} but without bounds checking. *)
(** {2 IOs} *)
(** The following functions behave similarly to the ones in {!Lwt_unix}, except
they use byte arrays instead of [Bytes.t], and they never perform extra copies
of the data. *)
val read : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t
val write : Lwt_unix.file_descr -> t -> int -> int -> int Lwt.t
val recv : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t
(** Not implemented on Windows. *)
val send : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> int Lwt.t
(** Not implemented on Windows. *)
val recvfrom : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> (int * Unix.sockaddr) Lwt.t
(** Not implemented on Windows. *)
val sendto : Lwt_unix.file_descr -> t -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int Lwt.t
(** Not implemented on Windows. *)
type io_vector = {
iov_buffer : t;
iov_offset : int;
iov_length : int;
}
val io_vector : buffer : t -> offset : int -> length : int -> io_vector
val recv_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> (int * Unix.file_descr list) Lwt.t
[@@ocaml.deprecated " Use Lwt_unix.Versioned.recv_msg_2."]
(** Not implemented on Windows.
@deprecated Use {!Lwt_unix.Versioned.recv_msg_2}. *)
val send_msg : socket : Lwt_unix.file_descr -> io_vectors : io_vector list -> fds : Unix.file_descr list -> int Lwt.t
[@@ocaml.deprecated " Use Lwt_unix.Versioned.send_msg_2."]
(** Not implemented on Windows.
@deprecated Use {!Lwt_unix.Versioned.send_msg_2}. *)
(** {2 Memory mapped files} *)
val map_file : fd : Unix.file_descr -> ?pos : int64 -> shared : bool -> ?size : int -> unit -> t
(** [map_file ~fd ?pos ~shared ?size ()] maps the file descriptor
[fd] to an array of bytes. *)
external mapped : t -> bool = "lwt_unix_mapped" "noalloc"
[@@ocaml.warning "-3"]
(** [mapped buffer] returns [true] iff [buffer] is a memory mapped
file. *)
(** Type of advise that can be sent to the kernel by the program. See
the manual madvise(2) for a description of each. *)
type advice =
| MADV_NORMAL
| MADV_RANDOM
| MADV_SEQUENTIAL
| MADV_WILLNEED
| MADV_DONTNEED
| MADV_MERGEABLE
| MADV_UNMERGEABLE
| MADV_HUGEPAGE
| MADV_NOHUGEPAGE
val madvise : t -> int -> int -> advice -> unit
(** [madvise buffer pos len advice] advises the kernel how the
program will use the memory mapped file between [pos] and
[pos + len].
This call is not available on windows. *)
val page_size : int
(** Size of pages. *)
val mincore : t -> int -> bool array -> unit
(** [mincore buffer offset states] tests whether the given pages are
in the system memory (the RAM). The [offset] argument must be a
multiple of {!page_size}. [states] is used to store the result;
each cases is [true] if the corresponding page is in RAM and
[false] otherwise.
This call is not available on windows and cygwin. *)
val wait_mincore : t -> int -> unit Lwt.t
(** [wait_mincore buffer offset] waits until the page containing the
byte at offset [offset] is in RAM.
This functions is not available on windows and cygwin. *)

42
unikernel/duniverse/lwt/src/unix/lwt_config.h Normal file
View file

@ -0,0 +1,42 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#ifndef _LWT_CONFIG_H_
#define _LWT_CONFIG_H_
#include "lwt_features.h"
#if defined(HAVE_GET_CREDENTIALS_LINUX) || \
defined(HAVE_GET_CREDENTIALS_NETBSD) || \
defined(HAVE_GET_CREDENTIALS_OPENBSD) || \
defined(HAVE_GET_CREDENTIALS_FREEBSD) || \
defined(HAVE_GETPEEREID)
#define HAVE_GET_CREDENTIALS
#endif
#if defined(HAVE_ST_MTIM_TV_NSEC)
#define NANOSEC(buf, field) buf->st_##field##tim.tv_nsec
#elif defined(HAVE_ST_MTIMESPEC_TV_NSEC)
#define NANOSEC(buf, field) buf->st_##field##timespec.tv_nsec
#elif defined(HAVE_ST_MTIMENSEC)
#define NANOSEC(buf, field) buf->st_##field##timensec
#else
#define NANOSEC(buf, field) 0.0
#endif
#include <caml/version.h>
#if OCAML_VERSION < 50000
#define CAML_NAME_SPACE
#endif
#if OCAML_VERSION < 41200
#define Val_none Val_int(0)
#define Some_val(v) Field(v, 0)
#define Tag_some 0
#define Is_none(v) ((v) == Val_none)
#define Is_some(v) Is_block(v)
#endif
#endif // #ifndef _LWT_CONFIG_H_

13
unikernel/duniverse/lwt/src/unix/lwt_config.ml Normal file
View file

@ -0,0 +1,13 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
include Lwt_features
let _HAVE_GET_CREDENTIALS =
_HAVE_GET_CREDENTIALS_LINUX ||
_HAVE_GET_CREDENTIALS_NETBSD ||
_HAVE_GET_CREDENTIALS_OPENBSD ||
_HAVE_GET_CREDENTIALS_FREEBSD ||
_HAVE_GETPEEREID

447
unikernel/duniverse/lwt/src/unix/lwt_engine.ml Normal file
View file

@ -0,0 +1,447 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it.
However, it is still used internally by Lwt. So, briefly disable warning 3
("deprecated"), and create a local, non-deprecated alias for
[Lwt_sequence] that can be referred to by the rest of the code in this
module without triggering any more warnings. *)
module Lwt_sequence = Lwt_sequence
(* +-----------------------------------------------------------------+
| Events |
+-----------------------------------------------------------------+ *)
type _event = {
stop : unit Lazy.t;
(* The stop method of the event. *)
node : Obj.t Lwt_sequence.node;
(* The node in the sequence of registered events. *)
}
type event = _event ref
external cast_node : 'a Lwt_sequence.node -> Obj.t Lwt_sequence.node = "%identity"
let stop_event ev =
let ev = !ev in
Lwt_sequence.remove ev.node;
Lazy.force ev.stop
let _fake_event = {
stop = lazy ();
node = Lwt_sequence.add_l (Obj.repr ()) (Lwt_sequence.create ());
}
let fake_event = ref _fake_event
(* +-----------------------------------------------------------------+
| Engines |
+-----------------------------------------------------------------+ *)
class virtual abstract = object(self)
method virtual iter : bool -> unit
method virtual private cleanup : unit
method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t
val readables = Lwt_sequence.create ()
(* Sequence of callbacks waiting for a file descriptor to become
readable. *)
val writables = Lwt_sequence.create ()
(* Sequence of callbacks waiting for a file descriptor to become
writable. *)
val timers = Lwt_sequence.create ()
(* Sequence of timers. *)
method destroy =
Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) readables;
Lwt_sequence.iter_l (fun (_fd, _f, _g, ev) -> stop_event ev) writables;
Lwt_sequence.iter_l (fun (_delay, _repeat, _f, _g, ev) -> stop_event ev)
timers;
self#cleanup
method transfer (engine : abstract) =
Lwt_sequence.iter_l (fun (fd, f, _g, ev) ->
stop_event ev; ev := !(engine#on_readable fd f)) readables;
Lwt_sequence.iter_l (fun (fd, f, _g, ev) ->
stop_event ev; ev := !(engine#on_writable fd f)) writables;
Lwt_sequence.iter_l (fun (delay, repeat, f, _g, ev) ->
stop_event ev; ev := !(engine#on_timer delay repeat f)) timers
method fake_io fd =
Lwt_sequence.iter_l (fun (fd', _f, g, _stop) ->
if fd = fd' then g ()) readables;
Lwt_sequence.iter_l (fun (fd', _f, g, _stop) ->
if fd = fd' then g ()) writables
method on_readable fd f =
let ev = ref _fake_event in
let g () = f ev in
let stop = self#register_readable fd g in
ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) readables) };
ev
method on_writable fd f =
let ev = ref _fake_event in
let g () = f ev in
let stop = self#register_writable fd g in
ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (fd, f, g, ev) writables) } ;
ev
method on_timer delay repeat f =
let ev = ref _fake_event in
let g () = f ev in
let stop = self#register_timer delay repeat g in
ev := { stop = stop; node = cast_node (Lwt_sequence.add_r (delay, repeat, f, g, ev) timers) };
ev
method readable_count = Lwt_sequence.length readables
method writable_count = Lwt_sequence.length writables
method timer_count = Lwt_sequence.length timers
method fork = ()
method forwards_signal (_signum:int) = false
end
class type t = object
inherit abstract
method iter : bool -> unit
method private cleanup : unit
method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t
end
(* +-----------------------------------------------------------------+
| The libev engine |
+-----------------------------------------------------------------+ *)
type ev_loop
type ev_io
type ev_timer
module Ev_backend =
struct
type t =
| EV_DEFAULT
| EV_SELECT
| EV_POLL
| EV_EPOLL
| EV_KQUEUE
| EV_DEVPOLL
| EV_PORT
let default = EV_DEFAULT
let select = EV_SELECT
let poll = EV_POLL
let epoll = EV_EPOLL
let kqueue = EV_KQUEUE
let devpoll = EV_DEVPOLL
let port = EV_PORT
let equal = ( = )
let name = function
| EV_DEFAULT -> "EV_DEFAULT"
| EV_SELECT -> "EV_SELECT"
| EV_POLL -> "EV_POLL"
| EV_EPOLL -> "EV_EPOLL"
| EV_KQUEUE -> "EV_KQUEUE"
| EV_DEVPOLL -> "EV_DEVPOLL"
| EV_PORT -> "EV_PORT"
let pp fmt t = Format.pp_print_string fmt (name t)
end
external ev_init : Ev_backend.t -> ev_loop = "lwt_libev_init"
external ev_backend : ev_loop -> Ev_backend.t = "lwt_libev_backend"
external ev_stop : ev_loop -> unit = "lwt_libev_stop"
external ev_loop : ev_loop -> bool -> unit = "lwt_libev_loop"
external ev_unloop : ev_loop -> unit = "lwt_libev_unloop"
external ev_readable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_readable_init"
external ev_writable_init : ev_loop -> Unix.file_descr -> (unit -> unit) -> ev_io = "lwt_libev_writable_init"
external ev_io_stop : ev_loop -> ev_io -> unit = "lwt_libev_io_stop"
external ev_timer_init : ev_loop -> float -> bool -> (unit -> unit) -> ev_timer = "lwt_libev_timer_init"
external ev_timer_stop : ev_loop -> ev_timer -> unit = "lwt_libev_timer_stop"
class libev ?(backend=Ev_backend.default) () = object
inherit abstract
val loop = ev_init backend
method loop = loop
method backend = ev_backend loop
method private cleanup = ev_stop loop
method iter block =
try
ev_loop loop block
with exn ->
ev_unloop loop;
raise exn
method private register_readable fd f =
let ev = ev_readable_init loop fd f in
lazy(ev_io_stop loop ev)
method private register_writable fd f =
let ev = ev_writable_init loop fd f in
lazy(ev_io_stop loop ev)
method private register_timer delay repeat f =
let ev = ev_timer_init loop delay repeat f in
lazy(ev_timer_stop loop ev)
end
class libev_deprecated = libev ()
(* +-----------------------------------------------------------------+
| Select/poll based engines |
+-----------------------------------------------------------------+ *)
(* Type of a sleeper for the select engine. *)
type sleeper = {
mutable time : float;
(* The time at which the sleeper should be wakeup. *)
mutable stopped : bool;
(* [true] iff the event has been stopped. *)
action : unit -> unit;
(* The action for the sleeper. *)
}
module Sleep_queue =
Lwt_pqueue.Make(struct
type t = sleeper
let compare {time = t1; _} {time = t2; _} = compare t1 t2
end)
[@ocaml.warning "-3"]
module Fd_map = Map.Make(struct type t = Unix.file_descr let compare = compare end)
let rec restart_actions sleep_queue now =
match Sleep_queue.lookup_min sleep_queue with
| Some{ stopped = true; _ } ->
restart_actions (Sleep_queue.remove_min sleep_queue) now
| Some{ time = time; action = action; _ } when time <= now ->
(* We have to remove the sleeper to the queue before performing
the action. The action can change the sleeper's time, and this
might break the priority queue invariant if the sleeper is
still in the queue. *)
let q = Sleep_queue.remove_min sleep_queue in
action ();
restart_actions q now
| _ ->
sleep_queue
let rec get_next_timeout sleep_queue =
match Sleep_queue.lookup_min sleep_queue with
| Some{ stopped = true; _ } ->
get_next_timeout (Sleep_queue.remove_min sleep_queue)
| Some{ time = time; _ } ->
max 0. (time -. Unix.gettimeofday ())
| None ->
-1.
let bad_fd fd =
try
let _ = Unix.fstat fd in
false
with Unix.Unix_error (_, _, _) ->
true
let invoke_actions fd map =
match Fd_map.find fd map with
| exception Not_found -> ()
| actions -> Lwt_sequence.iter_l (fun f -> f ()) actions
class virtual select_or_poll_based = object
inherit abstract
val mutable sleep_queue = Sleep_queue.empty
(* Threads waiting for a timeout to expire. *)
val mutable new_sleeps = []
(* Sleepers added since the last iteration of the main loop:
They are not added immediately to the main sleep queue in order
to prevent them from being wakeup immediately. *)
val mutable wait_readable = Fd_map.empty
(* Sequences of actions waiting for file descriptors to become
readable. *)
val mutable wait_writable = Fd_map.empty
(* Sequences of actions waiting for file descriptors to become
writable. *)
method private cleanup = ()
method private register_timer delay repeat f =
if repeat then begin
let rec sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = g }
and g () =
sleeper.time <- Unix.gettimeofday () +. delay;
new_sleeps <- sleeper :: new_sleeps;
f ()
in
new_sleeps <- sleeper :: new_sleeps;
lazy(sleeper.stopped <- true)
end else begin
let sleeper = { time = Unix.gettimeofday () +. delay; stopped = false; action = f } in
new_sleeps <- sleeper :: new_sleeps;
lazy(sleeper.stopped <- true)
end
method private register_readable fd f =
let actions =
try
Fd_map.find fd wait_readable
with Not_found ->
let actions = Lwt_sequence.create () in
wait_readable <- Fd_map.add fd actions wait_readable;
actions
in
let node = Lwt_sequence.add_l f actions in
lazy(Lwt_sequence.remove node;
if Lwt_sequence.is_empty actions then wait_readable <- Fd_map.remove fd wait_readable)
method private register_writable fd f =
let actions =
try
Fd_map.find fd wait_writable
with Not_found ->
let actions = Lwt_sequence.create () in
wait_writable <- Fd_map.add fd actions wait_writable;
actions
in
let node = Lwt_sequence.add_l f actions in
lazy(Lwt_sequence.remove node;
if Lwt_sequence.is_empty actions then wait_writable <- Fd_map.remove fd wait_writable)
end
class virtual select_based = object(self)
inherit select_or_poll_based
method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list
method iter block =
(* Transfer all sleepers added since the last iteration to the
main sleep queue: *)
sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps;
new_sleeps <- [];
(* Collect file descriptors. *)
let fds_r = Fd_map.fold (fun fd _ l -> fd :: l) wait_readable [] in
let fds_w = Fd_map.fold (fun fd _ l -> fd :: l) wait_writable [] in
(* Compute the timeout. *)
let timeout = if block then get_next_timeout sleep_queue else 0. in
(* Do the blocking call *)
let fds_r, fds_w =
try
self#select fds_r fds_w timeout
with
| Unix.Unix_error (Unix.EINTR, _, _) ->
([], [])
| Unix.Unix_error (Unix.EBADF, _, _) ->
(* Keeps only bad file descriptors. Actions registered on
them have to handle the error: *)
(List.filter bad_fd fds_r,
List.filter bad_fd fds_w)
in
(* Restart threads waiting for a timeout: *)
sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ());
(* Restart threads waiting on a file descriptors: *)
List.iter (fun fd -> invoke_actions fd wait_readable) fds_r;
List.iter (fun fd -> invoke_actions fd wait_writable) fds_w
end
class virtual poll_based = object(self)
inherit select_or_poll_based
method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list
method iter block =
(* Transfer all sleepers added since the last iteration to the
main sleep queue: *)
sleep_queue <- List.fold_left (fun q e -> Sleep_queue.add e q) sleep_queue new_sleeps;
new_sleeps <- [];
(* Collect file descriptors. *)
let fds = [] in
let fds = Fd_map.fold (fun fd _ l -> (fd, true, false) :: l) wait_readable fds in
let fds = Fd_map.fold (fun fd _ l -> (fd, false, true) :: l) wait_writable fds in
(* Compute the timeout. *)
let timeout = if block then get_next_timeout sleep_queue else 0. in
(* Do the blocking call *)
let fds =
try
self#poll fds timeout
with
| Unix.Unix_error (Unix.EINTR, _, _) ->
[]
| Unix.Unix_error (Unix.EBADF, _, _) ->
(* Keeps only bad file descriptors. Actions registered on
them have to handle the error: *)
List.filter (fun (fd, _, _) -> bad_fd fd) fds
in
(* Restart threads waiting for a timeout: *)
sleep_queue <- restart_actions sleep_queue (Unix.gettimeofday ());
(* Restart threads waiting on a file descriptors: *)
List.iter
(fun (fd, readable, writable) ->
if readable then invoke_actions fd wait_readable;
if writable then invoke_actions fd wait_writable)
fds
end
class select = object
inherit select_based
method private select fds_r fds_w timeout =
let fds_r, fds_w, _ = Unix.select fds_r fds_w [] timeout in
(fds_r, fds_w)
end
(* +-----------------------------------------------------------------+
| The current engine |
+-----------------------------------------------------------------+ *)
let current =
if Lwt_config._HAVE_LIBEV && Lwt_config.libev_default then
ref (new libev () :> t)
else
ref (new select :> t)
let get () =
!current
let set ?(transfer=true) ?(destroy=true) engine =
if transfer then !current#transfer (engine : #t :> abstract);
if destroy then !current#destroy;
current := (engine : #t :> t)
let iter block = !current#iter block
let on_readable fd f = !current#on_readable fd f
let on_writable fd f = !current#on_writable fd f
let on_timer delay repeat f = !current#on_timer delay repeat f
let fake_io fd = !current#fake_io fd
let readable_count () = !current#readable_count
let writable_count () = !current#writable_count
let timer_count () = !current#timer_count
let fork () = !current#fork
let forwards_signal n = !current#forwards_signal n
module Versioned =
struct
class libev_1 = libev_deprecated
class libev_2 = libev
end

240
unikernel/duniverse/lwt/src/unix/lwt_engine.mli Normal file
View file

@ -0,0 +1,240 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Lwt unix main loop engine *)
(** {2 Events} *)
type event
(** Type of events. An event represent a callback registered to be
called when some event occurs. *)
val stop_event : event -> unit
(** [stop_event event] stops the given event. *)
val fake_event : event
(** Event which does nothing when stopped. *)
(** {2 Event loop functions} *)
val iter : bool -> unit
(** [iter block] performs one iteration of the main loop. If [block]
is [true] the function must block until one event becomes
available, otherwise it should just check for available events
and return immediately. *)
val on_readable : Unix.file_descr -> (event -> unit) -> event
(** [on_readable fd f] calls [f] each time [fd] becomes readable. *)
val on_writable : Unix.file_descr -> (event -> unit) -> event
(** [on_readable fd f] calls [f] each time [fd] becomes writable. *)
val on_timer : float -> bool -> (event -> unit) -> event
(** [on_timer delay repeat f] calls [f] one time after [delay]
seconds. If [repeat] is [true] then [f] is called each [delay]
seconds, otherwise it is called only one time. *)
val readable_count : unit -> int
(** Returns the number of events waiting for a file descriptor to
become readable. *)
val writable_count : unit -> int
(** Returns the number of events waiting for a file descriptor to
become writable. *)
val timer_count : unit -> int
(** Returns the number of registered timers. *)
val fake_io : Unix.file_descr -> unit
(** Simulates activity on the given file descriptor. *)
val fork : unit -> unit
(** Called internally by Lwt_unix.fork to make sure we don't get strange behaviour *)
val forwards_signal : int -> bool
(** [forwards_signal signum] is [true] if the engine will call {!Lwt_unix.handle_signal}
when signal [signum] occurs. In this case, Lwt will not install its own signal handler.
Normally, this just returns [false], but when Lwt is used in combination
with other IO libraries, this allows sharing e.g. the SIGCHLD handler. *)
(** {2 Engines} *)
(** An engine represents a set of functions used to register different
kinds of callbacks for different kinds of events. *)
(** Abstract class for engines. *)
class virtual abstract : object
method destroy : unit
(** Destroy the engine, remove all its events and free its
associated resources. *)
method transfer : abstract -> unit
(** [transfer engine] moves all events from the current engine to
[engine]. Note that timers are reset in the destination
engine, i.e. if a timer with a delay of 2 seconds was
registered 1 second ago it will occur in 2 seconds in the
destination engine. *)
(** {2 Event loop methods} *)
method virtual iter : bool -> unit
method fork : unit
method on_readable : Unix.file_descr -> (event -> unit) -> event
method on_writable : Unix.file_descr -> (event -> unit) -> event
method on_timer : float -> bool -> (event -> unit) -> event
method fake_io : Unix.file_descr -> unit
method readable_count : int
method writable_count : int
method timer_count : int
method forwards_signal : int -> bool
(** {2 Backend methods} *)
(** Notes:
- the callback passed to register methods is of type [unit -> unit]
and not [event -> unit]
- register methods return a lazy value which unregisters the
event when forced
*)
method virtual private cleanup : unit
(** Cleanup resources associated with the engine. *)
method virtual private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method virtual private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method virtual private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t
end
(** Type of engines. *)
class type t = object
inherit abstract
method iter : bool -> unit
method private cleanup : unit
method private register_readable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method private register_writable : Unix.file_descr -> (unit -> unit) -> unit Lazy.t
method private register_timer : float -> bool -> (unit -> unit) -> unit Lazy.t
end
(** {2 Predefined engines} *)
type ev_loop
module Ev_backend :
sig
type t
val default : t
val select : t
val poll : t
val epoll : t
val kqueue : t
val devpoll : t
val port : t
val equal : t -> t -> bool
val pp : Format.formatter -> t -> unit
end
(** Type of libev loops. *)
(** Engine based on libev. If not compiled with libev support, the
creation of the class will raise {!Lwt_sys.Not_available}. *)
class libev : ?backend:Ev_backend.t -> unit -> object
inherit t
method backend : Ev_backend.t
(** The backend picked by libev. *)
val loop : ev_loop
(** The libev loop used for this engine. *)
method loop : ev_loop
(** Returns [loop]. *)
end
(** Engine based on {!Unix.select}. *)
class select : t
(** Abstract class for engines based on a select-like function. *)
class virtual select_based : object
inherit t
method private virtual select : Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list
(** [select fds_r fds_w timeout] waits for either:
- one of the file descriptor of [fds_r] to become readable
- one of the file descriptor of [fds_w] to become writable
- timeout to expire
and returns the list of readable file descriptor and the list
of writable file descriptors. *)
end
(** Abstract class for engines based on a poll-like function. *)
class virtual poll_based : object
inherit t
method private virtual poll : (Unix.file_descr * bool * bool) list -> float -> (Unix.file_descr * bool * bool) list
(** [poll fds tiomeout], where [fds] is a list of tuples of the
form [(fd, check_readable, check_writable)], waits for either:
- one of the file descriptor with [check_readable] set to
[true] to become readable
- one of the file descriptor with [check_writable] set to
[true] to become writable
- timeout to expire
and returns the list of file descriptors with their readable
and writable status. *)
end
(** {2 The current engine} *)
val get : unit -> t
(** [get ()] returns the engine currently in use. *)
val set : ?transfer : bool -> ?destroy : bool -> #t -> unit
(** [set ?transfer ?destroy engine] replaces the current engine by
the given one.
If [transfer] is [true] (the default) all events from the
current engine are transferred to the new one.
If [destroy] is [true] (the default) then the current engine is
destroyed before being replaced. *)
module Versioned :
sig
class libev_1 : object
inherit t
val loop : ev_loop
method backend : Ev_backend.t
method loop : ev_loop
end
[@@ocaml.deprecated
" Deprecated in favor of Lwt_engine.libev. See
https://github.com/ocsigen/lwt/pull/269"]
(** Old version of {!Lwt_engine.libev}. The current {!Lwt_engine.libev} allows
selecting the libev back end.
@deprecated Use {!Lwt_engine.libev}.
@since 2.7.0 *)
class libev_2 : ?backend:Ev_backend.t -> unit -> object
inherit t
val loop : ev_loop
method backend : Ev_backend.t
method loop : ev_loop
end
[@@ocaml.deprecated
" In Lwt >= 3.0.0, this is an alias for Lwt_engine.libev."]
(** Since Lwt 3.0.0, this is just an alias for {!Lwt_engine.libev}.
@deprecated Use {!Lwt_engine.libev}.
@since 2.7.0 *)
end

82
unikernel/duniverse/lwt/src/unix/lwt_fmt.ml Normal file
View file

@ -0,0 +1,82 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
open Lwt.Infix
type formatter = {
commit : unit -> unit Lwt.t ;
fmt : Format.formatter ;
}
let write_pending ppft = ppft.commit ()
let flush ppft = Format.pp_print_flush ppft.fmt () ; ppft.commit ()
let make_formatter ~commit ~fmt () = { commit ; fmt }
let get_formatter x = x.fmt
(** Stream formatter *)
type order =
| String of string * int * int
| Flush
let make_stream () =
let stream, push = Lwt_stream.create () in
let out_string s i j =
push @@ Some (String (s, i, j))
and flush () =
push @@ Some Flush
in
let fmt = Format.make_formatter out_string flush in
(* Not sure about that one *)
Gc.finalise (fun _ -> push None) fmt ;
let commit () = Lwt.return_unit in
stream, make_formatter ~commit ~fmt ()
(** Channel formatter *)
let write_order oc = function
| String (s, i, j) ->
Lwt_io.write_from_string_exactly oc s i j
| Flush ->
Lwt_io.flush oc
let rec write_orders oc queue =
if Queue.is_empty queue then
Lwt.return_unit
else
let o = Queue.pop queue in
write_order oc o >>= fun () ->
write_orders oc queue
let of_channel oc =
let q = Queue.create () in
let out_string s i j =
Queue.push (String (s, i, j)) q
and flush () =
Queue.push Flush q
in
let fmt = Format.make_formatter out_string flush in
let commit () = write_orders oc q in
make_formatter ~commit ~fmt ()
(** Printing functions *)
let kfprintf k ppft fmt =
Format.kfprintf (fun _ppf -> k ppft @@ ppft.commit ()) ppft.fmt fmt
let ikfprintf k ppft fmt =
Format.ikfprintf (fun _ppf -> k ppft @@ Lwt.return_unit) ppft.fmt fmt
let fprintf ppft fmt =
kfprintf (fun _ t -> t) ppft fmt
let ifprintf ppft fmt =
ikfprintf (fun _ t -> t) ppft fmt
let stdout = of_channel Lwt_io.stdout
let stderr = of_channel Lwt_io.stderr
let printf fmt = fprintf stdout fmt
let eprintf fmt = fprintf stderr fmt

93
unikernel/duniverse/lwt/src/unix/lwt_fmt.mli Normal file
View file

@ -0,0 +1,93 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Format API for Lwt-powered IOs
@since 4.1.0 *)
(** This module bridges the gap between {!Stdlib.Format} and {!Lwt}.
Although it is not required, it is recommended to use this module
with the {{:https://erratique.ch/software/fmt} [Fmt]} library.
Compared to regular formatting function, the main difference is that
printing statements will now return promises instead of blocking.
*)
val printf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
(** Returns a promise that prints on the standard output.
Similar to {!Stdlib.Format.printf}. *)
val eprintf : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
(** Returns a promise that prints on the standard error.
Similar to {!Stdlib.Format.eprintf}. *)
(** {1 Formatters} *)
type formatter
(** Lwt enabled formatters *)
type order =
| String of string * int * int (** [String (s, off, len)] indicate the output of [s] at offset [off] and length [len]. *)
| Flush (** Flush operation *)
val make_stream : unit -> order Lwt_stream.t * formatter
(** [make_stream ()] returns a formatter and a stream of all the writing
order given on that stream.
*)
val of_channel : Lwt_io.output_channel -> formatter
(** [of_channel oc] creates a formatter that writes to the channel [oc]. *)
val stdout : formatter
(** Formatter printing on {!Lwt_io.stdout}. *)
val stderr : formatter
(** Formatter printing on {!Lwt_io.stdout}. *)
val make_formatter :
commit:(unit -> unit Lwt.t) -> fmt:Format.formatter -> unit -> formatter
(** [make_formatter ~commit ~fmt] creates a new lwt formatter based on the
{!Stdlib.Format.formatter} [fmt]. The [commit] function will be called by the
printing functions to update the underlying channel.
*)
val get_formatter : formatter -> Format.formatter
(** [get_formatter fmt] returns the underlying {!Stdlib.Format.formatter}.
To access the underlying formatter during printing, it
is recommended to use [%t] and [%a].
*)
(** {2 Printing} *)
val fprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val kfprintf :
(formatter -> unit Lwt.t -> 'a) ->
formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b
val ifprintf : formatter -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
val ikfprintf :
(formatter -> unit Lwt.t -> 'a) ->
formatter -> ('b, Format.formatter, unit, 'a) format4 -> 'b
val flush : formatter -> unit Lwt.t
(** [flush fmt] flushes the formatter (as with {!Stdlib.Format.pp_print_flush})
and executes all the printing action on the underlying channel.
*)
(** Low level functions *)
val write_order : Lwt_io.output_channel -> order -> unit Lwt.t
(** [write_order oc o] applies the order [o] on the channel [oc]. *)
val write_pending : formatter -> unit Lwt.t
(** Write all the pending orders of a formatter.
Warning: This function flush neither the internal format queues
nor the underlying channel and is intended for low level use only.
You should probably use {!flush} instead.
*)

90
unikernel/duniverse/lwt/src/unix/lwt_gc.ml Normal file
View file

@ -0,0 +1,90 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it.
However, it is still used internally by Lwt. So, briefly disable warning 3
("deprecated"), and create a local, non-deprecated alias for
[Lwt_sequence] that can be referred to by the rest of the code in this
module without triggering any more warnings. *)
module Lwt_sequence = Lwt_sequence
let ensure_termination t =
if Lwt.state t = Lwt.Sleep then begin
let hook =
Lwt_sequence.add_l (fun _ -> t) Lwt_main.exit_hooks [@ocaml.warning "-3"]
in
(* Remove the hook when t has terminated *)
ignore (
Lwt.finalize
(fun () -> t)
(fun () -> Lwt_sequence.remove hook; Lwt.return_unit))
end
let finaliser f =
(* In order not to create a reference to the value in the
notification callback, we use an initially unset option cell
which will be filled when the finaliser is called. *)
let opt = ref None in
let id =
Lwt_unix.make_notification
~once:true
(fun () ->
match !opt with
| None ->
assert false
| Some x ->
opt := None;
ensure_termination (f x))
in
(* The real finaliser: fill the cell and send a notification. *)
(fun x ->
opt := Some x;
Lwt_unix.send_notification id)
let finalise f x =
Gc.finalise (finaliser f) x
(* Exit hook for a finalise_or_exit *)
let foe_exit f called weak () =
match Weak.get weak 0 with
| None ->
(* The value has been garbage collected, normally this point
is never reached *)
Lwt.return_unit
| Some x ->
(* Just to avoid double finalisation *)
Weak.set weak 0 None;
if !called then
Lwt.return_unit
else begin
called := true;
f x
end
(* Finaliser for a finalise_or_exit *)
let foe_finaliser f called hook =
finaliser
(fun x ->
(* Remove the exit hook, it is not needed anymore. *)
Lwt_sequence.remove hook;
(* Call the real finaliser. *)
if !called then
Lwt.return_unit
else begin
called := true;
f x
end)
let finalise_or_exit f x =
(* Create a weak pointer, so the exit-hook does not keep a reference
to [x]. *)
let weak = Weak.create 1 in
Weak.set weak 0 (Some x);
let called = ref false in
let hook =
Lwt_sequence.add_l (foe_exit f called weak) Lwt_main.exit_hooks
[@ocaml.warning "-3"]
in
Gc.finalise (foe_finaliser f called hook) x

22
unikernel/duniverse/lwt/src/unix/lwt_gc.mli Normal file
View file

@ -0,0 +1,22 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Interaction with the garbage collector *)
(** This module offers a convenient way to add a finaliser launching a
thread to a value, without having to use [Lwt_unix.run] in the
finaliser. *)
val finalise : ('a -> unit Lwt.t) -> 'a -> unit
(** [finalise f x] ensures [f x] is evaluated after [x] has been
garbage collected. If [f x] yields, then Lwt will wait for its
termination at the end of the program.
Note that [f x] is not called at garbage collection time, but
later in the main loop. *)
val finalise_or_exit : ('a -> unit Lwt.t) -> 'a -> unit
(** [finalise_or_exit f x] call [f x] when [x] is garbage collected
or (exclusively) when the program exits. *)

1870
unikernel/duniverse/lwt/src/unix/lwt_io.ml Normal file
View file

File diff suppressed because it is too large Load diff

859
unikernel/duniverse/lwt/src/unix/lwt_io.mli Normal file
View file

@ -0,0 +1,859 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Buffered byte channels *)
(** A {b channel} is a high-level object for performing input/output
(IO). It allows to read/write from/to the outside world in an
efficient way, by minimising the number of system calls.
An {b output channel} is used to send data and an {b input
channel} is used to receive data.
If you are familiar with buffered channels you may be familiar too
with the {b flush} operation. Note that byte channels of this
module are automatically flushed when there is nothing else to do
(i.e. before the program becomes idle), so this means that you no
longer have to write:
{[
eprintf "log message\n";
flush stderr;
]}
to have your messages displayed.
Note about errors: input functions of this module raise
[End_of_file] when the end-of-file is reached (i.e. when the read
function returns [0]). Other exceptions are ones caused by the
backend read/write functions, such as {!Unix.Unix_error}.
*)
exception Channel_closed of string
(** Exception raised when a channel is closed. The parameter is a
description of the channel. *)
(** {2 Types} *)
type 'mode channel
(** Type of buffered byte channels *)
type input
(** Input mode *)
type output
(** Output mode *)
(** Channel mode *)
type 'a mode =
| Input : input mode
| Output : output mode
val input : input mode
(** [input] input mode representation *)
val output : output mode
(** [output] output mode representation *)
type input_channel = input channel
(** Type of input channels *)
type output_channel = output channel
(** Type of output channels *)
val mode : 'a channel -> 'a mode
(** [mode ch] returns the mode of a channel *)
(** {2 Well-known instances} *)
val stdin : input_channel
(** The standard input, it reads data from {!Lwt_unix.stdin} *)
val stdout : output_channel
(** The standard output, it writes data to {!Lwt_unix.stdout} *)
val stderr : output_channel
(** The standard output for error messages, it writes data to
{!Lwt_unix.stderr} *)
val zero : input_channel
(** Inputs which returns always ['\x00'] *)
val null : output_channel
(** Output which drops everything *)
(** {2 Channels creation/manipulation} *)
val pipe : ?cloexec : bool ->
?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t -> unit ->
input_channel * output_channel
(** [pipe ?cloexec ?in_buffer ?out_buffer ()] creates a pipe using
{!Lwt_unix.pipe} and makes two channels from the two returned file
descriptors *)
val make :
?buffer : Lwt_bytes.t ->
?close : (unit -> unit Lwt.t) ->
?seek : (int64 -> Unix.seek_command -> int64 Lwt.t) ->
mode : 'mode mode ->
(Lwt_bytes.t -> int -> int -> int Lwt.t) -> 'mode channel
(** [make ?buffer ?close ~mode perform_io] is the
main function for creating new channels.
@param buffer user-supplied buffer. When this argument is
present, its value will be used as the buffer for the created
channel. The size of buffer must conform to the limitations
described in {!set_default_buffer_size}. When this argument is
not present, a new internal buffer of default size will be
allocated for this channel.
Warning: do not use the same buffer for simultaneous work with more
than one channel.
There are other functions in this module that take a [buffer]
argument, sharing the same semantics.
@param close close function of the channel. It defaults to
[Lwt.return]
@param seek same meaning as {!Unix.lseek}
@param mode either {!input} or {!output}
@param perform_io is the read or write function. It is called
when more input is needed or when the buffer need to be
flushed. *)
val of_bytes : mode : 'mode mode -> Lwt_bytes.t -> 'mode channel
(** Create a channel from a byte array. Reading/writing is done
directly on the provided array. *)
val of_fd : ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) ->
mode : 'mode mode -> Lwt_unix.file_descr -> 'mode channel
(** [of_fd ?buffer ?close ~mode fd] creates a channel from a
file descriptor.
@param close defaults to closing the file descriptor. *)
val of_unix_fd : ?buffer : Lwt_bytes.t -> ?close : (unit -> unit Lwt.t) ->
mode : 'mode mode -> Unix.file_descr -> 'mode channel
(** [of_unix_fd ?buffer ?close ~mode fd] is a short-hand for:
[of_fd ?buffer ?close (Lwt_unix.of_unix_file_descr fd)] *)
val close : 'a channel -> unit Lwt.t
(** [close ch] closes the given channel. If [ch] is an output
channel, it performs all pending actions, flushes it and closes
it. If [ch] is an input channel, it just closes it immediately.
[close] returns the result of the close function of the
channel. Multiple calls to [close] will return exactly the same
value.
Note: you cannot use [close] on channels obtained with
{!atomic}. *)
val abort : 'a channel -> unit Lwt.t
(** [abort ch] abort current operations and close the channel
immediately. *)
val atomic : ('a channel -> 'b Lwt.t) -> ('a channel -> 'b Lwt.t)
(** [atomic f] transforms a sequence of io operations into one
single atomic io operation.
Note:
- the channel passed to [f] is invalid after [f] terminates
- [atomic] can be called inside another [atomic] *)
val file_length : string -> int64 Lwt.t
(** Retrieves the length of the file at the given path. If the path refers to a
directory, the returned promise is rejected with
[Unix.(Unix_error (EISDIR, _, _))]. *)
val buffered : 'a channel -> int
(** [buffered oc] returns the number of bytes in the buffer *)
val flush : output_channel -> unit Lwt.t
(** [flush oc] performs all pending writes on [oc] *)
val flush_all : unit -> unit Lwt.t
(** [flush_all ()] flushes all open output channels *)
val buffer_size : 'a channel -> int
(** Returns the size of the internal buffer. *)
val resize_buffer : 'a channel -> int -> unit Lwt.t
(** Resize the internal buffer to the given size *)
val is_busy : 'a channel -> bool
(** [is_busy channel] returns whether the given channel is currently
busy. A channel is busy when there is at least one job using it
that has not yet terminated. *)
val is_closed : 'a channel -> bool
(** [is_closed channel] returns whether the given channel is currently
closed.
@since 4.2.0 *)
(** {2 Random access} *)
val position : 'a channel -> int64
(** [position ch] Returns the current position in the channel. *)
val set_position : 'a channel -> int64 -> unit Lwt.t
(** [set_position ch pos] Sets the position in the output channel. This
does not work if the channel does not support random access. *)
val length : 'a channel -> int64 Lwt.t
(** Returns the length of the channel in bytes *)
(** {2 Reading} *)
(** Note: except for functions dealing with streams ({!read_chars} and
{!read_lines}) all functions are {b atomic}. *)
val read_char : input_channel -> char Lwt.t
(** [read_char ic] reads the next character of [ic].
@raise End_of_file if the end of the file is reached *)
val read_char_opt : input_channel -> char option Lwt.t
(** Same as {!Lwt_io.read_char}, but does not raise [End_of_file] on end of
input *)
val read_chars : input_channel -> char Lwt_stream.t
(** [read_chars ic] returns a stream holding all characters of
[ic] *)
val read_line : input_channel -> string Lwt.t
(** [read_line ic] reads one complete line from [ic] and returns it
without the end of line. End of line is either ["\n"] or
["\r\n"].
If the end of input is reached before reading any character,
[End_of_file] is raised. If it is reached before reading an end
of line but characters have already been read, they are
returned. *)
val read_line_opt : input_channel -> string option Lwt.t
(** Same as {!read_line} but do not raise [End_of_file] on end of
input. *)
val read_lines : input_channel -> string Lwt_stream.t
(** [read_lines ic] returns a stream holding all lines of [ic] *)
val read : ?count : int -> input_channel -> string Lwt.t
(** If [~count] is specified, [read ~count ic] reads at most [~count] bytes from
[ic] in one read operation. Note that fewer than [~count] bytes can be read.
This can happen for multiple reasons, including end of input, or no more
data currently available. Check the size of the resulting string. [read]
resolves with [""] if the input channel is already at the end of input.
If [~count] is not specified, [read ic] reads all bytes until the end of
input. *)
val read_into : input_channel -> bytes -> int -> int -> int Lwt.t
(** [read_into ic buffer offset length] reads up to [length] bytes,
stores them in [buffer] at offset [offset], and returns the
number of bytes read.
Note: [read_into] does not raise [End_of_file], it returns a
length of [0] instead. *)
val read_into_exactly : input_channel -> bytes -> int -> int -> unit Lwt.t
(** [read_into_exactly ic buffer offset length] reads exactly
[length] bytes and stores them in [buffer] at offset [offset].
@raise End_of_file on end of input *)
val read_into_bigstring : input_channel -> Lwt_bytes.t -> int -> int -> int Lwt.t
val read_into_exactly_bigstring : input_channel -> Lwt_bytes.t -> int -> int -> unit Lwt.t
val read_value : input_channel -> 'a Lwt.t
(** [read_value channel] reads a marshaled value from [channel]; it corresponds
to the standard library's {!Stdlib.Marshal.from_channel}. The corresponding
writing function is {!write_value}.
Note that reading marshaled values is {e not}, in general, type-safe. See
the warning in the description of module {!Stdlib.Marshal} for details. The
short version is: if you read a value of one type, such as [string], when a
value of another type, such as [int] has actually been marshaled to
[channel], you may get arbitrary behavior, including segmentation faults,
access violations, security bugs, etc. *)
(** {2 Writing} *)
(** Note: as for reading functions, all functions except
{!write_chars} and {!write_lines} are {b atomic}.
For example if you use {!write_line} in two different threads, the
two operations will be serialized, and lines cannot be mixed.
*)
val write_char : output_channel -> char -> unit Lwt.t
(** [write_char oc char] writes [char] on [oc] *)
val write_chars : output_channel -> char Lwt_stream.t -> unit Lwt.t
(** [write_chars oc chars] writes all characters of [chars] on
[oc] *)
val write : output_channel -> string -> unit Lwt.t
(** [write oc str] writes all characters of [str] on [oc] *)
val write_line : output_channel -> string -> unit Lwt.t
(** [write_line oc str] writes [str] on [oc] followed by a
new-line. *)
val write_lines : output_channel -> string Lwt_stream.t -> unit Lwt.t
(** [write_lines oc lines] writes all lines of [lines] to [oc] *)
val write_from : output_channel -> bytes -> int -> int -> int Lwt.t
(** [write_from oc buffer offset length] writes up to [length] bytes
to [oc], from [buffer] at offset [offset] and returns the number
of bytes actually written *)
val write_from_bigstring : output_channel -> Lwt_bytes.t -> int -> int -> int Lwt.t
val write_from_string : output_channel -> string -> int -> int -> int Lwt.t
(** See {!write}. *)
val write_from_exactly : output_channel -> bytes -> int -> int -> unit Lwt.t
(** [write_from_exactly oc buffer offset length] writes all [length]
bytes from [buffer] at offset [offset] to [oc] *)
val write_from_exactly_bigstring : output_channel -> Lwt_bytes.t -> int -> int -> unit Lwt.t
val write_from_string_exactly :
output_channel -> string -> int -> int -> unit Lwt.t
(** See {!write_from_exactly}. *)
val write_value :
output_channel -> ?flags : Marshal.extern_flags list -> 'a -> unit Lwt.t
(** [write_value channel ?flags v] writes [v] to [channel] using the [Marshal]
module of the standard library. See {!Stdlib.Marshal.to_channel} for an
explanation of [?flags].
The corresponding reading function is {!read_value}. See warnings about type
safety in the description of {!read_value}. *)
(** {2 Printing} *)
(** These functions are basically helpers. Also you may prefer
using the name {!printl} rather than {!write_line} because it is
shorter.
The general name of a printing function is [<prefix>print<suffixes>],
where [<prefix>] is one of:
- ['f'], which means that the function takes as argument a channel
- nothing, which means that the function prints on {!stdout}
- ['e'], which means that the function prints on {!stderr}
and [<suffixes>] is a combination of:
- ['l'] which means that a new-line character is printed after the message
- ['f'] which means that the function takes as argument a {b format} instead
of a string
*)
val fprint : output_channel -> string -> unit Lwt.t
val fprintl : output_channel -> string -> unit Lwt.t
val fprintf : output_channel -> ('a, unit, string, unit Lwt.t) format4 -> 'a
(** [%!] does nothing here. To flush the channel, use [Lwt_io.flush channel]. *)
val fprintlf : output_channel -> ('a, unit, string, unit Lwt.t) format4 -> 'a
(** [%!] does nothing here. To flush the channel, use [Lwt_io.flush channel]. *)
val print : string -> unit Lwt.t
val printl : string -> unit Lwt.t
val printf : ('a, unit, string, unit Lwt.t) format4 -> 'a
(** [%!] does nothing here. To flush the channel, use
[Lwt_io.(flush stdout)]. *)
val printlf : ('a, unit, string, unit Lwt.t) format4 -> 'a
(** [%!] does nothing here. To flush the channel, use
[Lwt_io.(flush stdout)]. *)
val eprint : string -> unit Lwt.t
val eprintl : string -> unit Lwt.t
val eprintf : ('a, unit, string, unit Lwt.t) format4 -> 'a
(** [%!] does nothing here. To flush the channel, use
[Lwt_io.(flush stderr)]. *)
val eprintlf : ('a, unit, string, unit Lwt.t) format4 -> 'a
(** [%!] does nothing here. To flush the channel, use
[Lwt_io.(flush stderr)]. *)
(** {2 Utilities} *)
val hexdump_stream : output_channel -> char Lwt_stream.t -> unit Lwt.t
(** [hexdump_stream oc byte_stream] produces the same output as the
command [hexdump -C]. *)
val hexdump : output_channel -> string -> unit Lwt.t
(** [hexdump oc str = hexdump_stream oc (Lwt_stream.of_string str)] *)
(** {2 File utilities} *)
type file_name = string
(** Type of file names *)
val open_file :
?buffer:Lwt_bytes.t ->
?flags:Unix.open_flag list ->
?perm:Unix.file_perm ->
mode:'a mode ->
file_name ->
'a channel Lwt.t
(** [Lwt_io.open_file ~mode file] opens the given file, either for reading (with
[~mode:Input]) or for writing (with [~mode:Output]). The returned channel
provides buffered I/O on the file.
If [~buffer] is supplied, it is used as the I/O buffer.
If [~flags] is supplied, the file is opened with the given flags (see
{!Unix.open_flag}). Note that [~flags] is used {e exactly} as given. For
example, opening a file with [~flags] and [~mode:Input] does {e not}
implicitly add [O_RDONLY]. So, you should include [O_RDONLY] when opening
for reading ([~mode:Input]), and [O_WRONLY] when opening for writing
([~mode:Input]). It is also recommended to include [O_NONBLOCK], unless you
are sure that the file cannot be a socket or a named pipe.
The default permissions used for creating new files are [0o666], i.e.
reading and writing are allowed for the file owner, group, and everyone.
These default permissions can be overridden by supplying [~perm].
Note: if opening for writing ([~mode:Output]), and the file already exists,
[open_file] truncates (clears) the file by default. If you would like to
keep the pre-existing contents of the file, use the [~flags] parameter to
pass a custom flags list that does not include {!Unix.O_TRUNC}.
@raise Unix.Unix_error on error. *)
val with_file :
?buffer:Lwt_bytes.t ->
?flags:Unix.open_flag list ->
?perm:Unix.file_perm ->
mode:'a mode ->
file_name ->
('a channel -> 'b Lwt.t) ->
'b Lwt.t
(** [Lwt_io.with_file ~mode filename f] opens the given using
{!Lwt_io.open_file}, and passes the resulting channel to [f].
[Lwt_io.with_file] ensures that the channel is closed when the promise
returned by [f] resolves, or if [f] raises an exception.
See {!Lwt_io.open_file} for a description of the arguments, warnings, and
other notes. *)
val open_temp_file :
?buffer:Lwt_bytes.t ->
?flags:Unix.open_flag list ->
?perm:Unix.file_perm ->
?temp_dir:string ->
?prefix:string ->
?suffix:string ->
unit ->
(string * output_channel) Lwt.t
(** [open_temp_file ()] starts creating a new temporary file, and evaluates to a
promise for the pair of the file's name, and an output channel for writing
to the file.
The caller should take care to delete the file later. Alternatively, see
{!Lwt_io.with_temp_file}.
The [?buffer] and [?perm] arguments are passed directly to an internal call
to {!Lwt_io.open_file}.
If not specified, [?flags] defaults to
[[O_CREATE; O_EXCL; O_WRONLY; O_CLOEXEC]]. If specified, the specified flags
are used exactly. Note that these should typically contain at least
[O_CREAT] and [O_EXCL], otherwise [open_temp_file] may open an existing
file.
[?temp_dir] can be used to choose the directory in which the file is
created. For the current directory, use {!Stdlib.Filename.current_dir_name}.
If not specified, the directory is taken from {!Stdlib.Filename.get_temp_dir_name},
which is typically set to your system temporary file directory.
[?prefix] helps determine the name of the file. It will be the prefix
concatenated with a random sequence of characters. If not specified,
[open_temp_file] uses some default prefix.
[?suffix] is like [prefix], but it is appended at the end of the filename.
In particular, it can be used to set the extension. This argument is
supported since Lwt 4.4.0.
@since 3.2.0 *)
val with_temp_file :
?buffer:Lwt_bytes.t ->
?flags:Unix.open_flag list ->
?perm:Unix.file_perm ->
?temp_dir:string ->
?prefix:string ->
?suffix:string ->
(string * output_channel -> 'b Lwt.t) ->
'b Lwt.t
(** [with_temp_file f] calls {!open_temp_file}[ ()], passing all optional
arguments directly to it. It then attaches [f] to run after the file is
created, passing the filename and output channel to [f]. When the promise
returned by [f] is resolved, [with_temp_file] closes the channel and deletes
the temporary file by calling {!Lwt_unix.unlink}.
@since 3.2.0 *)
val create_temp_dir :
?perm:Unix.file_perm ->
?parent:string ->
?prefix:string ->
?suffix:string ->
unit ->
string Lwt.t
(** Creates a temporary directory, and returns a promise that resolves to its
path. The caller must take care to remove the directory. Alternatively, see
{!Lwt_io.with_temp_dir}.
If [~perm] is specified, the directory is created with the given
permissions. The default permissions are [0755].
[~parent] is the directory in which the temporary directory is created. If
not specified, the default value is the result of
[Filename.get_temp_dir_name ()].
[~prefix] is prepended to the directory name, and [~suffix] is appended to
it.
@since 4.4.0 *)
val with_temp_dir :
?perm:Unix.file_perm ->
?parent:string ->
?prefix:string ->
?suffix:string ->
(string -> 'a Lwt.t) ->
'a Lwt.t
(** [with_temp_dir f] first calls {!create_temp_dir}, forwarding all optional
arguments to it. Once the temporary directory is created at [path],
[with_temp_dir f] calls [f path]. When the promise returned by [f path] is
resolved, [with_temp_dir f] recursively deletes the temporary directory and
all its contents by calling {!Lwt_io.delete_recursively}.
@since 4.4.0 *)
val delete_recursively : string -> unit Lwt.t
(** [delete_recursively path] attempts to delete the directory [path]
and all its content recursively.
This is likely VERY slow for directories with many files. That is probably
best addressed by switching to blocking calls run inside a worker thread,
i.e. with {!Lwt_preemptive}.
@since 5.7.0 *)
val open_connection :
?fd : Lwt_unix.file_descr ->
?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t ->
Unix.sockaddr -> (input_channel * output_channel) Lwt.t
(** [open_connection ?fd ?in_buffer ?out_buffer addr] opens a
connection to the given address and returns two channels for using
it. If [fd] is not specified, a fresh one will be used.
The connection is completely closed when you close both
channels.
@raise Unix.Unix_error on error.
*)
val with_connection :
?fd : Lwt_unix.file_descr ->
?in_buffer : Lwt_bytes.t -> ?out_buffer : Lwt_bytes.t ->
Unix.sockaddr -> (input_channel * output_channel -> 'a Lwt.t) -> 'a Lwt.t
(** [with_connection ?fd ?in_buffer ?out_buffer addr f] opens a
connection to the given address and passes the channels to
[f] *)
(**/**)
(** This function is not public API and can be changed or removed without
notice. It is exposed in order to test [with_connection].
[with_close_connection f (ic, oc)] calls [f (ic, oc)] and makes sure that
[ic] and [oc] are closed, whether [f] returns or fails with an exception.
Does not fail if [ic] or [oc] is already closed. *)
val with_close_connection :
(input_channel * output_channel -> 'a Lwt.t) ->
input_channel * output_channel ->
'a Lwt.t
(**/**)
type server
(** Type of a server *)
val establish_server_with_client_socket :
?server_fd:Lwt_unix.file_descr ->
?backlog:int ->
?no_close:bool ->
Unix.sockaddr ->
(Lwt_unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t) ->
server Lwt.t
(** [establish_server_with_client_socket listen_address f] creates a server
which listens for incoming connections on [listen_address]. When a client
makes a new connection, it is passed to [f]: more precisely, the server
calls
{[
f client_address client_socket
]}
where [client_address] is the address (peer name) of the new client, and
[client_socket] is the socket connected to the client.
The server does not block waiting for [f] to complete: it concurrently tries
to accept more client connections while [f] is handling the client.
When the promise returned by [f] completes (i.e., [f] is done handling the
client), [establish_server_with_client_socket] automatically closes
[client_socket]. This is a default behavior that is useful for simple cases,
but for a robust application you should explicitly close these channels
yourself, and handle any exceptions as appropriate. If the channels are
still open when [f] completes, and their automatic closing raises an
exception, [establish_server_with_client_socket] treats it as an unhandled
exception reaching the top level of the application: it passes that
exception to {!Lwt.async_exception_hook}, the default behavior of which is
to print the exception and {e terminate your process}.
Automatic closing can be completely disabled by passing [~no_close:true].
Similarly, if [f] raises an exception (or the promise it returns fails with
an exception), [establish_server_with_client_socket] can do nothing with
that exception, except pass it to {!Lwt.async_exception_hook}.
[~server_fd] can be specified to use an existing file descriptor for
listening. Otherwise, a fresh socket is created internally. In either case,
[establish_server_with_client_socket] will internally assign
[listen_address] to the server socket.
[~backlog] is the argument passed to {!Lwt_unix.listen}. Its default value
is [SOMAXCONN], which varies by platform and socket kind.
The returned promise (a [server Lwt.t]) resolves when the server has just
started listening on [listen_address]: right after the internal call to
[listen], and right before the first internal call to [accept].
@since 4.1.0 *)
val establish_server_with_client_address :
?fd:Lwt_unix.file_descr ->
?buffer_size:int ->
?backlog:int ->
?no_close:bool ->
Unix.sockaddr ->
(Lwt_unix.sockaddr -> input_channel * output_channel -> unit Lwt.t) ->
server Lwt.t
(** Like {!Lwt_io.establish_server_with_client_socket}, but passes two buffered
channels to the connection handler [f]. These channels wrap the client
socket.
The channels are closed automatically when the promise returned by [f]
resolves. To avoid this behavior, pass [~no_close:true].
@since 3.1.0 *)
val shutdown_server : server -> unit Lwt.t
(** Closes the given server's listening socket. The returned promise resolves
when the [close(2)] system call completes. This function does not affect the
sockets of connections that have already been accepted, i.e. passed to [f]
by {!establish_server}.
@since 3.0.0 *)
val lines_of_file : file_name -> string Lwt_stream.t
(** [lines_of_file name] returns a stream of all lines of the file
with name [name]. The file is automatically closed when all
lines have been read. *)
val lines_to_file : file_name -> string Lwt_stream.t -> unit Lwt.t
(** [lines_to_file name lines] writes all lines of [lines] to
file with name [name]. *)
val chars_of_file : file_name -> char Lwt_stream.t
(** [chars_of_file name] returns a stream of all characters of the
file with name [name]. As for {!lines_of_file} the file is
closed when all characters have been read. *)
val chars_to_file : file_name -> char Lwt_stream.t -> unit Lwt.t
(** [chars_to_file name chars] writes all characters of [chars] to
[name] *)
(** {2 Input/output of integers} *)
(** Common interface for reading/writing integers in binary *)
module type NumberIO = sig
(** {3 Reading} *)
val read_int : input_channel -> int Lwt.t
(** Reads a 32-bits integer as an ocaml int *)
val read_int16 : input_channel -> int Lwt.t
val read_int32 : input_channel -> int32 Lwt.t
val read_int64 : input_channel -> int64 Lwt.t
val read_float32 : input_channel -> float Lwt.t
(** Reads an IEEE single precision floating point value *)
val read_float64 : input_channel -> float Lwt.t
(** Reads an IEEE double precision floating point value *)
(** {3 Writing} *)
val write_int : output_channel -> int -> unit Lwt.t
(** Writes an ocaml int as a 32-bits integer *)
val write_int16 : output_channel -> int -> unit Lwt.t
val write_int32 : output_channel -> int32 -> unit Lwt.t
val write_int64 : output_channel -> int64 -> unit Lwt.t
val write_float32 : output_channel -> float -> unit Lwt.t
(** Writes an IEEE single precision floating point value *)
val write_float64 : output_channel -> float -> unit Lwt.t
(** Writes an IEEE double precision floating point value *)
end
module LE : NumberIO
(** Reading/writing of numbers in little-endian *)
module BE : NumberIO
(** Reading/writing of numbers in big-endian *)
include NumberIO
(** Reading/writing of numbers in the system endianness. *)
type byte_order = Lwt_sys.byte_order = Little_endian | Big_endian
(** Type of byte order *)
val system_byte_order : byte_order
(** Same as {!val:Lwt_sys.byte_order}. *)
(** {2 Low-level access to the internal buffer} *)
val block : 'a channel -> int -> (Lwt_bytes.t -> int -> 'b Lwt.t) -> 'b Lwt.t
(** [block ch size f] pass to [f] the internal buffer and an
offset. The buffer contains [size] chars at [offset]. [f] may
read or write these chars. [size] must satisfy [0 <= size <= 16] *)
(** Information for directly accessing the internal buffer of a
channel *)
type direct_access = {
da_buffer : Lwt_bytes.t;
(** The internal buffer *)
mutable da_ptr : int;
(** The pointer to:
- the beginning of free space for output channels
- the beginning of data for input channels *)
mutable da_max : int;
(** The maximum offset *)
da_perform : unit -> int Lwt.t;
(** - for input channels:
refills the buffer and returns how many bytes have been read
- for output channels:
flush partially the buffer and returns how many bytes have been
written *)
}
val direct_access : 'a channel -> (direct_access -> 'b Lwt.t) -> 'b Lwt.t
(** [direct_access ch f] passes to [f] a {!type:direct_access}
structure. [f] must use it and update [da_ptr] to reflect how
many bytes have been read/written. *)
(** {2 Misc} *)
val default_buffer_size : unit -> int
(** Return the default size for buffers. Channels that are created
without a specific buffer use new buffer of this size. *)
val set_default_buffer_size : int -> unit
(** Change the default buffer size.
@raise Invalid_argument if the given size is smaller than [16]
or greater than {!Stdlib.Sys.max_string_length} *)
(** {2 Deprecated} *)
val establish_server :
?fd : Lwt_unix.file_descr ->
?buffer_size : int ->
?backlog : int ->
?no_close : bool ->
Unix.sockaddr -> (input_channel * output_channel -> unit Lwt.t) ->
server Lwt.t
[@@ocaml.deprecated
" Since Lwt 3.1.0, use Lwt_io.establish_server_with_client_address"]
(** Like [establish_server_with_client_address], but does not pass the client
address or fd to the callback [f].
@deprecated Use {!establish_server_with_client_address}.
@since 3.0.0 *)
(** Versioned variants of APIs undergoing breaking changes. *)
module Versioned :
sig
val establish_server_1 :
?fd : Lwt_unix.file_descr ->
?buffer_size : int ->
?backlog : int ->
Unix.sockaddr -> (input_channel * output_channel -> unit) ->
server
[@@ocaml.deprecated
" Deprecated in favor of Lwt_io.establish_server. See
https://github.com/ocsigen/lwt/pull/258"]
(** Old version of {!Lwt_io.establish_server}. The current
{!Lwt_io.establish_server} automatically closes channels passed to the
callback, and notifies the caller when the server's listening socket is
bound.
@deprecated Use {!Lwt_io.establish_server_with_client_address}.
@since 2.7.0 *)
val establish_server_2 :
?fd : Lwt_unix.file_descr ->
?buffer_size : int ->
?backlog : int ->
?no_close : bool ->
Unix.sockaddr -> (input_channel * output_channel -> unit Lwt.t) ->
server Lwt.t
[@@ocaml.deprecated
" In Lwt >= 3.0.0, this is an alias for Lwt_io.establish_server."]
(** Since Lwt 3.0.0, this is just an alias for {!Lwt_io.establish_server}.
@deprecated Use {!Lwt_io.establish_server_with_client_address}.
@since 2.7.0 *)
val shutdown_server_1 : server -> unit
[@@ocaml.deprecated
" Deprecated in favor of Lwt_io.shutdown_server. See
https://github.com/ocsigen/lwt/issues/259"]
(** Old version of {!Lwt_io.shutdown_server}. The current
{!Lwt_io.shutdown_server} returns a promise, which resolves when the
server's listening socket is closed.
@deprecated Use {!Lwt_io.shutdown_server}.
@since 2.7.0 *)
val shutdown_server_2 : server -> unit Lwt.t
[@@ocaml.deprecated
" In Lwt >= 3.0.0, this is an alias for Lwt_io.shutdown_server."]
(** Since Lwt 3.0.0, this is just an alias for {!Lwt_io.shutdown_server}.
@deprecated Use {!Lwt_io.shutdown_server}.
@since 2.7.0 *)
end

257
unikernel/duniverse/lwt/src/unix/lwt_libev_stubs.c Normal file
View file

@ -0,0 +1,257 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
/* Stubs for libev */
#include "lwt_config.h"
#if defined(HAVE_LIBEV)
#include <assert.h>
#include <caml/alloc.h>
#include <caml/callback.h>
#include <caml/custom.h>
#include <caml/fail.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
#include <caml/signals.h>
#include <ev.h>
#include "lwt_unix.h"
/* +-----------------------------------------------------------------+
| Backend types |
+-----------------------------------------------------------------+ */
enum {
val_EVBACKEND_DEFAULT,
val_EVBACKEND_SELECT,
val_EVBACKEND_POLL,
val_EVBACKEND_EPOLL,
val_EVBACKEND_KQUEUE,
val_EVBACKEND_DEVPOLL,
val_EVBACKEND_PORT
};
static unsigned int backend_val(value v) {
switch (Int_val(v)) {
case val_EVBACKEND_DEFAULT:
return 0;
case val_EVBACKEND_SELECT:
return EVBACKEND_SELECT;
case val_EVBACKEND_POLL:
return EVBACKEND_POLL;
case val_EVBACKEND_EPOLL:
return EVBACKEND_EPOLL;
case val_EVBACKEND_KQUEUE:
return EVBACKEND_KQUEUE;
case val_EVBACKEND_DEVPOLL:
return EVBACKEND_DEVPOLL;
case val_EVBACKEND_PORT:
return EVBACKEND_PORT;
default:
assert(0);
}
}
/* +-----------------------------------------------------------------+
| Loops |
+-----------------------------------------------------------------+ */
static int compare_loops(value a, value b) {
return (int)((char *)Ev_loop_val(a) - (char *)Ev_loop_val(b));
}
static long hash_loop(value loop) { return (long)Ev_loop_val(loop); }
static struct custom_operations loop_ops = {
"lwt.libev.loop", custom_finalize_default, compare_loops,
hash_loop, custom_serialize_default, custom_deserialize_default,
custom_compare_ext_default,
NULL
};
/* Do nothing.
We replace the invoke_pending callback of the event loop, so when
events are ready, they can be executed after ev_loop has returned:
it is executed in a blocking section and callbacks must be executed
outside.
*/
static void nop(struct ev_loop *loop) {}
CAMLprim value lwt_libev_init(value backend) {
struct ev_loop *loop = ev_loop_new(EVFLAG_FORKCHECK | backend_val(backend));
if (!loop) caml_failwith("lwt_libev_init");
/* Remove the invoke_pending callback. */
ev_set_invoke_pending_cb(loop, nop);
value result = caml_alloc_custom(&loop_ops, sizeof(struct ev_loop *), 0, 1);
Ev_loop_val(result) = loop;
return result;
}
CAMLprim value lwt_libev_backend(value loop) {
switch (ev_backend(Ev_loop_val(loop))) {
case EVBACKEND_SELECT:
return Val_int(val_EVBACKEND_SELECT);
case EVBACKEND_POLL:
return Val_int(val_EVBACKEND_POLL);
case EVBACKEND_EPOLL:
return Val_int(val_EVBACKEND_EPOLL);
case EVBACKEND_KQUEUE:
return Val_int(val_EVBACKEND_KQUEUE);
case EVBACKEND_DEVPOLL:
return Val_int(val_EVBACKEND_DEVPOLL);
case EVBACKEND_PORT:
return Val_int(val_EVBACKEND_PORT);
default:
assert(0);
}
}
CAMLprim value lwt_libev_stop(value loop) {
ev_loop_destroy(Ev_loop_val(loop));
return Val_unit;
}
CAMLprim value lwt_libev_loop(value val_loop, value val_block) {
struct ev_loop *loop = Ev_loop_val(val_loop);
/* Call the event loop inside a blocking section. */
caml_enter_blocking_section();
ev_loop(loop, Bool_val(val_block) ? EVLOOP_ONESHOT
: EVLOOP_ONESHOT | EVLOOP_NONBLOCK);
caml_leave_blocking_section();
/* Invoke callbacks now, i.e. outside the blocking section. */
ev_invoke_pending(loop);
return Val_unit;
}
CAMLprim value lwt_libev_unloop(value loop) {
ev_unloop(Ev_loop_val(loop), EVUNLOOP_ONE);
return Val_unit;
}
/* +-----------------------------------------------------------------+
| Watchers |
+-----------------------------------------------------------------+ */
#define Ev_io_val(v) *(struct ev_io **)Data_custom_val(v)
#define Ev_timer_val(v) *(struct ev_timer **)Data_custom_val(v)
static int compare_watchers(value a, value b) {
return (int)((char *)Ev_io_val(a) - (char *)Ev_io_val(b));
}
static long hash_watcher(value watcher) { return (long)Ev_io_val(watcher); }
static struct custom_operations watcher_ops = {
"lwt.libev.watcher", custom_finalize_default, compare_watchers,
hash_watcher, custom_serialize_default, custom_deserialize_default,
custom_compare_ext_default,
NULL
};
/* +-----------------------------------------------------------------+
| IO watchers |
+-----------------------------------------------------------------+ */
static void handle_io(struct ev_loop *loop, ev_io *watcher, int revents) {
caml_callback((value)watcher->data, Val_unit);
}
static value lwt_libev_io_init(struct ev_loop *loop, int fd, int event,
value callback) {
CAMLparam1(callback);
CAMLlocal1(result);
/* Create and initialise the watcher */
struct ev_io *watcher = lwt_unix_new(struct ev_io);
ev_io_init(watcher, handle_io, fd, event);
/* Wrap the watcher into a custom caml value */
result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_io *), 0, 1);
Ev_io_val(result) = watcher;
/* Store the callback in the watcher, and register it as a root */
watcher->data = (void *)callback;
caml_register_generational_global_root((value *)(&(watcher->data)));
/* Start the event */
ev_io_start(loop, watcher);
CAMLreturn(result);
}
CAMLprim value lwt_libev_readable_init(value loop, value fd, value callback) {
return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_READ, callback);
}
CAMLprim value lwt_libev_writable_init(value loop, value fd, value callback) {
return lwt_libev_io_init(Ev_loop_val(loop), FD_val(fd), EV_WRITE, callback);
}
CAMLprim value lwt_libev_io_stop(value loop, value val_watcher) {
CAMLparam2(loop, val_watcher);
struct ev_io *watcher = Ev_io_val(val_watcher);
caml_remove_generational_global_root((value *)(&(watcher->data)));
ev_io_stop(Ev_loop_val(loop), watcher);
free(watcher);
CAMLreturn(Val_unit);
}
/* +-----------------------------------------------------------------+
| Timer watchers |
+-----------------------------------------------------------------+ */
static void handle_timer(struct ev_loop *loop, ev_timer *watcher, int revents) {
caml_callback((value)watcher->data, Val_unit);
}
CAMLprim value lwt_libev_timer_init(value loop, value delay, value repeat,
value callback) {
CAMLparam4(loop, delay, repeat, callback);
CAMLlocal1(result);
struct ev_loop* ev_loop = Ev_loop_val(loop);
/* Create and initialise the watcher */
struct ev_timer *watcher = lwt_unix_new(struct ev_timer);
ev_tstamp adjusted_delay = Double_val(delay) + ev_time() - ev_now(ev_loop);
if (Bool_val(repeat))
ev_timer_init(watcher, handle_timer, adjusted_delay, Double_val(delay));
else
ev_timer_init(watcher, handle_timer, adjusted_delay, 0.0);
/* Wrap the watcher into a custom caml value */
result = caml_alloc_custom(&watcher_ops, sizeof(struct ev_timer *), 0, 1);
Ev_timer_val(result) = watcher;
/* Store the callback in the watcher, and register it as a root */
watcher->data = (void *)callback;
caml_register_generational_global_root((value *)(&(watcher->data)));
/* Start the event */
ev_timer_start(ev_loop, watcher);
CAMLreturn(result);
}
CAMLprim value lwt_libev_timer_stop(value loop, value val_watcher) {
CAMLparam2(loop, val_watcher);
struct ev_timer *watcher = Ev_timer_val(val_watcher);
caml_remove_generational_global_root((value *)(&(watcher->data)));
ev_timer_stop(Ev_loop_val(loop), watcher);
free(watcher);
CAMLreturn(Val_unit);
}
#else
#include "lwt_unix.h"
LWT_NOT_AVAILABLE1(libev_backend)
LWT_NOT_AVAILABLE1(libev_init)
LWT_NOT_AVAILABLE1(libev_stop)
LWT_NOT_AVAILABLE2(libev_loop)
LWT_NOT_AVAILABLE1(libev_unloop)
LWT_NOT_AVAILABLE3(libev_readable_init)
LWT_NOT_AVAILABLE3(libev_writable_init)
LWT_NOT_AVAILABLE2(libev_io_stop)
LWT_NOT_AVAILABLE4(libev_timer_init)
LWT_NOT_AVAILABLE2(libev_timer_stop)
#endif

187
unikernel/duniverse/lwt/src/unix/lwt_main.ml Normal file
View file

@ -0,0 +1,187 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it.
However, it is still used internally by Lwt. So, briefly disable warning 3
("deprecated"), and create a local, non-deprecated alias for
[Lwt_sequence] that can be referred to by the rest of the code in this
module without triggering any more warnings. *)
module Lwt_sequence = Lwt_sequence
open Lwt.Infix
let enter_iter_hooks = Lwt_sequence.create ()
let leave_iter_hooks = Lwt_sequence.create ()
let yield = Lwt.pause
let abandon_yielded_and_paused () =
Lwt.abandon_paused ()
let run p =
let rec run_loop () =
match Lwt.poll p with
| Some x ->
x
| None ->
(* Call enter hooks. *)
Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks;
(* Do the main loop call. *)
let should_block_waiting_for_io = Lwt.paused_count () = 0 in
Lwt_engine.iter should_block_waiting_for_io;
(* Fulfill paused promises. *)
Lwt.wakeup_paused ();
(* Call leave hooks. *)
Lwt_sequence.iter_l (fun f -> f ()) leave_iter_hooks;
(* Repeat. *)
run_loop ()
in
run_loop ()
let run_already_called = ref `No
let run_already_called_mutex = Mutex.create ()
let finished () =
Mutex.lock run_already_called_mutex;
run_already_called := `No;
Mutex.unlock run_already_called_mutex
let run p =
(* Fail in case a call to Lwt_main.run is nested under another invocation of
Lwt_main.run. *)
Mutex.lock run_already_called_mutex;
let error_message_if_call_is_nested =
match !run_already_called with
(* `From is effectively disabled for the time being, because there is a bug,
present in all versions of OCaml supported by Lwt, where, with the
bytecode runtime, if one changes the working directory and then attempts
to retrieve the backtrace, the runtime calls [abort] at the C level and
exits the program ungracefully. It is especially likely that a daemon
would change directory before calling [Lwt_main.run], so we can't have it
retrieving the backtrace, even though a daemon is not likely to be
compiled to bytecode.
This can be addressed with detection. Starting with 4.04, there is a
type [Sys.backend_type] that could be used. *)
| `From backtrace_string ->
Some (Printf.sprintf "%s\n%s\n%s"
"Nested calls to Lwt_main.run are not allowed"
"Lwt_main.run already called from:"
backtrace_string)
| `From_somewhere ->
Some ("Nested calls to Lwt_main.run are not allowed")
| `No ->
let called_from =
(* See comment above.
if Printexc.backtrace_status () then
let backtrace =
try raise Exit
with Exit -> Printexc.get_backtrace ()
in
`From backtrace
else *)
`From_somewhere
in
run_already_called := called_from;
None
in
Mutex.unlock run_already_called_mutex;
begin match error_message_if_call_is_nested with
| Some message -> failwith message
| None -> ()
end;
match run p with
| result ->
finished ();
result
| exception exn when Lwt.Exception_filter.run exn ->
finished ();
raise exn
let exit_hooks = Lwt_sequence.create ()
let rec call_hooks () =
match Lwt_sequence.take_opt_l exit_hooks with
| None ->
Lwt.return_unit
| Some f ->
Lwt.catch
(fun () -> f ())
(fun _ -> Lwt.return_unit) >>= fun () ->
call_hooks ()
let () =
at_exit (fun () ->
if not (Lwt_sequence.is_empty exit_hooks) then begin
Lwt.abandon_wakeups ();
finished ();
run (call_hooks ())
end)
let at_exit f = ignore (Lwt_sequence.add_l f exit_hooks)
module type Hooks =
sig
type 'return_value kind
type hook
val add_first : (unit -> unit kind) -> hook
val add_last : (unit -> unit kind) -> hook
val remove : hook -> unit
val remove_all : unit -> unit
end
module type Hook_sequence =
sig
type 'return_value kind
val sequence : (unit -> unit kind) Lwt_sequence.t
end
module Wrap_hooks (Sequence : Hook_sequence) =
struct
type 'a kind = 'a Sequence.kind
type hook = (unit -> unit Sequence.kind) Lwt_sequence.node
let add_first hook_fn =
let hook_node = Lwt_sequence.add_l hook_fn Sequence.sequence in
hook_node
let add_last hook_fn =
let hook_node = Lwt_sequence.add_r hook_fn Sequence.sequence in
hook_node
let remove hook_node =
Lwt_sequence.remove hook_node
let remove_all () =
Lwt_sequence.iter_node_l Lwt_sequence.remove Sequence.sequence
end
module Enter_iter_hooks =
Wrap_hooks (struct
type 'return_value kind = 'return_value
let sequence = enter_iter_hooks
end)
module Leave_iter_hooks =
Wrap_hooks (struct
type 'return_value kind = 'return_value
let sequence = leave_iter_hooks
end)
module Exit_hooks =
Wrap_hooks (struct
type 'return_value kind = 'return_value Lwt.t
let sequence = exit_hooks
end)

154
unikernel/duniverse/lwt/src/unix/lwt_main.mli Normal file
View file

@ -0,0 +1,154 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Main loop and event queue *)
(** This module controls the ``main-loop'' of Lwt. *)
val run : 'a Lwt.t -> 'a
(** [Lwt_main.run p] calls the Lwt scheduler, performing I/O until [p]
resolves. [Lwt_main.run p] returns the value in [p] if [p] is fulfilled.
If [p] is rejected with an exception instead, [Lwt_main.run p] raises that
exception.
Every native and bytecode program that uses Lwt should call this function
at its top level. It implements the Lwt main loop.
Example:
{[
let main () = Lwt_io.write_line Lwt_io.stdout "hello world"
let () = Lwt_main.run (main ())
]}
[Lwt_main.run] is not available when targeting JavaScript, because the
environment (such as Node.js or the browser's script engine) implements
the I/O loop.
On Unix, calling [Lwt_main.run] installs a [SIGCHLD] handler, which is
needed for the implementations of {!Lwt_unix.waitpid} and
{!Lwt_unix.wait4}. As a result, programs that call [Lwt_main.run] and also
use non-Lwt system calls need to handle those system calls failing with
[EINTR].
Nested calls to [Lwt_main.run] are not allowed. That is, do not call
[Lwt_main.run] in a callback triggered by a promise that is resolved by
an outer invocation of [Lwt_main.run]. If your program makes such a call,
[Lwt_main.run] will raise [Failure]. This should be considered a logic
error (i.e., code making such a call is inherently broken).
In addition, note that if you have set the exception filter to let runtime
exceptions bubble up (via
[Lwt.Exception_filter.(set handle_all_except_runtime)])
then Lwt does not attempt to catch exceptions thrown by the OCaml runtime.
Specifically, in this case, Lwt lets [Out_of_memory] and [Stack_overflow]
exceptions traverse all of its functions and bubble up to the caller of
[Lwt_main.run]. Moreover because these exceptions are left to traverse the
call stack, they leave the internal data-structures in an inconsistent
state. For this reason, calling [Lwt_main.run] again after such an
exception will raise [Failure].
It is not safe to call [Lwt_main.run] in a function registered with
[Stdlib.at_exit], use {!Lwt_main.at_exit} instead. *)
val yield : unit -> unit Lwt.t [@@deprecated "Use Lwt.pause instead"]
(** [yield ()] is a pending promise that is fulfilled after Lwt finishes
calling all currently ready callbacks, i.e. it is fulfilled on the next
“tick.”
@deprecated Since 5.5.0 [yield] is deprecated in favor of the more general
{!Lwt.pause} in order to avoid discrepancies in resolution (see below) and
stay compatible with other execution environments such as js_of_ocaml. *)
val abandon_yielded_and_paused : unit -> unit [@@deprecated "Use Lwt.abandon_paused instead"]
(** Causes promises created with {!Lwt.pause} and {!Lwt_main.yield} to remain
forever pending.
(Note that [yield] is deprecated in favor of the more general {!Lwt.pause}.)
This is meant for use with {!Lwt_unix.fork}, as a way to “abandon” more
promise chains that are pending in your process.
@deprecated Since 5.7 [abandon_yielded_and_paused] is deprecated in favour
of [Lwt.abandon_paused]. *)
(** Hook sequences. Each module of this type is a set of hooks, to be run by Lwt
at certain points during execution. See modules {!Enter_iter_hooks},
{!Leave_iter_hooks}, and {!Exit_hooks}. *)
module type Hooks =
sig
type 'return_value kind
(** Hooks are functions of either type [unit -> unit] or [unit -> unit Lwt.t];
this type constructor is used only to express both possibilities in one
signature. *)
type hook
(** Values of type [hook] represent hooks that have been added, so that they
can be removed later (if needed). *)
val add_first : (unit -> unit kind) -> hook
(** Adds a hook to the hook sequence underlying this module, to be run
{e first}, before any other hooks already added. *)
val add_last : (unit -> unit kind) -> hook
(** Adds a hook to the hook sequence underlying this module, to be run
{e last}, after any other hooks already added. *)
val remove : hook -> unit
(** Removes a hook added by {!add_first} or {!add_last}. *)
val remove_all : unit -> unit
(** Removes all hooks from the hook sequence underlying this module. *)
end
(** Hooks, of type [unit -> unit], that are called before each iteration of the
Lwt main loop.
@since 4.2.0 *)
module Enter_iter_hooks :
Hooks with type 'return_value kind = 'return_value
(** Hooks, of type [unit -> unit], that are called after each iteration of the
Lwt main loop.
@since 4.2.0 *)
module Leave_iter_hooks :
Hooks with type 'return_value kind = 'return_value
(** Promise-returning hooks, of type [unit -> unit Lwt.t], that are called at
process exit. Exceptions raised by these hooks are ignored.
@since 4.2.0 *)
module Exit_hooks :
Hooks with type 'return_value kind = 'return_value Lwt.t
[@@@ocaml.warning "-3"]
val enter_iter_hooks : (unit -> unit) Lwt_sequence.t
[@@ocaml.deprecated
" Use module Lwt_main.Enter_iter_hooks."]
(** @deprecated Use module {!Enter_iter_hooks}. *)
val leave_iter_hooks : (unit -> unit) Lwt_sequence.t
[@@ocaml.deprecated
" Use module Lwt_main.Leave_iter_hooks."]
(** @deprecated Use module {!Leave_iter_hooks}. *)
val exit_hooks : (unit -> unit Lwt.t) Lwt_sequence.t
[@@ocaml.deprecated
" Use module Lwt_main.Exit_hooks."]
(** @deprecated Use module {!Exit_hooks}. *)
[@@@ocaml.warning "+3"]
val at_exit : (unit -> unit Lwt.t) -> unit
(** [Lwt_main.at_exit hook] is the same as
[ignore (Lwt_main.Exit_hooks.add_first hook)]. *)

263
unikernel/duniverse/lwt/src/unix/lwt_preemptive.ml Normal file
View file

@ -0,0 +1,263 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(* [Lwt_sequence] is deprecated – we don't want users outside Lwt using it.
However, it is still used internally by Lwt. So, briefly disable warning 3
("deprecated"), and create a local, non-deprecated alias for
[Lwt_sequence] that can be referred to by the rest of the code in this
module without triggering any more warnings. *)
module Lwt_sequence = Lwt_sequence
open Lwt.Infix
(* +-----------------------------------------------------------------+
| Parameters |
+-----------------------------------------------------------------+ *)
(* Minimum number of preemptive threads: *)
let min_threads : int ref = ref 0
(* Maximum number of preemptive threads: *)
let max_threads : int ref = ref 0
(* Size of the waiting queue: *)
let max_thread_queued = ref 1000
let get_max_number_of_threads_queued _ =
!max_thread_queued
let set_max_number_of_threads_queued n =
if n < 0 then invalid_arg "Lwt_preemptive.set_max_number_of_threads_queued";
max_thread_queued := n
(* The total number of preemptive threads currently running: *)
let threads_count = ref 0
(* +-----------------------------------------------------------------+
| Preemptive threads management |
+-----------------------------------------------------------------+ *)
module CELL :
sig
type 'a t
val make : unit -> 'a t
val get : 'a t -> 'a
val set : 'a t -> 'a -> unit
end =
struct
type 'a t = {
m : Mutex.t;
cv : Condition.t;
mutable cell : 'a option;
}
let make () = { m = Mutex.create (); cv = Condition.create (); cell = None }
let get t =
let rec await_value t =
match t.cell with
| None ->
Condition.wait t.cv t.m;
await_value t
| Some v ->
t.cell <- None;
Mutex.unlock t.m;
v
in
Mutex.lock t.m;
await_value t
let set t v =
Mutex.lock t.m;
t.cell <- Some v;
Mutex.unlock t.m;
Condition.signal t.cv
end
type thread = {
task_cell: (int * (unit -> unit)) CELL.t;
(* Channel used to communicate notification id and tasks to the
worker thread. *)
mutable thread : Thread.t;
(* The worker thread. *)
mutable reuse : bool;
(* Whether the thread must be re-added to the pool when the work is
done. *)
}
(* Pool of worker threads: *)
let workers : thread Queue.t = Queue.create ()
(* Queue of clients waiting for a worker to be available: *)
let waiters : thread Lwt.u Lwt_sequence.t = Lwt_sequence.create ()
(* Code executed by a worker: *)
let rec worker_loop worker =
let id, task = CELL.get worker.task_cell in
task ();
(* If there is too much threads, exit. This can happen if the user
decreased the maximum: *)
if !threads_count > !max_threads then worker.reuse <- false;
(* Tell the main thread that work is done: *)
Lwt_unix.send_notification id;
if worker.reuse then worker_loop worker
(* create a new worker: *)
let make_worker () =
incr threads_count;
let worker = {
task_cell = CELL.make ();
thread = Thread.self ();
reuse = true;
} in
worker.thread <- Thread.create worker_loop worker;
worker
(* Add a worker to the pool: *)
let add_worker worker =
match Lwt_sequence.take_opt_l waiters with
| None ->
Queue.add worker workers
| Some w ->
Lwt.wakeup w worker
(* Wait for worker to be available, then return it: *)
let get_worker () =
if not (Queue.is_empty workers) then
Lwt.return (Queue.take workers)
else if !threads_count < !max_threads then
Lwt.return (make_worker ())
else
(Lwt.add_task_r [@ocaml.warning "-3"]) waiters
(* +-----------------------------------------------------------------+
| Initialisation, and dynamic parameters reset |
+-----------------------------------------------------------------+ *)
let get_bounds () = (!min_threads, !max_threads)
let set_bounds (min, max) =
if min < 0 || max < min then invalid_arg "Lwt_preemptive.set_bounds";
let diff = min - !threads_count in
min_threads := min;
max_threads := max;
(* Launch new workers: *)
for _i = 1 to diff do
add_worker (make_worker ())
done
let initialized = ref false
let init min max _errlog =
initialized := true;
set_bounds (min, max)
let simple_init () =
if not !initialized then begin
initialized := true;
set_bounds (0, 4)
end
let nbthreads () = !threads_count
let nbthreadsqueued () = Lwt_sequence.fold_l (fun _ x -> x + 1) waiters 0
let nbthreadsbusy () = !threads_count - Queue.length workers
(* +-----------------------------------------------------------------+
| Detaching |
+-----------------------------------------------------------------+ *)
let init_result = Result.Error (Failure "Lwt_preemptive.detach")
let detach f args =
simple_init ();
let result = ref init_result in
(* The task for the worker thread: *)
let task () =
try
result := Result.Ok (f args)
with exn when Lwt.Exception_filter.run exn ->
result := Result.Error exn
in
get_worker () >>= fun worker ->
let waiter, wakener = Lwt.wait () in
let id =
Lwt_unix.make_notification ~once:true
(fun () -> Lwt.wakeup_result wakener !result)
in
Lwt.finalize
(fun () ->
(* Send the id and the task to the worker: *)
CELL.set worker.task_cell (id, task);
waiter)
(fun () ->
if worker.reuse then
(* Put back the worker to the pool: *)
add_worker worker
else begin
decr threads_count;
(* Or wait for the thread to terminates, to free its associated
resources: *)
Thread.join worker.thread
end;
Lwt.return_unit)
(* +-----------------------------------------------------------------+
| Running Lwt threads in the main thread |
+-----------------------------------------------------------------+ *)
(* Queue of [unit -> unit Lwt.t] functions. *)
let jobs = Queue.create ()
(* Mutex to protect access to [jobs]. *)
let jobs_mutex = Mutex.create ()
let job_notification =
Lwt_unix.make_notification
(fun () ->
(* Take the first job. The queue is never empty at this
point. *)
Mutex.lock jobs_mutex;
let thunk = Queue.take jobs in
Mutex.unlock jobs_mutex;
ignore (thunk ()))
let run_in_main_dont_wait f =
(* Add the job to the queue. *)
Mutex.lock jobs_mutex;
Queue.add f jobs;
Mutex.unlock jobs_mutex;
(* Notify the main thread. *)
Lwt_unix.send_notification job_notification
(* There is a potential performance issue from creating a cell every time this
function is called. See:
https://github.com/ocsigen/lwt/issues/218
https://github.com/ocsigen/lwt/pull/219
https://github.com/ocaml/ocaml/issues/7158 *)
let run_in_main f =
let cell = CELL.make () in
(* Create the job. *)
let job () =
(* Execute [f] and wait for its result. *)
Lwt.try_bind f
(fun ret -> Lwt.return (Result.Ok ret))
(fun exn -> Lwt.return (Result.Error exn)) >>= fun result ->
(* Send the result. *)
CELL.set cell result;
Lwt.return_unit
in
run_in_main_dont_wait job;
(* Wait for the result. *)
match CELL.get cell with
| Result.Ok ret -> ret
| Result.Error exn -> raise exn
(* This version shadows the one above, adding an exception handler *)
let run_in_main_dont_wait f handler =
let f () = Lwt.catch f (fun exc -> handler exc; Lwt.return_unit) in
run_in_main_dont_wait f

86
unikernel/duniverse/lwt/src/unix/lwt_preemptive.mli Normal file
View file

@ -0,0 +1,86 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** This module allows to mix preemptive threads with [Lwt]
cooperative threads. It maintains an extensible pool of preemptive
threads to which you can detach computations.
See {{:https://github.com/hcarty/mwt} Mwt} for a more modern
implementation. *)
val detach : ('a -> 'b) -> 'a -> 'b Lwt.t
(** [detach f x] runs the computation [f x] in a separate preemptive thread.
[detach] evaluates to an Lwt promise, which is pending until the
preemptive thread completes.
[detach] calls {!simple_init} internally, which means that the number of
preemptive threads is capped by default at four. If you would like a
higher limit, call {!init} or {!set_bounds} directly.
Note that Lwt thread-local storage (i.e., {!Lwt.with_value}) cannot be
safely used from within [f]. The same goes for most of the rest of Lwt. If
you need to run an Lwt thread in [f], use {!run_in_main}. *)
val run_in_main : (unit -> 'a Lwt.t) -> 'a
(** [run_in_main f] can be called from a detached computation to execute
[f ()] in the main preemptive thread, i.e. the one executing
{!Lwt_main.run}. [run_in_main f] blocks until [f ()] completes, then
returns its result. If [f ()] raises an exception, [run_in_main f] raises
the same exception.
{!Lwt.with_value} may be used inside [f ()]. {!Lwt.get} can correctly
retrieve values set this way inside [f ()], but not values set using
{!Lwt.with_value} outside [f ()]. *)
val run_in_main_dont_wait : (unit -> unit Lwt.t) -> (exn -> unit) -> unit
(** [run_in_main_dont_wait f h] does the same as [run_in_main f] but a bit faster
and lighter as it does not wait for the result of [f].
If [f]'s promise is rejected (or if it raises), then the function [h] is
called with the rejection exception.
@since 5.7.0 *)
val init : int -> int -> (string -> unit) -> unit
(** [init min max log] initialises this module. i.e. it launches the
minimum number of preemptive threads and starts the {b
dispatcher}.
@param min is the minimum number of threads
@param max is the maximum number of threads
@param log is used to log error messages
If {!Lwt_preemptive} has already been initialised, this call
only modify bounds and the log function. *)
val simple_init : unit -> unit
(** [simple_init ()] checks if the library is not yet initialized, and if not,
does a {i simple initialization}. The minimum number of threads is set to
zero, maximum to four, and the log function is left unchanged, i.e. the
default built-in logging function is used. See {!Lwt_preemptive.init}.
Note: this function is automatically called by {!detach}. *)
val get_bounds : unit -> int * int
(** [get_bounds ()] returns the minimum and the maximum number of
preemptive threads. *)
val set_bounds : int * int -> unit
(** [set_bounds (min, max)] set the minimum and the maximum number
of preemptive threads. *)
val set_max_number_of_threads_queued : int -> unit
(** Sets the size of the waiting queue, if no more preemptive
threads are available. When the queue is full, {!detach} will
sleep until a thread is available. *)
val get_max_number_of_threads_queued : unit -> int
(** Returns the size of the waiting queue, if no more threads are
available *)
(**/**)
val nbthreads : unit -> int
val nbthreadsbusy : unit -> int
val nbthreadsqueued : unit -> int

543
unikernel/duniverse/lwt/src/unix/lwt_process.cppo.ml Normal file
View file

@ -0,0 +1,543 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
open Lwt.Infix
type command = string * string array
let shell =
if Sys.win32 then
fun cmd -> ("", [|"cmd.exe"; "/c"; "\000" ^ cmd|])
else
fun cmd -> ("", [|"/bin/sh"; "-c"; cmd|])
type redirection =
[ `Keep
| `Dev_null
| `Close
| `FD_copy of Unix.file_descr
| `FD_move of Unix.file_descr ]
(* +-----------------------------------------------------------------+
| OS-dependent command spawning |
+-----------------------------------------------------------------+ *)
type proc = {
id : int;
(* The process id. *)
fd : Unix.file_descr;
(* A handle on windows, and a dummy value of Unix. *)
}
let win32_get_fd fd redirection =
match redirection with
| `Keep ->
Some fd
| `Dev_null ->
Some (Unix.openfile "nul" [Unix.O_RDWR; Unix.O_KEEPEXEC] 0o666)
| `Close ->
None
| `FD_copy fd' ->
Some fd'
| `FD_move fd' ->
Some fd'
external win32_create_process :
string option -> string -> string option -> string option ->
(Unix.file_descr option * Unix.file_descr option * Unix.file_descr option) ->
proc = "lwt_process_create_process"
let win32_quote arg =
if String.length arg > 0 && arg.[0] = '\000' then
String.sub arg 1 (String.length arg - 1)
else
Filename.quote arg
let win32_spawn
?cwd
?(stdin:redirection=`Keep)
?(stdout:redirection=`Keep)
?(stderr:redirection=`Keep)
(prog, args) env
=
let cmdline = String.concat " " (List.map win32_quote (Array.to_list args)) in
let env =
match env with
| None ->
None
| Some env ->
let len =
Array.fold_left (fun len str -> String.length str + len + 1) 1 env in
let res = Bytes.create len in
let ofs =
Array.fold_left
(fun ofs str ->
let len = String.length str in
String.blit str 0 res ofs len;
Bytes.set res (ofs + len) '\000';
ofs + len + 1)
0 env
in
Bytes.set res ofs '\000';
Some (Bytes.unsafe_to_string res)
in
let stdin_fd = win32_get_fd Unix.stdin stdin
and stdout_fd = win32_get_fd Unix.stdout stdout
and stderr_fd = win32_get_fd Unix.stderr stderr in
let proc =
win32_create_process
(if prog = "" then None else Some prog) cmdline env cwd
(stdin_fd, stdout_fd, stderr_fd)
in
let close fd fd' =
match fd with
| `FD_move _ | `Dev_null ->
Unix.close (match fd' with Some fd' -> fd' | _ -> assert false)
| _ -> ()
in
close stdin stdin_fd;
close stdout stdout_fd;
close stderr stderr_fd;
proc
external win32_wait_job : Unix.file_descr -> int Lwt_unix.job =
"lwt_process_wait_job"
let win32_waitproc proc =
Lwt_unix.run_job (win32_wait_job proc.fd) >>= fun code ->
Lwt.return
(proc.id,
Lwt_unix.WEXITED code,
{Lwt_unix.ru_utime = 0.; Lwt_unix.ru_stime = 0.})
external win32_terminate_process : Unix.file_descr -> int -> unit =
"lwt_process_terminate_process"
let win32_terminate proc =
win32_terminate_process proc.fd 1
let unix_redirect fd redirection = match redirection with
| `Keep ->
()
| `Dev_null ->
let dev_null = Unix.openfile "/dev/null" [Unix.O_RDWR; Unix.O_KEEPEXEC] 0o666 in
Unix.dup2 ~cloexec:false dev_null fd;
Unix.close dev_null
| `Close ->
Unix.close fd
| `FD_copy fd' ->
Unix.dup2 ~cloexec:false fd' fd
| `FD_move fd' ->
Unix.dup2 ~cloexec:false fd' fd;
Unix.close fd'
#if OCAML_VERSION >= (5, 0, 0)
external unix_exit : int -> 'a = "caml_unix_exit"
#else
external unix_exit : int -> 'a = "unix_exit"
#endif
let unix_spawn
?cwd
?(stdin:redirection=`Keep)
?(stdout:redirection=`Keep)
?(stderr:redirection=`Keep)
(prog, args) env
=
let prog = if prog = "" && Array.length args > 0 then args.(0) else prog in
match Lwt_unix.fork () with
| 0 ->
unix_redirect Unix.stdin stdin;
unix_redirect Unix.stdout stdout;
unix_redirect Unix.stderr stderr;
begin
try
begin match cwd with
| None -> ()
| Some dir ->
Sys.chdir dir
end;
match env with
| None ->
Unix.execvp prog args
| Some env ->
Unix.execvpe prog args env
with _ ->
(* Do not run at_exit hooks *)
unix_exit 127
end
| id ->
let close = function
| `FD_move fd ->
Unix.close fd
| _ ->
()
in
close stdin;
close stdout;
close stderr;
{id; fd = Unix.stdin}
let unix_waitproc proc = Lwt_unix.wait4 [] proc.id
let unix_terminate proc =
Unix.kill proc.id Sys.sigkill
let spawn = if Sys.win32 then win32_spawn else unix_spawn
let waitproc = if Sys.win32 then win32_waitproc else unix_waitproc
let terminate = if Sys.win32 then win32_terminate else unix_terminate
(* +-----------------------------------------------------------------+
| Objects |
+-----------------------------------------------------------------+ *)
type state =
| Running
| Exited of Unix.process_status
let status (_pid, status, _rusage) = status
let rusage (_pid, _status, rusage) = rusage
external cast_chan : 'a Lwt_io.channel -> unit Lwt_io.channel = "%identity"
(* Transform a channel into a channel that only support closing. *)
let ignore_close chan = ignore (Lwt_io.close chan)
class virtual common timeout proc channels =
let wait = waitproc proc in
object(self)
val mutable closed = false
method pid = proc.id
method state =
match Lwt.poll wait with
| None -> Running
| Some (_pid, status, _rusage) -> Exited status
method kill signum =
if Lwt.state wait = Lwt.Sleep then
Unix.kill proc.id signum
method terminate =
if Lwt.state wait = Lwt.Sleep then
terminate proc
method close =
if closed then self#status
else (
closed <- true;
Lwt.protected (Lwt.join (List.map Lwt_io.close channels))
>>= fun () -> self#status
)
method status = Lwt.protected wait >|= status
method rusage = Lwt.protected wait >|= rusage
initializer
(* Ensure channels are closed when no longer used. *)
List.iter (Gc.finalise ignore_close) channels;
(* Handle timeout. *)
match timeout with
| None ->
()
| Some dt ->
ignore (
(* Ignore errors since they can be obtained by
self#close. *)
Lwt.try_bind
(fun () ->
Lwt.choose [(Lwt_unix.sleep dt >>= fun () -> Lwt.return_false);
(wait >>= fun _ -> Lwt.return_true)])
(function
| true ->
Lwt.return_unit
| false ->
self#terminate;
self#close >>= fun _ -> Lwt.return_unit)
(fun _ ->
(* The exception is dropped because it can be
obtained with self#close. *)
Lwt.return_unit)
)
end
class process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd =
let proc = spawn cmd env ?cwd ?stdin ?stdout ?stderr in
object
inherit common timeout proc []
end
class process_in ?timeout ?env ?cwd ?stdin ?stderr cmd =
let stdout_r, stdout_w = Lwt_unix.pipe_in ~cloexec:true () in
let proc = spawn cmd env ?cwd ?stdin ~stdout:(`FD_move stdout_w) ?stderr in
let stdout = Lwt_io.of_fd ~mode:Lwt_io.input stdout_r in
object
inherit common timeout proc [cast_chan stdout]
method stdout = stdout
end
class process_out ?timeout ?env ?cwd ?stdout ?stderr cmd =
let stdin_r, stdin_w = Lwt_unix.pipe_out ~cloexec:true () in
let proc = spawn cmd env ?cwd ~stdin:(`FD_move stdin_r) ?stdout ?stderr in
let stdin = Lwt_io.of_fd ~mode:Lwt_io.output stdin_w in
object
inherit common timeout proc [cast_chan stdin]
method stdin = stdin
end
class process ?timeout ?env ?cwd ?stderr cmd =
let stdin_r, stdin_w = Lwt_unix.pipe_out ~cloexec:true ()
and stdout_r, stdout_w = Lwt_unix.pipe_in ~cloexec:true () in
let proc =
spawn
cmd env ?cwd ~stdin:(`FD_move stdin_r) ~stdout:(`FD_move stdout_w) ?stderr
in
let stdin = Lwt_io.of_fd ~mode:Lwt_io.output stdin_w
and stdout = Lwt_io.of_fd ~mode:Lwt_io.input stdout_r in
object
inherit common timeout proc [cast_chan stdin; cast_chan stdout]
method stdin = stdin
method stdout = stdout
end
class process_full ?timeout ?env ?cwd cmd =
let stdin_r, stdin_w = Lwt_unix.pipe_out ~cloexec:true ()
and stdout_r, stdout_w = Lwt_unix.pipe_in ~cloexec:true ()
and stderr_r, stderr_w = Lwt_unix.pipe_in ~cloexec:true () in
let proc =
spawn
cmd env ?cwd
~stdin:(`FD_move stdin_r)
~stdout:(`FD_move stdout_w)
~stderr:(`FD_move stderr_w)
in
let stdin = Lwt_io.of_fd ~mode:Lwt_io.output stdin_w
and stdout = Lwt_io.of_fd ~mode:Lwt_io.input stdout_r
and stderr = Lwt_io.of_fd ~mode:Lwt_io.input stderr_r in
object
inherit
common timeout proc [cast_chan stdin; cast_chan stdout; cast_chan stderr]
method stdin = stdin
method stdout = stdout
method stderr = stderr
end
let open_process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd =
new process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd
let open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd =
new process_in ?timeout ?env ?cwd ?stdin ?stderr cmd
let open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd =
new process_out ?timeout ?env ?cwd ?stdout ?stderr cmd
let open_process ?timeout ?env ?cwd ?stderr cmd =
new process ?timeout ?env ?cwd ?stderr cmd
let open_process_full ?timeout ?env ?cwd cmd =
new process_full ?timeout ?env ?cwd cmd
let make_with backend ?timeout ?env ?cwd cmd f =
let process = backend ?timeout ?env ?cwd cmd in
Lwt.finalize
(fun () -> f process)
(fun () ->
process#close >>= fun _ ->
Lwt.return_unit)
let with_process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd f =
make_with (open_process_none ?stdin ?stdout ?stderr) ?timeout ?env ?cwd cmd f
let with_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd f =
make_with (open_process_in ?stdin ?stderr) ?timeout ?env ?cwd cmd f
let with_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd f =
make_with (open_process_out ?stdout ?stderr) ?timeout ?env ?cwd cmd f
let with_process ?timeout ?env ?cwd ?stderr cmd f =
make_with (open_process ?stderr) ?timeout ?env ?cwd cmd f
let with_process_full ?timeout ?env ?cwd cmd f =
make_with open_process_full ?timeout ?env ?cwd cmd f
(* +-----------------------------------------------------------------+
| High-level functions |
+-----------------------------------------------------------------+ *)
let exec ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd =
(open_process_none ?timeout ?env ?cwd ?stdin ?stdout ?stderr cmd)#close
let ignore_close ch =
ignore (Lwt_io.close ch)
let read_opt read ic =
Lwt.catch
(fun () -> read ic >|= fun x -> Some x)
(function
| Unix.Unix_error (Unix.EPIPE, _, _) | End_of_file ->
Lwt.return_none
| exn -> Lwt.reraise exn)
let recv_chars pr =
let ic = pr#stdout in
Gc.finalise ignore_close ic;
Lwt_stream.from (fun _ ->
read_opt Lwt_io.read_char ic >>= fun x ->
if x = None then begin
Lwt_io.close ic >>= fun () ->
Lwt.return x
end else
Lwt.return x)
let recv_lines pr =
let ic = pr#stdout in
Gc.finalise ignore_close ic;
Lwt_stream.from (fun _ ->
read_opt Lwt_io.read_line ic >>= fun x ->
if x = None then begin
Lwt_io.close ic >>= fun () ->
Lwt.return x
end else
Lwt.return x)
let recv pr =
let ic = pr#stdout in
Lwt.finalize
(fun () -> Lwt_io.read ic)
(fun () -> Lwt_io.close ic)
let recv_line pr =
let ic = pr#stdout in
Lwt.finalize
(fun () -> Lwt_io.read_line ic)
(fun () -> Lwt_io.close ic)
let send f pr data =
let oc = pr#stdin in
Lwt.finalize
(fun () -> f oc data)
(fun () -> Lwt_io.close oc)
(* Receiving *)
let pread ?timeout ?env ?cwd ?stdin ?stderr cmd =
recv (open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd)
let pread_chars ?timeout ?env ?cwd ?stdin ?stderr cmd =
recv_chars (open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd)
let pread_line ?timeout ?env ?cwd ?stdin ?stderr cmd =
recv_line (open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd)
let pread_lines ?timeout ?env ?cwd ?stdin ?stderr cmd =
recv_lines (open_process_in ?timeout ?env ?cwd ?stdin ?stderr cmd)
(* Sending *)
let pwrite ?timeout ?env ?cwd ?stdout ?stderr cmd text =
send Lwt_io.write (open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd) text
let pwrite_chars ?timeout ?env ?cwd ?stdout ?stderr cmd chars =
send
Lwt_io.write_chars
(open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd)
chars
let pwrite_line ?timeout ?env ?cwd ?stdout ?stderr cmd line =
send
Lwt_io.write_line
(open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd)
line
let pwrite_lines ?timeout ?env ?cwd ?stdout ?stderr cmd lines =
send
Lwt_io.write_lines
(open_process_out ?timeout ?env ?cwd ?stdout ?stderr cmd)
lines
(* Mapping *)
type 'a map_state =
| Init
| Save of 'a option Lwt.t
| Done
(* Monitor the thread [sender] in the stream [st] so write errors are
reported. *)
let monitor sender st =
let sender = sender >|= fun () -> None in
let state = ref Init in
Lwt_stream.from
(fun () ->
match !state with
| Init ->
let getter = Lwt.apply Lwt_stream.get st in
let result _ =
match Lwt.state sender with
| Lwt.Sleep ->
(* The sender is still sleeping, behave as the
getter. *)
getter
| Lwt.Return _ ->
(* The sender terminated successfully, we are
done monitoring it. *)
state := Done;
getter
| Lwt.Fail _ ->
(* The sender failed, behave as the sender for
this element and save current getter. *)
state := Save getter;
sender
in
Lwt.try_bind (fun () -> Lwt.choose [sender; getter]) result result
| Save t ->
state := Done;
t
| Done ->
Lwt_stream.get st)
let pmap ?timeout ?env ?cwd ?stderr cmd text =
let pr = open_process ?timeout ?env ?cwd ?stderr cmd in
(* Start the sender and getter at the same time. *)
let sender = send Lwt_io.write pr text in
let getter = recv pr in
Lwt.catch
(fun () ->
(* Wait for both to terminate, returning the result of the
getter. *)
sender >>= fun () -> getter)
(function
| Lwt.Canceled as exn ->
(* Cancel the getter if the sender was canceled. *)
Lwt.cancel getter;
Lwt.reraise exn
| exn -> Lwt.reraise exn)
let pmap_chars ?timeout ?env ?cwd ?stderr cmd chars =
let pr = open_process ?timeout ?env ?cwd ?stderr cmd in
let sender = send Lwt_io.write_chars pr chars in
monitor sender (recv_chars pr)
let pmap_line ?timeout ?env ?cwd ?stderr cmd line =
let pr = open_process ?timeout ?env ?cwd ?stderr cmd in
(* Start the sender and getter at the same time. *)
let sender = send Lwt_io.write_line pr line in
let getter = recv_line pr in
Lwt.catch
(fun () ->
(* Wait for both to terminate, returning the result of the
getter. *)
sender >>= fun () -> getter)
(function
| Lwt.Canceled as exn ->
(* Cancel the getter if the sender was canceled. *)
Lwt.cancel getter;
Lwt.reraise exn
| exn -> Lwt.reraise exn)
let pmap_lines ?timeout ?env ?cwd ?stderr cmd lines =
let pr = open_process ?timeout ?env ?cwd ?stderr cmd in
let sender = send Lwt_io.write_lines pr lines in
monitor sender (recv_lines pr)

339
unikernel/duniverse/lwt/src/unix/lwt_process.mli Normal file
View file

@ -0,0 +1,339 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Process management *)
(** This module allows you to spawn processes and communicate with them. *)
type command = string * string array
(** A command. The first field is the name of the executable and
the second is the list of arguments. For example:
{[
("ls", [|"ls"; "-l"|])
]}
Notes:
- if the name is the empty string, then the first argument
will be used. You should specify a name only if you do not
want the executable to be searched in the PATH. On Windows the
only way to enable automatic search in PATH is to pass an empty
name.
- it is possible to ``inline'' an argument, i.e. split it into
multiple arguments. To do that prefix it with ["\000"]. For
example:
{[
("", [|"echo"; "\000foo bar"|])
]}
is the same as:
{[
("", [|"echo"; "foo"; "bar"|])
]}
*)
val shell : string -> command
(** A command executed with the shell. (with ["/bin/sh -c <cmd>"] on
Unix and ["cmd.exe /c <cmd>"] on Windows). *)
(** All the following functions take an optional argument
[timeout], in seconds. If specified, after expiration, the process will be
sent a {!Unix.sigkill} signal and channels will be closed. When the channels
are closed, any pending I/O operations on them (such as
{!Lwt_io.read_chars}) fail with exception {!Lwt_io.Channel_closed}. *)
(** {2 High-level functions} *)
(** {3 Redirections} *)
type redirection =
[ `Keep (** Point to the same file as in the parent. *)
| `Dev_null (** Redirect to [/dev/null] (POSIX) or [nul] (Win32). *)
| `Close (** Close the file descriptor. *)
| `FD_copy of Unix.file_descr (** Redirect to the file pointed to by [fd].
[fd] remains open in the parent. *)
| `FD_move of Unix.file_descr (** Redirect to the file pointed to by [fd].
[fd] is then closed in the parent. *)
]
(** File descriptor redirections. These are used with the [~stdin], [~stdout],
and [~stderr] arguments below to specify how the standard file descriptors
should be redirected in the child process.
All optional redirection arguments default to [`Keep]. *)
(** {3 Executing} *)
val exec :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stdout : redirection ->
?stderr : redirection ->
command -> Unix.process_status Lwt.t
(** Executes the given command and returns its exit status. *)
(** {3 Receiving} *)
val pread :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stderr : redirection ->
command -> string Lwt.t
val pread_chars :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stderr : redirection ->
command -> char Lwt_stream.t
val pread_line :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stderr : redirection ->
command -> string Lwt.t
val pread_lines :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stderr : redirection ->
command -> string Lwt_stream.t
(** {3 Sending} *)
val pwrite :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdout : redirection ->
?stderr : redirection ->
command -> string -> unit Lwt.t
val pwrite_chars :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdout : redirection ->
?stderr : redirection ->
command -> char Lwt_stream.t -> unit Lwt.t
val pwrite_line :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdout : redirection ->
?stderr : redirection ->
command -> string -> unit Lwt.t
val pwrite_lines :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdout : redirection ->
?stderr : redirection ->
command -> string Lwt_stream.t -> unit Lwt.t
(** {3 Mapping} *)
val pmap :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stderr : redirection ->
command -> string -> string Lwt.t
val pmap_chars :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stderr : redirection ->
command -> char Lwt_stream.t -> char Lwt_stream.t
val pmap_line :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stderr : redirection ->
command -> string -> string Lwt.t
val pmap_lines :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stderr : redirection ->
command -> string Lwt_stream.t -> string Lwt_stream.t
(** {2 Spawning processes} *)
(** State of a sub-process *)
type state =
| Running
(** The process is still running *)
| Exited of Unix.process_status
(** The process has exited *)
class process_none :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stdout : redirection ->
?stderr : redirection ->
command ->
object
method pid : int
(** Pid of the sub-process *)
method state : state
(** Return the state of the process *)
method kill : int -> unit
(** [kill signum] sends [signum] to the process if it is still
running. *)
method terminate : unit
(** Terminates the process. It is equivalent to [kill Sys.sigkill]
on Unix but also works on Windows
(unlike {!Lwt_process.process_none.kill}). *)
method status : Unix.process_status Lwt.t
(** Threads which wait for the sub-process to exit then returns its
exit status *)
method rusage : Lwt_unix.resource_usage Lwt.t
(** Threads which wait for the sub-process to exit then returns
its resource usages *)
method close : Unix.process_status Lwt.t
(** Closes the process and returns its exit status. This closes all
channels used to communicate with the process *)
end
val open_process_none :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stdout : redirection ->
?stderr : redirection ->
command -> process_none
val with_process_none :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stdout : redirection ->
?stderr : redirection ->
command -> (process_none -> 'a Lwt.t) -> 'a Lwt.t
class process_in :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stderr : redirection ->
command ->
object
inherit process_none
method stdout : Lwt_io.input_channel
(** The standard output of the process *)
end
val open_process_in :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stderr : redirection ->
command -> process_in
val with_process_in :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdin : redirection ->
?stderr : redirection ->
command -> (process_in -> 'a Lwt.t) -> 'a Lwt.t
class process_out :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdout : redirection ->
?stderr : redirection ->
command ->
object
inherit process_none
method stdin : Lwt_io.output_channel
(** The standard input of the process *)
end
val open_process_out :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdout : redirection ->
?stderr : redirection ->
command -> process_out
val with_process_out :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stdout : redirection ->
?stderr : redirection ->
command -> (process_out -> 'a Lwt.t) -> 'a Lwt.t
class process :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stderr : redirection ->
command ->
object
inherit process_none
method stdin : Lwt_io.output_channel
method stdout : Lwt_io.input_channel
end
val open_process :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stderr : redirection ->
command -> process
val with_process :
?timeout : float ->
?env : string array ->
?cwd : string ->
?stderr : redirection ->
command -> (process -> 'a Lwt.t) -> 'a Lwt.t
class process_full :
?timeout : float ->
?env : string array ->
?cwd : string ->
command ->
object
inherit process_none
method stdin : Lwt_io.output_channel
method stdout : Lwt_io.input_channel
method stderr : Lwt_io.input_channel
end
val open_process_full :
?timeout : float ->
?env : string array ->
?cwd : string ->
command -> process_full
val with_process_full :
?timeout : float ->
?env : string array ->
?cwd : string ->
command -> (process_full -> 'a Lwt.t) -> 'a Lwt.t

175
unikernel/duniverse/lwt/src/unix/lwt_process_stubs.c Normal file
View file

@ -0,0 +1,175 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if defined(LWT_ON_WINDOWS)
#include "lwt_unix.h"
#if OCAML_VERSION < 41300
#define CAML_INTERNALS
#endif
#include <caml/alloc.h>
#include <caml/fail.h>
#include <caml/memory.h>
#include <caml/osdeps.h>
static HANDLE get_handle(value opt) {
value fd;
if (Is_some(opt)) {
fd = Some_val(opt);
if (Descr_kind_val(fd) == KIND_SOCKET) {
win32_maperr(ERROR_INVALID_HANDLE);
uerror("CreateProcess", Nothing);
return NULL;
} else
return Handle_val(fd);
} else
return INVALID_HANDLE_VALUE;
}
/* Ensures the handle [h] is inheritable. Returns the handle for the
child process in [hStd] and in [to_close] if it needs to be closed
after CreateProcess. */
static int ensure_inheritable(HANDLE h /* in */,
HANDLE * hStd /* out */,
HANDLE * to_close /* out */)
{
DWORD flags;
HANDLE hp;
if (h == INVALID_HANDLE_VALUE || h == NULL)
return 1;
if (! GetHandleInformation(h, &flags))
return 0;
hp = GetCurrentProcess();
if (! (flags & HANDLE_FLAG_INHERIT)) {
if (! DuplicateHandle(hp, h, hp, hStd, 0, TRUE, DUPLICATE_SAME_ACCESS))
return 0;
*to_close = *hStd;
} else {
*hStd = h;
}
return 1;
}
CAMLprim value lwt_process_create_process(value prog, value cmdline, value env,
value cwd, value fds) {
CAMLparam5(prog, cmdline, env, cwd, fds);
CAMLlocal1(result);
STARTUPINFO si;
PROCESS_INFORMATION pi;
DWORD flags = 0, err;
HANDLE hp, fd0, fd1, fd2;
HANDLE to_close0 = INVALID_HANDLE_VALUE, to_close1 = INVALID_HANDLE_VALUE,
to_close2 = INVALID_HANDLE_VALUE;
fd0 = get_handle(Field(fds, 0));
fd1 = get_handle(Field(fds, 1));
fd2 = get_handle(Field(fds, 2));
err = ERROR_SUCCESS;
ZeroMemory(&si, sizeof(si));
ZeroMemory(&pi, sizeof(pi));
si.cb = sizeof(si);
si.dwFlags = STARTF_USESTDHANDLES;
/* If needed, duplicate the handles fd1, fd2, fd3 to make sure they
are inheritable. */
if (! ensure_inheritable(fd0, &si.hStdInput, &to_close0) ||
! ensure_inheritable(fd1, &si.hStdOutput, &to_close1) ||
! ensure_inheritable(fd2, &si.hStdError, &to_close2)) {
err = GetLastError(); goto ret;
}
#define string_option(opt) \
(Is_block(opt) ? caml_stat_strdup_to_os(String_val(Field(opt, 0))) : NULL)
char_os
*progs = string_option(prog),
*cmdlines = caml_stat_strdup_to_os(String_val(cmdline)),
*envs = string_option(env),
*cwds = string_option(cwd);
#undef string_option
flags |= CREATE_UNICODE_ENVIRONMENT;
if (! CreateProcess(progs, cmdlines, NULL, NULL, TRUE, flags,
envs, cwds, &si, &pi)) {
err = GetLastError();
}
caml_stat_free(progs);
caml_stat_free(cmdlines);
caml_stat_free(envs);
caml_stat_free(cwds);
ret:
/* Close the handles if we duplicated them above. */
if (to_close0 != INVALID_HANDLE_VALUE) CloseHandle(to_close0);
if (to_close1 != INVALID_HANDLE_VALUE) CloseHandle(to_close1);
if (to_close2 != INVALID_HANDLE_VALUE) CloseHandle(to_close2);
if (err != ERROR_SUCCESS) {
win32_maperr(err);
uerror("CreateProcess", Nothing);
}
CloseHandle(pi.hThread);
result = caml_alloc_tuple(2);
Store_field(result, 0, Val_int(pi.dwProcessId));
Store_field(result, 1, win_alloc_handle(pi.hProcess));
CAMLreturn(result);
}
struct job_wait {
struct lwt_unix_job job;
HANDLE handle;
};
static void worker_wait(struct job_wait *job) {
WaitForSingleObject(job->handle, INFINITE);
}
static value result_wait(struct job_wait *job) {
DWORD code, error;
if (!GetExitCodeProcess(job->handle, &code)) {
error = GetLastError();
CloseHandle(job->handle);
lwt_unix_free_job(&job->job);
win32_maperr(error);
uerror("GetExitCodeProcess", Nothing);
}
CloseHandle(job->handle);
lwt_unix_free_job(&job->job);
return Val_int(code);
}
CAMLprim value lwt_process_wait_job(value handle) {
LWT_UNIX_INIT_JOB(job, wait, 0);
job->handle = Handle_val(handle);
return lwt_unix_alloc_job(&(job->job));
}
CAMLprim value lwt_process_terminate_process(value handle, value code) {
if (!TerminateProcess(Handle_val(handle), Int_val(code))) {
win32_maperr(GetLastError());
uerror("TerminateProcess", Nothing);
}
return Val_unit;
}
#else /* defined(LWT_ON_WINDOWS) */
/* This is used to suppress a warning from ranlib about the object file having
no symbols. */
void lwt_process_dummy_symbol() {}
#endif /* defined(LWT_ON_WINDOWS) */

44
unikernel/duniverse/lwt/src/unix/lwt_sys.ml Normal file
View file

@ -0,0 +1,44 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
exception Not_available of string
let () = Callback.register_exception "lwt:not-available" (Not_available "")
let windows = Sys.win32
type feature =
[ `wait4
| `get_cpu
| `get_affinity
| `set_affinity
| `recv_msg
| `send_msg
| `fd_passing
| `get_credentials
| `mincore
| `madvise
| `fdatasync
| `libev ]
let have = function
| `wait4
| `recv_msg
| `send_msg
| `madvise -> not Sys.win32
| `mincore -> not (Sys.win32 || Sys.cygwin)
| `get_cpu -> Lwt_config._HAVE_GETCPU
| `get_affinity
| `set_affinity -> Lwt_config._HAVE_AFFINITY
| `fd_passing -> Lwt_config._HAVE_FD_PASSING
| `get_credentials -> Lwt_config._HAVE_GET_CREDENTIALS
| `fdatasync -> Lwt_config._HAVE_FDATASYNC
| `libev -> Lwt_config._HAVE_LIBEV
type byte_order = Little_endian | Big_endian
external get_byte_order : unit -> byte_order = "lwt_unix_system_byte_order"
let byte_order = get_byte_order ()

39
unikernel/duniverse/lwt/src/unix/lwt_sys.mli Normal file
View file

@ -0,0 +1,39 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** System informations. *)
exception Not_available of string
(** [Not_available(feature)] is an exception that may be raised when
a feature is not available on the current system. *)
(** Features that can be tested. *)
type feature =
[ `wait4
| `get_cpu
| `get_affinity
| `set_affinity
| `recv_msg
| `send_msg
| `fd_passing
| `get_credentials
| `mincore
| `madvise
| `fdatasync
| `libev ]
val have : feature -> bool
(** Test whether the given feature is available on the current
system. *)
type byte_order = Little_endian | Big_endian
(** Type of byte order *)
val byte_order : byte_order
(** The byte order used by the computer running the program. *)
val windows : bool
[@@ocaml.deprecated " Use Sys.win32."]
(** @deprecated Use [Sys.win32]. *)

118
unikernel/duniverse/lwt/src/unix/lwt_throttle.ml Normal file
View file

@ -0,0 +1,118 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
open Lwt.Infix
module type S = sig
type key
type t
val create : rate:int -> max:int -> n:int -> t
val wait : t -> key -> bool Lwt.t
end
module Make (H : Hashtbl.HashedType) : (S with type key = H.t) = struct
module MH = Hashtbl.Make(H)
type key = H.t
type elt = {
mutable consumed : int;
queue : bool Lwt.u Queue.t;
}
type t = {
rate : int;
max : int; (* maximum number of waiting threads *)
mutable waiting : int;
table : elt MH.t;
mutable cleaning : unit Lwt.t option;
}
let create ~rate ~max ~n =
if rate < 1 || max < 1 || n < 0 then
invalid_arg "Lwt_throttle.S.create"
else {
rate = rate;
max = max;
waiting = 0;
table = MH.create n;
cleaning = None;
}
let update_key t key elt (old_waiting,to_run) =
let rec update to_run = function
| 0 -> 0, Queue.length elt.queue, to_run
| i ->
try
let to_run = (Queue.take elt.queue)::to_run in
update to_run (i-1)
with
| Queue.Empty -> i, 0, to_run
in
let not_consumed, waiting, to_run = update to_run t.rate in
let consumed = t.rate - not_consumed in
if consumed = 0
then
(* there is no waiting threads for this key: we can clean the table *)
MH.remove t.table key
else elt.consumed <- consumed;
(old_waiting+waiting, to_run)
let rec clean_table t =
let waiting,to_run = MH.fold (update_key t) t.table (0,[]) in
t.waiting <- waiting;
if waiting = 0 && to_run = []
then
(* the table is empty: we do not need to clean in 1 second *)
t.cleaning <- None
else launch_cleaning t;
List.iter (fun u -> Lwt.wakeup u true) to_run
and launch_cleaning t =
t.cleaning <-
let t =
Lwt_unix.sleep 1. >>= fun () ->
Lwt.catch
(fun () ->
clean_table t;
Lwt.return_unit)
(fun _exn ->
(* Not good practice, but not worse than the code it is
replacing. *)
prerr_endline "internal error";
Printexc.print_backtrace stderr;
Lwt.return_unit)
in
Some t
let really_wait t elt =
let w,u = Lwt.task () in
if t.max > t.waiting
then (Queue.add u elt.queue;
t.waiting <- succ t.waiting;
w)
else Lwt.return_false
let wait t key =
let res =
try
let elt = MH.find t.table key in
if elt.consumed >= t.rate
then really_wait t elt
else (elt.consumed <- succ elt.consumed;
Lwt.return_true)
with
| Not_found ->
let elt = { consumed = 1;
queue = Queue.create () } in
MH.add t.table key elt;
Lwt.return_true
in
(match t.cleaning with
| None -> launch_cleaning t
| Some _ -> ());
res
end

41
unikernel/duniverse/lwt/src/unix/lwt_throttle.mli Normal file
View file

@ -0,0 +1,41 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Rate limiters.
A rate limiter allows generating sets of promises that will be resolved in
the future, at a maximum rate of N promises per second.
The rate limiters in this module support multiple {e channels}, each given a
different key by the user. The rate limit applies to each channel
independently. *)
module type S = sig
type key
type t
val create : rate:int -> max:int -> n:int -> t
(** Creates a rate limiter.
@param rate Maximum number of promise resolutions per second, per channel.
@param max Maximum number of pending promises allowed at once, over all
channels.
@param n Initial size of the internal channel hash table. This should be
approximately the number of different channels that will be used. *)
val wait : t -> key -> bool Lwt.t
(** [Lwt_throttle.wait limiter channel] returns a new promise associated with
the given rate limiter and channel.
If the maximum number of pending promises for [limiter] has {e not} been
reached, the promise starts pending. It will be resolved with [true] at
some future time, such that the rate limit of [limiter] is not exceeded,
with respect to other promises in the same [channel].
If the maximum number of pending promises has been reached, the returned
promise is already resolved with [false]. *)
end
module Make (H : Hashtbl.HashedType) : S with type key = H.t

107
unikernel/duniverse/lwt/src/unix/lwt_timeout.ml Normal file
View file

@ -0,0 +1,107 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
type t =
{ mutable delay : int; action : unit -> unit;
mutable prev : t; mutable next : t }
let make delay action =
let rec x = { delay = delay; action = action; prev = x; next = x } in
x
let lst_empty () = make (-1) (fun () -> ())
let lst_remove x =
let p = x.prev in
let n = x.next in
p.next <- n;
n.prev <- p;
x.next <- x;
x.prev <- x
let lst_insert p x =
let n = p.next in
p.next <- x;
x.prev <- p;
x.next <- n;
n.prev <- x
let lst_in_list x = x.next != x
let lst_is_empty set = set.next == set
let lst_peek s = let x = s.next in lst_remove x; x
(****)
let count = ref 0
let buckets = ref [||]
let curr = ref 0
let stopped = ref true
let size l =
let len = Array.length !buckets in
if l >= len then begin
let b = Array.init (l + 1) (fun _ -> lst_empty ()) in
Array.blit !buckets !curr b 0 (len - !curr);
Array.blit !buckets 0 b (len - !curr) !curr;
buckets := b; curr := 0;
end
(****)
let handle_exn =
ref
(fun exn ->
!Lwt.async_exception_hook exn)
let set_exn_handler f = handle_exn := f
let rec loop () =
stopped := false;
Lwt.bind (Lwt_unix.sleep 1.) (fun () ->
let s = !buckets.(!curr) in
while not (lst_is_empty s) do
let x = lst_peek s in
decr count;
(*XXX Should probably report any exception *)
try
x.action ()
with e when Lwt.Exception_filter.run e ->
!handle_exn e
done;
curr := (!curr + 1) mod (Array.length !buckets);
if !count > 0 then loop () else begin stopped := true; Lwt.return_unit end)
let start x =
let in_list = lst_in_list x in
let slot = (!curr + x.delay) mod (Array.length !buckets) in
lst_remove x;
lst_insert !buckets.(slot) x;
if not in_list then begin
incr count;
if !count = 1 && !stopped then ignore (loop ())
end
let create delay action =
if delay < 1 then invalid_arg "Lwt_timeout.create";
let x = make delay action in
size delay;
x
let stop x =
if lst_in_list x then begin
lst_remove x;
decr count
end
let change x delay =
if delay < 1 then invalid_arg "Lwt_timeout.change";
x.delay <- delay;
size delay;
if lst_in_list x then start x

46
unikernel/duniverse/lwt/src/unix/lwt_timeout.mli Normal file
View file

@ -0,0 +1,46 @@
(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
(** Cancelable timeouts. *)
type t
val create : int -> (unit -> unit) -> t
(** [Lwt_timeout.create n f] creates a new timeout object with duration [n]
seconds. [f] is the {e action}, a function to be called once the timeout
expires. [f] should not raise exceptions.
The timeout is not started until {!Lwt_timeout.start} is called on it. *)
val start : t -> unit
(** Starts the given timeout.
Starting a timeout that has already been started has the same effect as
stopping it, and then restarting it with its original duration. So,
suppose you have [timeout] with a duration of three seconds, which was
started two seconds ago. The next call to its action is scheduled for one
second in the future. Calling [Lwt_timeout.start timeout] at this point
cancels this upcoming action call, and schedules a call three seconds from
now. *)
val stop : t -> unit
(** Stops (cancels) the given timeout. *)
val change : t -> int -> unit
(** Changes the duration of the given timeout.
If the timeout has already been started, it is stopped, and restarted with
its new duration. This is similar to how {!Lwt_timeout.start} works on a
timeout that has already been started. *)
val set_exn_handler : (exn -> unit) -> unit
(** [Lwt_timeout.set_exn_handler f] sets the handler to be used for exceptions
raised by timeout actions. Recall that actions are not allowed to raise
exceptions. If they do raise an exception [exn] despite this, [f exn] is
called.
The default behavior of [f exn], set by [Lwt_timeout] on program startup, is
to pass [exn] to [!]{!Lwt.async_exception_hook}. The default behavior of
{e that} is to terminate the process. *)

2591
unikernel/duniverse/lwt/src/unix/lwt_unix.cppo.ml Normal file
View file

File diff suppressed because it is too large Load diff

1605
unikernel/duniverse/lwt/src/unix/lwt_unix.cppo.mli Normal file
View file

File diff suppressed because it is too large Load diff

330
unikernel/duniverse/lwt/src/unix/lwt_unix.h Normal file
View file

@ -0,0 +1,330 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#ifndef __LWT_UNIX_H
#define __LWT_UNIX_H
#include "lwt_config.h"
#include <caml/mlvalues.h>
#include <caml/unixsupport.h>
#include <caml/socketaddr.h>
#include <string.h>
// The following macro is for backwards compatibility.
// It is given an `lwt_` prefix to avoid name collisions for code which
// include both this file and alloc.h.
#if OCAML_VERSION < 50000
#define lwt_convert_flag_list(flags, table) \
caml_convert_flag_list((flags), (int *)(table))
#else
#define lwt_convert_flag_list caml_convert_flag_list
#endif
/* The macro to get the file-descriptor from a value. */
#if defined(LWT_ON_WINDOWS)
#define FD_val(value) win_CRT_fd_of_filedescr(value)
#else
#define FD_val(value) Int_val(value)
#endif
/* Macro to extract a libev loop from a caml value. */
#define Ev_loop_val(value) *(struct ev_loop **)Data_custom_val(value)
/* +-----------------------------------------------------------------+
| Utils |
+-----------------------------------------------------------------+ */
/* Allocate the given amount of memory and abort the program if there
is no free memory left. */
void *lwt_unix_malloc(size_t size);
void *lwt_unix_realloc(void *ptr, size_t size);
/* Same as [strdup] and abort the program if there is not memory
left. */
char *lwt_unix_strdup(char *string);
/* Helpers for allocating structures. */
#define lwt_unix_new(type) (type *)lwt_unix_malloc(sizeof(type))
#define lwt_unix_new_plus(type, size) \
(type *)lwt_unix_malloc(sizeof(type) + size)
/* Raise [Lwt_unix.Not_available]. */
void lwt_unix_not_available(char const *feature) Noreturn;
#define LWT_NOT_AVAILABLE_BYTE(prim) \
CAMLprim value lwt_##prim(value *a1, int a2) \
{ \
lwt_unix_not_available(#prim); \
}
#define LWT_NOT_AVAILABLE1(prim) \
CAMLprim value lwt_##prim(value a1) { lwt_unix_not_available(#prim); }
#define LWT_NOT_AVAILABLE2(prim) \
CAMLprim value lwt_##prim(value a1, value a2) \
{ \
lwt_unix_not_available(#prim); \
}
#define LWT_NOT_AVAILABLE3(prim) \
CAMLprim value lwt_##prim(value a1, value a2, value a3) \
{ \
lwt_unix_not_available(#prim); \
}
#define LWT_NOT_AVAILABLE4(prim) \
CAMLprim value lwt_##prim(value a1, value a2, value a3, value a4) \
{ \
lwt_unix_not_available(#prim); \
}
#define LWT_NOT_AVAILABLE5(prim) \
CAMLprim value lwt_##prim(value a1, value a2, value a3, value a4, \
value a5) \
{ \
lwt_unix_not_available(#prim); \
}
#define LWT_NOT_AVAILABLE6(prim) \
CAMLprim value lwt_##prim(value a1, value a2, value a3, value a4, \
value a5, value a6) \
{ \
lwt_unix_not_available(#prim); \
}
/* +-----------------------------------------------------------------+
| Notifications |
+-----------------------------------------------------------------+ */
/* Sends a notification for the given id. */
void lwt_unix_send_notification(intnat id);
/* +-----------------------------------------------------------------+
| Threading |
+-----------------------------------------------------------------+ */
#if defined(HAVE_PTHREAD)
#include <pthread.h>
typedef pthread_t lwt_unix_thread;
typedef pthread_mutex_t lwt_unix_mutex;
typedef pthread_cond_t lwt_unix_condition;
#elif defined(LWT_ON_WINDOWS)
typedef DWORD lwt_unix_thread;
typedef CRITICAL_SECTION lwt_unix_mutex;
typedef struct lwt_unix_condition lwt_unix_condition;
#else
#error "lwt.unix requires pthreads on Unix-like systems"
#endif
/* Launch a thread in detached mode. */
int lwt_unix_launch_thread(void *(*start)(void *), void *data);
/* Return a handle to the currently running thread. */
lwt_unix_thread lwt_unix_thread_self();
/* Returns whether two thread handles refer to the same thread. */
int lwt_unix_thread_equal(lwt_unix_thread thread1, lwt_unix_thread thread2);
/* Initialises a mutex. */
void lwt_unix_mutex_init(lwt_unix_mutex *mutex);
/* Destroy a mutex. */
void lwt_unix_mutex_destroy(lwt_unix_mutex *mutex);
/* Lock a mutex. */
void lwt_unix_mutex_lock(lwt_unix_mutex *mutex);
/* Unlock a mutex. */
void lwt_unix_mutex_unlock(lwt_unix_mutex *mutex);
/* Initialises a condition variable. */
void lwt_unix_condition_init(lwt_unix_condition *condition);
/* Destroy a condition variable. */
void lwt_unix_condition_destroy(lwt_unix_condition *condition);
/* Signal a condition variable. */
void lwt_unix_condition_signal(lwt_unix_condition *condition);
/* Broadcast a signal on a condition variable. */
void lwt_unix_condition_broadcast(lwt_unix_condition *condition);
/* Wait for a signal on a condition variable. */
void lwt_unix_condition_wait(lwt_unix_condition *condition,
lwt_unix_mutex *mutex);
/* +-----------------------------------------------------------------+
| Detached jobs |
+-----------------------------------------------------------------+ */
/* How job are executed. */
enum lwt_unix_async_method {
/* Synchronously. */
LWT_UNIX_ASYNC_METHOD_NONE = 0,
/* Asynchronously, on another thread. */
LWT_UNIX_ASYNC_METHOD_DETACH = 1,
/* Currently a synonym for DETACH. This was a different strategy in the
past. */
LWT_UNIX_ASYNC_METHOD_SWITCH = 2
};
/* Type of job execution modes. */
typedef enum lwt_unix_async_method lwt_unix_async_method;
/* State of a job. */
enum lwt_unix_job_state {
/* The job has not yet started. */
LWT_UNIX_JOB_STATE_PENDING,
/* The job is running. */
LWT_UNIX_JOB_STATE_RUNNING,
/* The job is done. */
LWT_UNIX_JOB_STATE_DONE
};
/* A job descriptor. */
struct lwt_unix_job {
/* The next job in the queue. */
struct lwt_unix_job *next;
/* Id used to notify the main thread in case the job do not
terminate immediately. */
intnat notification_id;
/* The function to call to do the work.
This function must not:
- access or allocate OCaml block values (tuples, strings, ...),
- call OCaml code. */
void (*worker)(struct lwt_unix_job *job);
/* The function to call to extract the result and free memory
allocated by the job.
Note: if you want to raise an exception, be sure to free
resources before raising it!
It has been introduced in Lwt 2.3.3. */
value (*result)(struct lwt_unix_job *job);
/* State of the job. */
enum lwt_unix_job_state state;
/* Is the main thread still waiting for the job ? */
int fast;
/* Mutex to protect access to [state] and [fast]. */
lwt_unix_mutex mutex;
/* The async method in used by the job. */
lwt_unix_async_method async_method;
};
/* Type of job descriptors. */
typedef struct lwt_unix_job *lwt_unix_job;
/* Type of worker functions. */
typedef void (*lwt_unix_job_worker)(lwt_unix_job job);
/* Type of result functions. */
typedef value (*lwt_unix_job_result)(lwt_unix_job job);
/* Allocate a caml custom value for the given job. */
value lwt_unix_alloc_job(lwt_unix_job job);
/* Free resourecs allocated for this job and free it. */
void lwt_unix_free_job(lwt_unix_job job);
/* +-----------------------------------------------------------------+
| Helpers for writing jobs |
+-----------------------------------------------------------------+ */
/* Allocate a job structure and set its worker and result fields.
- VAR is the name of the job variable. It is usually "job".
- FUNC is the suffix of the structure name and functions of this job.
It is usually the name of the function that is wrapped.
- SIZE is the dynamic size to allocate at the end of the structure,
in case it ends ends with something of the form: char data[]);
*/
#define LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE) \
struct job_##FUNC *VAR = lwt_unix_new_plus(struct job_##FUNC, SIZE); \
VAR->job.worker = (lwt_unix_job_worker)worker_##FUNC; \
VAR->job.result = (lwt_unix_job_result)result_##FUNC
/* Same as LWT_UNIX_INIT_JOB, but also stores a string argument named
ARG at the end of the job structure. The offset of the copied
string is assigned to the field VAR->ARG.
The structure must ends with: char data[]; */
#define LWT_UNIX_INIT_JOB_STRING(VAR, FUNC, SIZE, ARG) \
mlsize_t __len = caml_string_length(ARG); \
LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE + __len + 1); \
VAR->ARG = VAR->data + SIZE; \
memcpy(VAR->ARG, String_val(ARG), __len + 1)
/* Same as LWT_UNIX_INIT_JOB, but also stores two string arguments
named ARG1 and ARG2 at the end of the job structure. The offsets of
the copied strings are assigned to the fields VAR->ARG1 and
VAR->ARG2.
The structure definition must ends with: char data[]; */
#define LWT_UNIX_INIT_JOB_STRING2(VAR, FUNC, SIZE, ARG1, ARG2) \
mlsize_t __len1 = caml_string_length(ARG1); \
mlsize_t __len2 = caml_string_length(ARG2); \
LWT_UNIX_INIT_JOB(VAR, FUNC, SIZE + __len1 + __len2 + 2); \
VAR->ARG1 = VAR->data + SIZE; \
VAR->ARG2 = VAR->data + SIZE + __len1 + 1; \
memcpy(VAR->ARG1, String_val(ARG1), __len1 + 1); \
memcpy(VAR->ARG2, String_val(ARG2), __len2 + 1)
/* If TEST is true, it frees the job and raises Unix.Unix_error using
the value of errno stored in the field error_code. */
#define LWT_UNIX_CHECK_JOB(VAR, TEST, NAME) \
if (TEST) { \
int error_code = VAR->error_code; \
lwt_unix_free_job(&VAR->job); \
unix_error(error_code, NAME, Nothing); \
}
/* If TEST is true, it frees the job and raises Unix.Unix_error using
the value of errno stored in the field error_code and uses the C
string ARG for the third field of Unix.Unix_error. */
#define LWT_UNIX_CHECK_JOB_ARG(VAR, TEST, NAME, ARG) \
if (TEST) { \
int error_code = VAR->error_code; \
value arg = caml_copy_string(ARG); \
lwt_unix_free_job(&VAR->job); \
unix_error(error_code, NAME, arg); \
}
/* +-----------------------------------------------------------------+
| Deprecated |
+-----------------------------------------------------------------+ */
/* Define not implement methods. Deprecated: it is for the old
mechanism with three externals. */
#define LWT_UNIX_JOB_NOT_IMPLEMENTED(name) \
CAMLprim value lwt_unix_##name##_job(value Unit) \
{ \
caml_invalid_argument("not implemented"); \
} \
\
CAMLprim value lwt_unix_##name##_result(value Unit) \
{ \
caml_invalid_argument("not implemented"); \
} \
\
CAMLprim value lwt_unix_##name##_free(value Unit) \
{ \
caml_invalid_argument("not implemented"); \
}
#endif /* __LWT_UNIX_H */

1217
unikernel/duniverse/lwt/src/unix/lwt_unix_stubs.c Normal file
View file

File diff suppressed because it is too large Load diff

45
unikernel/duniverse/lwt/src/unix/unix_c/unix_accept4.c Normal file
View file

@ -0,0 +1,45 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#ifdef HAVE_ACCEPT4
#define _GNU_SOURCE
#include <caml/alloc.h>
#include <caml/memory.h>
#include <caml/unixsupport.h>
#include <caml/socketaddr.h>
CAMLprim value lwt_unix_accept4(value vcloexec, value vnonblock, value vsock)
{
CAMLparam3(vcloexec, vnonblock, vsock);
CAMLlocal2(vaddr, res);
union sock_addr_union addr;
socklen_param_type addr_len;
int cloexec = Is_some(vcloexec) && Bool_val(Some_val(vcloexec)) ? SOCK_CLOEXEC : 0;
int nonblock = Bool_val(vnonblock) ? SOCK_NONBLOCK : 0;
addr_len = sizeof(addr);
int fd =
accept4(Int_val(vsock), &addr.s_gen, &addr_len, cloexec | nonblock);
if (fd == -1)
uerror("accept", Nothing);
vaddr = alloc_sockaddr(&addr, addr_len, fd);
res = caml_alloc_small(2, 0);
Field(res, 0) = Val_int(fd);
Field(res, 1) = vaddr;
CAMLreturn(res);
}
#else
#include "lwt_unix.h"
LWT_NOT_AVAILABLE3(unix_accept4)
#endif

137
unikernel/duniverse/lwt/src/unix/unix_c/unix_access_job.c Normal file
View file

@ -0,0 +1,137 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
/* Informations:
- this is the expected prototype of the C function [access]:
int access(char* path, int mode)
- these are the expected ocaml externals for this job:
external access_job : string -> Unix.access_permission list -> unit Lwt_unix.job = "lwt_unix_access_job"
external access_sync : string -> Unix.access_permission list -> unit = "lwt_unix_access_sync"
*/
/* Caml headers. */
#include "lwt_config.h"
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/fail.h>
#include <caml/signals.h>
#include "lwt_unix.h"
#if !defined(LWT_ON_WINDOWS)
/* Specific headers. */
#include <errno.h>
#include <string.h>
#include <unistd.h>
/* +-----------------------------------------------------------------+
| Converters |
+-----------------------------------------------------------------+ */
/* Table mapping constructors of ocaml type Unix.access_permission to C values. */
static const int access_permission_table[] = {
/* Constructor R_OK. */
R_OK,
/* Constructor W_OK. */
W_OK,
/* Constructor X_OK. */
X_OK,
/* Constructor F_OK. */
F_OK
};
/* Convert ocaml values of type Unix.access_permission to a C int. */
static int int_of_access_permissions(value list)
{
int result = 0;
while (list != Val_emptylist) {
result |= access_permission_table[Int_val(Field(list, 0))];
list = Field(list, 1);
};
return result;
}
/* +-----------------------------------------------------------------+
| Asynchronous job |
+-----------------------------------------------------------------+ */
/* Structure holding informations for calling [access]. */
struct job_access {
/* Informations used by lwt. It must be the first field of the structure. */
struct lwt_unix_job job;
/* This field store the result of the call. */
int result;
/* This field store the value of [errno] after the call. */
int errno_copy;
/* in parameter. */
char* path;
/* in parameter. */
int mode;
/* Buffer for string parameters. */
char data[];
};
/* The function calling [access]. */
static void worker_access(struct job_access* job)
{
/* Perform the blocking call. */
job->result = access(job->path, job->mode);
/* Save the value of errno. */
job->errno_copy = errno;
}
/* The function building the caml result. */
static value result_access(struct job_access* job)
{
/* Check for errors. */
if (job->result < 0) {
/* Save the value of errno so we can use it once the job has been freed. */
int error = job->errno_copy;
/* Copy the contents of job->path into a caml string. */
value string_argument = caml_copy_string(job->path);
/* Free the job structure. */
lwt_unix_free_job(&job->job);
/* Raise the error. */
unix_error(error, "access", string_argument);
}
/* Free the job structure. */
lwt_unix_free_job(&job->job);
/* Return the result. */
return Val_unit;
}
/* The stub creating the job structure. */
CAMLprim value lwt_unix_access_job(value path, value mode)
{
/* Get the length of the path parameter. */
mlsize_t len_path = caml_string_length(path) + 1;
/* Allocate a new job. */
struct job_access* job = lwt_unix_new_plus(struct job_access, len_path);
/* Set the offset of the path parameter inside the job structure. */
job->path = job->data;
/* Copy the path parameter inside the job structure. */
memcpy(job->path, String_val(path), len_path);
/* Initializes function fields. */
job->job.worker = (lwt_unix_job_worker)worker_access;
job->job.result = (lwt_unix_job_result)result_access;
/* Copy the mode parameter. */
job->mode = int_of_access_permissions(mode);
/* Wrap the structure into a caml value. */
return lwt_unix_alloc_job(&job->job);
}
#else /* !defined(LWT_ON_WINDOWS) */
CAMLprim value lwt_unix_access_job(value Unit)
{
lwt_unix_not_available("access");
return Val_unit;
}
#endif /* !defined(LWT_ON_WINDOWS) */

49
unikernel/duniverse/lwt/src/unix/unix_c/unix_bind_job.c Normal file
View file

@ -0,0 +1,49 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if !defined(LWT_ON_WINDOWS)
#include <caml/mlvalues.h>
#include <caml/socketaddr.h>
#include <caml/unixsupport.h>
#include <errno.h>
#include <sys/types.h>
#include <sys/socket.h>
#include "lwt_unix.h"
struct job_bind {
struct lwt_unix_job job;
int fd;
union sock_addr_union addr;
socklen_param_type addr_len;
int result;
int error_code;
};
static void worker_bind(struct job_bind *job)
{
job->result = bind(job->fd, &job->addr.s_gen, job->addr_len);
job->error_code = errno;
}
static value result_bind(struct job_bind *job)
{
LWT_UNIX_CHECK_JOB(job, job->result != 0, "bind");
lwt_unix_free_job(&job->job);
return Val_unit;
}
CAMLprim value lwt_unix_bind_job(value fd, value address)
{
LWT_UNIX_INIT_JOB(job, bind, 0);
job->fd = Int_val(fd);
get_sockaddr(address, &job->addr, &job->addr_len);
return lwt_unix_alloc_job(&job->job);
}
#endif

24
unikernel/duniverse/lwt/src/unix/unix_c/unix_bytes_read.c Normal file
View file

@ -0,0 +1,24 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if !defined(LWT_ON_WINDOWS)
#include <caml/mlvalues.h>
#include <caml/unixsupport.h>
#include <caml/bigarray.h>
CAMLprim value lwt_unix_bytes_read(value val_fd, value val_buf, value val_ofs,
value val_len)
{
long ret;
ret = read(Int_val(val_fd),
(char *)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs),
Long_val(val_len));
if (ret == -1) uerror("read", Nothing);
return Val_long(ret);
}
#endif

62
unikernel/duniverse/lwt/src/unix/unix_c/unix_bytes_read_job.c Normal file
View file

@ -0,0 +1,62 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if !defined(LWT_ON_WINDOWS)
#include <caml/bigarray.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
#include <caml/unixsupport.h>
#include <errno.h>
#include "lwt_unix.h"
struct job_bytes_read {
struct lwt_unix_job job;
/* The file descriptor. */
int fd;
/* The destination buffer. */
char *buffer;
/* The offset in the string. */
long offset;
/* The amount of data to read. */
long length;
/* The result of the read syscall. */
long result;
/* The value of errno. */
int error_code;
/* OCaml buffer. */
value ocaml_buffer;
};
static void worker_bytes_read(struct job_bytes_read *job)
{
job->result = read(job->fd, job->buffer, job->length);
job->error_code = errno;
}
static value result_bytes_read(struct job_bytes_read *job)
{
long result = job->result;
caml_remove_generational_global_root(&job->ocaml_buffer);
LWT_UNIX_CHECK_JOB(job, result < 0, "read");
lwt_unix_free_job(&job->job);
return Val_long(result);
}
CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buf,
value val_ofs, value val_len)
{
LWT_UNIX_INIT_JOB(job, bytes_read, 0);
job->fd = Int_val(val_fd);
job->buffer = (char *)Caml_ba_data_val(val_buf) + Long_val(val_ofs);
job->length = Long_val(val_len);
job->ocaml_buffer = val_buf;
caml_register_generational_global_root(&job->ocaml_buffer);
return lwt_unix_alloc_job(&(job->job));
}
#endif

30
unikernel/duniverse/lwt/src/unix/unix_c/unix_bytes_recv.c Normal file
View file

@ -0,0 +1,30 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if !defined(LWT_ON_WINDOWS)
#include <caml/alloc.h>
#include <caml/bigarray.h>
#include <caml/mlvalues.h>
#include <caml/unixsupport.h>
#include <sys/types.h>
#include <sys/socket.h>
#include "lwt_unix.h"
#include "unix_recv_send_utils.h"
value lwt_unix_bytes_recv(value fd, value buf, value ofs, value len,
value flags)
{
int ret;
ret =
recv(Int_val(fd), (char *)Caml_ba_array_val(buf)->data + Long_val(ofs),
Long_val(len), lwt_convert_flag_list(flags, msg_flag_table));
if (ret == -1) uerror("recv", Nothing);
return Val_int(ret);
}
#endif

41
unikernel/duniverse/lwt/src/unix/unix_c/unix_bytes_recvfrom.c Normal file
View file

@ -0,0 +1,41 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if !defined(LWT_ON_WINDOWS)
#include <caml/alloc.h>
#include <caml/bigarray.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
#include <caml/socketaddr.h>
#include <caml/unixsupport.h>
#include <sys/types.h>
#include <sys/socket.h>
#include "lwt_unix.h"
#include "unix_recv_send_utils.h"
value lwt_unix_bytes_recvfrom(value fd, value buf, value ofs, value len,
value flags)
{
CAMLparam5(fd, buf, ofs, len, flags);
CAMLlocal2(result, address);
int ret;
union sock_addr_union addr;
socklen_t addr_len;
addr_len = sizeof(addr);
ret = recvfrom(Int_val(fd), (char *)Caml_ba_data_val(buf) + Long_val(ofs),
Long_val(len), lwt_convert_flag_list(flags, msg_flag_table),
&addr.s_gen, &addr_len);
if (ret == -1) uerror("recvfrom", Nothing);
address = alloc_sockaddr(&addr, addr_len, -1);
result = caml_alloc_tuple(2);
Field(result, 0) = Val_int(ret);
Field(result, 1) = address;
CAMLreturn(result);
}
#endif

30
unikernel/duniverse/lwt/src/unix/unix_c/unix_bytes_send.c Normal file
View file

@ -0,0 +1,30 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if !defined(LWT_ON_WINDOWS)
#include <caml/alloc.h>
#include <caml/bigarray.h>
#include <caml/mlvalues.h>
#include <caml/unixsupport.h>
#include <sys/types.h>
#include <sys/socket.h>
#include "lwt_unix.h"
#include "unix_recv_send_utils.h"
value lwt_unix_bytes_send(value fd, value buf, value ofs, value len,
value flags)
{
int ret;
ret =
send(Int_val(fd), (char *)Caml_ba_array_val(buf)->data + Long_val(ofs),
Long_val(len), lwt_convert_flag_list(flags, msg_flag_table));
if (ret == -1) uerror("send", Nothing);
return Val_int(ret);
}
#endif

34
unikernel/duniverse/lwt/src/unix/unix_c/unix_bytes_sendto.c Normal file
View file

@ -0,0 +1,34 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if !defined(LWT_ON_WINDOWS)
#include <caml/alloc.h>
#include <caml/bigarray.h>
#include <caml/mlvalues.h>
#include <caml/socketaddr.h>
#include <caml/unixsupport.h>
#include <sys/types.h>
#include <sys/socket.h>
#include "lwt_unix.h"
#include "unix_recv_send_utils.h"
value lwt_unix_bytes_sendto(value fd, value buf, value ofs, value len,
value flags, value dest)
{
union sock_addr_union addr;
socklen_t addr_len;
int ret;
get_sockaddr(dest, &addr, &addr_len);
ret = sendto(Int_val(fd), (char *)Caml_ba_data_val(buf) + Long_val(ofs),
Long_val(len), lwt_convert_flag_list(flags, msg_flag_table),
&addr.s_gen, addr_len);
if (ret == -1) uerror("send", Nothing);
return Val_int(ret);
}
#endif

20
unikernel/duniverse/lwt/src/unix/unix_c/unix_bytes_sendto_byte.c Normal file
View file

@ -0,0 +1,20 @@
/* This file is part of Lwt, released under the MIT license. See LICENSE.md for
details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. */
#include "lwt_config.h"
#if !defined(LWT_ON_WINDOWS)
#include <caml/mlvalues.h>
extern value lwt_unix_bytes_sendto(value fd, value buf, value ofs, value len,
value flags, value dest);
CAMLprim value lwt_unix_bytes_sendto_byte(value *argv, int argc)
{
return lwt_unix_bytes_sendto(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5]);
}
#endif

Some files were not shown because too many files have changed in this diff Show more