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

49
unikernel/duniverse/base/.github/workflows/workflow.yml vendored Normal file
View file

@ -0,0 +1,49 @@
name: Main workflow
on:
pull_request:
push:
schedule:
- cron: '0 1 * * SAT'
concurrency:
group: ci-${{ github.ref }}
cancel-in-progress: true
jobs:
Tests:
strategy:
fail-fast: false
matrix:
os: [macos-latest, ubuntu-latest, windows-latest]
ocaml:
- ocaml-base-compiler.5.0.0~alpha0
- 4.14.0
include:
- {os: ubuntu-latest, ocaml: 4.13.1}
- {os: ubuntu-latest, ocaml: 4.12.1}
- {os: ubuntu-latest, ocaml: 4.11.2}
exclude:
- {os: windows-latest, ocaml: ocaml-base-compiler.5.0.0~alpha0}
runs-on: ${{ matrix.os }}
steps:
- name: Checkout code
uses: actions/checkout@v3
- name: Setup OCaml ${{ matrix.ocaml }}
uses: ocaml/setup-ocaml@v2
with:
cache-prefix: v1-${{ matrix.os }}-${{ matrix.ocaml }}
dune-cache: true
ocaml-compiler: ${{ matrix.ocaml }}
- name: Build dependencies
run: opam install . --deps-only --with-test
- name: Build library
run: opam exec -- dune build
- name: Run test suite
run: opam exec -- dune runtest

5
unikernel/duniverse/base/.gitignore vendored Normal file
View file

@ -0,0 +1,5 @@
_build
*.install
*.merlin
_opam

1
unikernel/duniverse/base/.ocamlformat Normal file
View file

@ -0,0 +1 @@
profile=janestreet

522
unikernel/duniverse/base/CHANGES.md Normal file
View file

@ -0,0 +1,522 @@
## Release v0.17.0
Added functionality:
* Add `String.to_sequence`
* Derive `equal` on `Set.Merge_with_duplicates_element.t`
* Add `Queue.drain`
* Add `Or_error.of_option`
* Extend `Hashtbl_intf.Hashtbl` with `capacity`, intended for testing resizing behavior
* Add `Nothing.must_be_*` functions discarding (parts of) inputs with `Nothing.t` as a
type parameter
* Add `Float.log2`
* Add `Random.bits64`, re-exported from `Stdlib.Random`
* Add `String.edit_distance` to compute Levenshtein distance between strings
* Add `Comparator.to_module` and `Comparator.of_module`, converting between `Comparator.t` and `Comparator.Module.t`
* Add `Map.sum`, `unzip`, `of_list_with_key_fold`, and `of_list_with_key_reduce`
* Add `Applicative.Ident`, similar to `Monad.Ident`
* Extend `Uniform_array` with more operations akin to `Array`
* Added `List.singleton`
* Add `Map.merge_disjoint_exn` for merging two disjoint maps of the same key/value types
Raises an exception if there are conflicting keys
* Added `Sequence.Expert.View` to consume sequences more flexibly and efficiently
* Add a `Binary` submodule to `Int`, `Int32`, etc, which provide `to_string` and
`sexp_of_t` with syntax matching the ocaml binary int literal syntax
* Add `List.stable_dedup` and deprecate `Set.stable_dedup_list`
* Add `Queue.enqueue_front` and `Queue.dequeue_back`
* Add `Type_equal.Id.Create*` functors for polymorphic types
Added unicode support:
* Added `Utf*` submodules to `Bytes`, `Uchar`, and `String`
* Types for `Uchar` and `String` encoding UTF-8, UTF-16LE, UTF-16BE, UTF-32LE, UTF32-BE
* Added conversions, read/write functions, etc
Changed behavior:
* `Info` has improved parsing of DOS newlines and trailing newlines in backtraces
Removed definitions that were previously deprecated:
* `Type_equal.equal` type alias now that destructive update is available
* `Map.comparator` and `Set.comparator` type aliases
* `Base.Popcount`, as it is exported via the various `Int*` modules
* `Option` functions from `Container` that are not useful
* `Result.ok_fst`, an alias for `to_either`
* `Sequence.merge`, an alias for `merge_deduped_and_sorted`
* `Info.to_string_hum_deprecated`
* `?trunc_after` flag to `Info.of_list`, no longer used
Deprecated:
* `Type_equal.Injective`, now that injectivity annotations exist
Removed without deprecating:
* `Type_equal.Id.Uid.to_string`, `of_string`, and `t_of_sexp`. These were not compatible
with the representation changes needed for the new `Id.Create*` functors
Interface changes:
* `Container.Generic` now supports two "extra" (non-element) type parameters
* Abstracted some of `Map` into `Dictionary_immutable` interfaces
* Abstracted some of `Hashtbl` into `Dictionary_mutable` interfaces
* Export `Set.Poly.set` type rather than using destructive update
Bug fixes:
* Indexing was wrong in `Sequence.findi`, now fixed and with a regression test
Performance improvements:
* Split up and refactored tests in `Base` to reduce build times
* Stop using exceptions for control, primarily to speed up `js_of_ocaml` versions. Affects
`Sequence.compare`, `String.index`, `String.rindex`, `String.index_from`,
`String.rindex_from`, `Map.change`, and `Map.remove`
* Unboxed `Int64.pow`
* Branchless implementation of `Float.clamp_unchecked`, `Int.clamp_unchecked`
* Branchless loop body in `Array.count` and `Array.counti`
* Remove allocation in `List.Assoc.find_exn`
* Reduce allocation of `With_return` under some compiler configurations
* Restore `Array.equal` to zero allocation
* Avoid boxing in `Int64.to_int_exn`, `Int64.hash_fold_t`, `Float.hash_fold_t`
* Inlining annotation on `Float.sign_exn` to avoid boxing
* Add `[@cold]` annotation to `Error.raise`
* Tighten up conditional logic in `Hashtbl.set` and `Hashtbl.remove`
* Reducing redundant computation in various `Map` functions
* Rewrite `Array.min_elt` and `Array.max_elt` to reduce branching and allocation
* Improve `ppx_hash` derived code for enumeration-like variants.
* Moved queue mutation check to a function marked `[@cold]`.
* Rewrite `List.dedup_and_sort` without a final remove-duplicates pass.
* Fix `Info` to avoid blowing up the stack on `force` of the internal `lazy`.
* Make `List.take`, `List.drop`, and `List.split` return the original list when possible.
(issue 153, thanks `@mroch`)
* Adapted `List` functions to take advantage of `[@tail_mod_cons]` where beneficial.
* Use `[@tail_mod_cons]` in `Sequence.to_list`
Refactoring:
* Update whitespace styling, primarily by no longer using ocp-indent on code
* Use `Stdlib.Sys.Immediate64` in `Int63` instead of hand-written copy
* Properly use loop variable in `List.chunks_of` helper
* Rename internal variable in `Hashtbl.remove` for clarity
* Lift some of `Int_conversions` to `Int_string_conversions` to share elsewhere
* Remove unused `[@tailcall]` attribute in `List.group`
* Use inlined records in `Map` and `Set` internal variant representations
* Reimplement `Map.Build_increasing` to something simpler
* Remove unnecessary helper in `Map.remove`
* Remove unused functions from `String0`
* Use inlining instead of duplication for helpers in `Set` implementation
* Split out `Ocaml_intrinsics_kernel`, used it for some intrinsics in `Base`
Documentation:
* Fix typo where `Set.union_list` documented itself as `union`
* Various grammar and capitalization fixes (PR 145, thanks `@goodship1`)
Tests and benchmarks, largely to gain confidence in the changes above:
* Updated allocation expect tests to actually use `let%expect_test` (oops)
* Updated benchmarks for `Float.clamp*`.
* Add benchmarks for `Hashtbl.map_inplace`, `create`, `remove`, `set`, `change`, and
`find_and_remove`
* Add benchmarks for `Map.set`, `remove`, and `change`
* Add `js_of_ocaml`-only benchmarks for `Map.remove` and `Map.change`
* Benchmark `Sequence.compare` and `String.index`
* Benchmark `Set.add`, `find`, and `find_map`
* Tests and benchmarks for `min_elt`, `max_elt`, `count`, and `counti` in `Array` and
`List`
Windows:
* Fixed the windows build. (PR 152, thanks `@hhugo`)
Work toward compatibility with OCaml 5.1:
* Update `Random` to use new splittable PRNG
* Other various changes
Improved support for compiler extensions found at https://github.com/ocaml-flambda/flambda-backend:
* Various updated signatures, definitions, and new functionality to support `local_` mode
and stack allocation
* Added annotations for `[@zero_alloc]` compiler checks
## Release v0.16.0
Changes across many modules:
* Replaced `Caml` with `Stdlib`. The `Caml` module predated `Stdlib` and has been
redundant for some time.
* Added support for local allocations. This is a nonstandard OCaml extension available at
<https://github.com/ocaml-flambda/ocaml-jst>.
Support includes:
- updating functions to accept `[@local]` arguments, especially closures
- local constructors, like `Array.create_local` and `Bytes.create_local`
- new versions of interfaces supporting `local` values, such as `Applicative.S_local`
- `[@@deriving globalize]` on some types, for converting local values to global values
* Rename `Polymorphic_compare` submodules to `Comparisons`. The former was a misnomer.
While the comparisons for a given type are meant to replace polymorphic compare
operators, they are not polymorphic themselves.
* Added `Container.S_with_creators` and `Indexed_container.S_with_creators`. Used these in
container modules such as `Array`, `List`, and `String`. These interfaces standardize
functions like `map` and `filter`. Along the way, refactored module types in `Container`
and `Indexed_container`.
* In signatures for `fold*` functions, renamed accumulator type variables to `'acc` for
improved readability.
* Added `of_string_opt` to `Int_intf.S`.
* Added `dequeue_and_ignore_exn` to `Queue_intf.S`.
Changes to individual modules:
* `Bool`: added `select`, a primitive using `CMOV` on architectures that support it.
* `Comparable`:
* Added `'a reversed` and `compare_reversed`, to support deriving inverted comparisons,
e.g.: `[%compare: My_type.t Comparable.reversed]`
* Added `Derived2_phantom`, similar to `Derived_phantom`.
* Made `Derived*.comparator_witness` types injective.
* `Float`:
* Added hyperbolic trig functions `acosh`, `asinh`, and `atanh` to `Float`.
* Added `Float.of_string_opt`.
* `Hash_set`: Made `t` injective.
* `Hashtbl`:
* Added `choose_randomly` and `choose_randomly_exn`.
* Made `Hashtbl.t` injective.
* `Lazy`: Added `peek`, extracting an already-forced value if present.
* `Map`:
* Added `split_le_gt`, `split_lt_ge`, and `transpose_keys`.
* Added `Make_applicative_traversals`, allowing some applicatives to improve performance
when operating on maps.
* Corrected documentation of performance for `filter*` functions.
* Refactored module types in `map_intf.ml`. Among other changes, propagated
`~comparator` argument slightly differently to allow expressing type of
`transpose_keys` properly.
* `Monad`: Documented performance characteristics of `Ident`.
* `Option`: Deprecated functions from `Container` but not particularly useful for options.
* `Ppx_compare_lib`: Removed primitive functions; `ppx_compare` now explicitly refers to
these via `Stdlib`.
* `Sequence`: Changed `Step.t` variant type to use inlined records.
* `Set`:
* Added `of_tree`, `to_tree`, `split_le_gt`, and `split_lt_ge`.
* Created a single shared `'a Named.t` type to `set_intf.ml`, rather than using a new type
in every instance of `Accessors`.
* Made `Set.t` injective in both type arguments.
* Refactored module types in `set_intf.ml`.
* `Sexpable`: `Of_stringable` now provides `t_sexp_grammar`.
* `Sign` and `Sign_or_nan`: Added `to_string_hum`.
* `Stack`: added `filter`, `filter_inplace`, and `filter_map`.
* `String`: added `concat_lines`, `pad_left`, `pad_right`, and `unsafe_sub`
* `Sys`: added `opaque_identity_global`, which forces its argument to be globally
allocated.
* `Type_equal`: `Id.Uid` now implements `Identifiable.S`
* `Uniform_array`: add `sort`
## Old pre-v0.15 changelogs (very likely stale and incomplete)
## git version
- Renamed `Result.ok_fst` to `Result.to_either` (old name remains as
deprecated alias). Added analogous `Result.of_either` function.
- Removed deprecated values `Array.truncate`, `{Obj_array,
Uniform_array}.unsafe_truncate`, `Result.ok_unit`, `{Result,
Or_error}.ignore`.
- Changed the signature of `Hashtbl.equal` to take the data equality
function first, allowing it to be used with `[%equal: t]`.
- Remove deprecated function `List.dedup`.
- Remove deprecated string mutation functions from the `String` module.
- Removed deprecated function `Monad.all_ignore` in favor of
`Monad.all_unit`.
- Deprecated `Or_error.ignore` and `Result.ignore` in favor of
`Or_error.ignore_m` and `Result.ignore_m`.
- `Ordered_collection_common.get_pos_len` now returns an `Or_error.t`
- Added `Bool.Non_short_circuiting`.
- Added `Float.square`.
- Remove module `Or_error.Ok`.
- module `Ref` doesn't implement `Container.S1` anymore.
- Rename parameter of `Sequence.merge` from `cmp` to `compare`.
- Added `Info.of_lazy_t`
- Added `List.partition_result` function, to partition a list of `Result.t`
values
- Changed the signature of `equal` from `'a t -> 'a t -> equal:('a -> 'a ->
bool) -> bool` to `('a -> 'a -> bool) -> 'a t -> 'a t -> bool`.
- Optimized `Lazy.compare` to check physical equality before forcing the lazy
values.
- Deprecated `Args` in the `Applicative` interface in favor of using `ppx_let`.
- Deprecated `Array.replace arr i ~f` in favor of using `arr.(i) <- (f (arr.(i)))`
- Rename collection length parameter of `Ordered_collection_common` functions
from `length` to `total_length`, and add a unit argument to `get_pos_len` and
`get_pos_len_exn`.
- Removed functions that were deprecated in 2016 from the `Array` and `Set`
modules.
- `Int.Hex.of_string` and friends no longer silently ignore a suffix
of non-hexadecimal garbage.
- Added `?backtrace` argument to `Or_error.of_exn_result`.
- `List.zip` now returns a `List.Or_unequal_lengths.t` instead of an `option`.
- Remove functions from the `Sequence` module that were deprecated in 2015.
- `Container.Make` and `Container.Make0` now require callers to either provide a
custom `length` function or request that one be derived from `fold`.
`Container.to_array`'s signature is also changed to accept `length` and `iter`
instead of `fold`.
- Exposed module `Int_math`.
## v0.11
- Deprecated `Not_found`, people who need it can use `Caml.Not_found`, but its
use isn't recommended.
- Added the `Sexp.Not_found_s` exception which will replace `Caml.Not_found` as
the default exception in a future release.
- Document that `Array.find_exn`, `Array.find_map_exn`, and `Array.findi_exn`
may throw `Caml.Not_found` _or_ `Not_found_s`.
- Document that `Hashtbl.find_exn` may throw `Caml.Not_found` _or_
`Not_found_s`.
- Document that `List.find_exn`, and `List.find_map_exn` may throw
`Caml.Not_found` _or_ `Not_found_s`.
- Document that `List.find_exn` may throw `Caml.Not_found` _or_ `Not_found_s`.
- Document that `String.lsplit2_exn`, and `String.rsplit2_exn` may throw
`Caml.Not_found` _or_ `Not_found_s`.
- Added `Sys.backend_type`.
- Removed unnecessary unit argument from `Hashtbl.create`.
- Removed deprecated operations from `Hashtbl`.
- Removed `Hashable.t` constructors from `Hashtbl` and `Hash_set`, instead
favoring the first-class module constructors.
- Removed `Container` operations from `Either.First` and `Either.Second`.
- Changed the type of `fold_until` in the `Container` interfaces. Rather than
returning a `Finished_or_stopped_early.t` (which has also been removed), the
function now takes a `finish` function that will be applied the result if `f`
never returned a `Stop _`.
- Removed the `String_dict` module.
- Added a `Queue` module that is backed by an `Option_array` for efficient and
(non-allocating) implementations of most operations.
- Added a `Poly` submodule to `Map` and `Set` that exposes constructors that
use polymorphic compare.
- Deprecated `all_ignore` in the `Monad` and `Applicative` interfaces in favor
of `all_unit`.
- Deprecated `Array.replace_all` in favor of `Array.map_inplace`, which is the
standard name for that sort of operation within Base.
- Document that `List.find_exn`, and `List.find_map_exn` may throw
`Caml.Not_found` _or_ `Not_found_s`.
- Make `~compare` a required argument to `List.dedup_and_sort`, `List.dedup`,
`List.find_a_dup`, `List.contains_dup`, and `List.find_all_dups`.
- Removed `List.exn_if_dup`. It is still available in core_kernel.
- Removed "normalized" index operation `List.slice`. It is still available in
core_kernel.
- Remove "normalized" index operations from `Array`, which incluced
`Array.normalize`, `Array.slice`, `Array.nget` and `Array.nset`. These
operations are still available in core_kernel.
- Added `Uniform_array` module that is just like an `Array` except guarantees
that the representation array is not tagged with `Double_array_tag`, the tag
for float arrays.
- Added `Option_array` module that allows for a compact representation of `'a
optoin array`, which avoids allocating heap objects representing `Some a`.
- Remove "normalized" index operations from `String`, which incluced
`String.normalize`, `String.slice`, `String.nget` and `String.nset`. These
operations are still available in core_kernel.
- Added missing conversions between `Int63` and other integer types,
specifically, the versions that return options.
- Added truncating versions of integer conversions, with a suffix of
`_trunc`. These allow fast conversions via bit arithmetic without
any conditional failure; excess bits beyond the width of the output
type are simply dropped.
- Added `Sequence.group`, similar to `List.group`.
- Reimplemented `String.Caseless.compare` so that it does not
allocate.
- Added `String.is_substring_at string ~pos ~substring`. Used it as
back-end for `is_suffix` and `is_prefix`.
- Moved all remaining `Replace_polymorphic_compare` submodules from Base
types and consolidated them in one place within `Import0`.
- Removed `(<=.)` and its friends.
- Added `Sys.argv`.
- Added a infix exponentation operator for int.
- Added a `Formatter` module to reexport the `Format.formatter` type and updated
the deprecation message for `Format`.
## v0.10
(Changes that can break existing programs are marked with a "\*")
### Bugfixes
- Generalized the type of `Printf.ifprintf` to reflect OCaml's stdlib.
- Made `Sequence.fold_m` and `iter_m` respect `Skip` steps and explicitly bind
when they occur.
- Changed `Float.is_negative` and `is_non_positive` on `NaN` to return `false`
rather than `true`.
- Fixed the `Validate.protect` function, which was mistakenly raising exceptions.
### API changes
- Renamed `Map.add` as `set`, and deprecated `add`. A later feature will add
`add` and `add_exn` in the style of `Hashtbl`.
- A different hash function is used to implement `Base.Int.hash`.
The old implementation was `Int.abs` but collision resistance is not enough,
we want avalanching as well.
The new function is an adaptation of one of the
[Thomas Wang](http://web.archive.org/web/20071223173210/http://www.concentric.net/~Ttwang/tech/inthash.htm)
hash functions to OCaml (63-bit integers), which results in reasonably good avalanching.
- Made `open Base` expose infix float operators (+., -., etc.).
* Renamed `List.dedup` to `List.dedup_and_sort`, to better reflect its existing behavior.
- Added `Hashtbl.find_multi` and `Map.find_multi`.
- Added function `Map.of_increasing_sequence` for constructing a `Map.t` from an
ordered `Sequence.t`
- Added function `List.chunks_of : 'a t -> length : int -> 'a t t`, for breaking
a list into chunks of equal length.
- Add to module `Random` numeric functions that take upper and lower inclusive
bounds, e.g. `Random.int_incl : int -> int -> int`.
* Replaced `Exn.Never_elide_backtrace` with `Backtrace.elide`, a `ref` cell that
determines whether `Backtrace.to_string` and `Backtrace.sexp_of_t` elide
backtraces.
- Exposed infix operator `Base.( @@ )`.
- Exposed modules `Base.Continue_or_stop` and `Finished_or_stopped_early`, used
with the `Container.fold_until` function.
- Exposed module types Base.T, T1, T2, and T3.
- Added `Sequence.Expert` functions `next_step` and
`delayed_fold_step`, for clients that want to explicitly handle `Skip` steps.
- Added `Bytes` module.
This includes the submodules `From_string` and `To_string` with blit
functions.
N.B. the signature (and name) of `unsafe_to_string` and `unsafe_of_string` are
different from the one in the standard library (and hopefully more explicit).
- Add bytes functions to `Buffer`.
Also added `Buffer.content_bytes`, the analog of `contents` but that returns
`bytes` rather than `string`.
* Enabled `-safe-string`.
- Added function `Int63.of_int32`, which was missing.
* Deprecated a number of `String` mutating functions.
- Added module `Obj_array`, moved in from `Core_kernel`.
* In module type `Hashtbl.Accessors`, removed deprecated functions, moving them
into a new module type, `Deprecated`.
- Exported `sexp_*` types that are recognized by `ppx_sexp_*` converters:
`sexp_array`, `sexp_list`, `sexp_opaque`, `sexp_option`.
* Reworked the `Or_error` module's interface, moving the `Container.S` interface
to an `Ok` submodule, and adding functions `is_ok`, `is_error`, and `ok` to
more closely resemble the interface of the `Result` module.
- Removed `Int.O.of_int_exn`.
- Exposed `Base.force` function.
- Changed the deprecation warning for `mod` to recommend `( % )` rather than
`Caml.( mod )`.
### Performance related changes
- Optimized `List.compare`, removing its closure allocation.
- Optimized `String.mem` to not allocate.
- Optimized `Float.is_negative`, `is_non_negative`, `is_positive`, and
`is_non_positive` to avoid some boxing.
- Changed `Hashtbl.merge` to relax its equality check on the input tables'
`Hashable.t` records, checking physical equality componentwise if the records
aren't physically equal.
- Added `Result.combine_errors`, similar to `Or_error.combine_errors`, with a
slightly different type.
- Added `Result.combine_errors_unit`, similar to `Or_error.combine_errors_unit`.
- Optimized the `With_return.return` type by adding the `[@@unboxed]` attribute.
- Improved a number of deprecation warnings.
## v0.9
Initial release.

67
unikernel/duniverse/base/CONTRIBUTING.md Normal file
View file

@ -0,0 +1,67 @@
This repository contains open source software that is developed and
maintained by [Jane Street][js].
Contributions to this project are welcome and should be submitted via
GitHub pull requests.
Signing contributions
---------------------
We require that you sign your contributions. Your signature certifies
that you wrote the patch or otherwise have the right to pass it on as
an open-source patch. The rules are pretty simple: if you can certify
the below (from [developercertificate.org][dco]):
```
Developer Certificate of Origin
Version 1.1
Copyright (C) 2004, 2006 The Linux Foundation and its contributors.
1 Letterman Drive
Suite D4700
San Francisco, CA, 94129
Everyone is permitted to copy and distribute verbatim copies of this
license document, but changing it is not allowed.
Developer's Certificate of Origin 1.1
By making a contribution to this project, I certify that:
(a) The contribution was created in whole or in part by me and I
have the right to submit it under the open source license
indicated in the file; or
(b) The contribution is based upon previous work that, to the best
of my knowledge, is covered under an appropriate open source
license and I have the right under that license to submit that
work with modifications, whether created in whole or in part
by me, under the same open source license (unless I am
permitted to submit under a different license), as indicated
in the file; or
(c) The contribution was provided directly to me by some other
person who certified (a), (b) or (c) and I have not modified
it.
(d) I understand and agree that this project and the contribution
are public and that a record of the contribution (including all
personal information I submit with it, including my sign-off) is
maintained indefinitely and may be redistributed consistent with
this project or the open source license(s) involved.
```
Then you just add a line to every git commit message:
```
Signed-off-by: Joe Smith <joe.smith@email.com>
```
Use your real name (sorry, no pseudonyms or anonymous contributions.)
If you set your `user.name` and `user.email` git configs, you can sign
your commit automatically with git commit -s.
[dco]: http://developercertificate.org/
[js]: https://opensource.janestreet.com/

21
unikernel/duniverse/base/LICENSE.md Normal file
View file

@ -0,0 +1,21 @@
The MIT License
Copyright (c) 2016--2024 Jane Street Group, LLC <opensource-contacts@janestreet.com>
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.

17
unikernel/duniverse/base/Makefile Normal file
View file

@ -0,0 +1,17 @@
INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
default:
dune build
install:
dune install $(INSTALL_ARGS)
uninstall:
dune uninstall $(INSTALL_ARGS)
reinstall: uninstall install
clean:
dune clean
.PHONY: default install uninstall reinstall clean

212
unikernel/duniverse/base/README.org Normal file
View file

@ -0,0 +1,212 @@
* Base
[[https://github.com/janestreet/base/actions][https://github.com/janestreet/base/actions/workflows/workflow.yml/badge.svg]]
Base is a standard library for OCaml. It provides a standard set of
general purpose modules that are well-tested, performant, and
fully-portable across any environment that can run OCaml code. Unlike
other standard library projects, Base is meant to be used as a
wholesale replacement of the standard library distributed with the
OCaml compiler. In particular it makes different choices and doesn't
re-export features that are not fully portable such as I/O, which are
left to other libraries.
You also might want to browse the [[https://ocaml.janestreet.com/ocaml-core/latest/doc/base/index.html][API Documentation]].
** Installation
Install Base via [[https://opam.ocaml.org][OPAM]]:
#+begin_src
$ opam install base
#+end_src
Base has no runtime dependencies and is fast to build. Its sole build
dependencies are [[https://github.com/ocaml/dune][dune]], which itself requires nothing more than the
compiler, and [[https://github.com/janestreet/sexplib0][sexplib0]].
** Using the OCaml standard library with Base
Base is intended as a full stdlib replacement. As a result, after an
=open Base=, all the modules, values, types, ... coming from the OCaml
standard library that one normally gets in the default environment are
deprecated.
In order to access these values, one must use the =Stdlib= library,
which re-exports them all through the toplevel name =Stdlib=:
=Stdlib.String=, =Stdlib.print_string=, ...
** Differences between Base and the OCaml standard library
Programmers who are used to the OCaml standard library should read
through this section to understand major differences between the two
libraries that one should be aware of when switching to Base.
*** Comparison operators
The comparison operators exposed by the OCaml standard library are
polymorphic:
#+begin_src ocaml
val compare : 'a -> 'a -> int
val ( <= ) : 'a -> 'a -> bool
...
#+end_src
What they implement is structural comparison of the runtime
representation of values. Since these are often error-prone,
i.e. they don't correspond to what the user expects, they are not
exposed directly by Base.
To use polymorphic comparison with Base, one should use the =Poly=
module. The default comparison operators exposed by Base are the
integer ones, just like the default arithmetic operators are the
integer ones.
The recommended way to compare arbitrary complex data structures is to
use the specific =compare= functions. For instance:
#+begin_src ocaml
List.compare String.compare x y
#+end_src
The [[https://github.com/janestreet/ppx_compare][ppx_compare]] rewriter
offers an alternative way to write this:
#+begin_src ocaml
[%compare: string list] x y
#+end_src
** Base and ppx code generators
Base uses a few ppx code generators to implement:
- Reliable and customizable comparison of OCaml values.
- Reliable and customizable hash of OCaml values.
- Conversions between OCaml values and s-expression.
However, it doesn't need these code generators to build. What it does
instead is use ppx as a code verification tool during development. It
works in a very similar fashion to
[[https://github.com/janestreet/ppx_expect][expectation tests]].
Whenever you see this in the code source:
#+begin_src ocaml
type t = ... [@@deriving_inline sexp_of]
let sexp_of_t = ...
[@@@end]
#+end_src
the code between the =[@@deriving_inline]= and the =[@@@end]= is
generated code. The generated code is currently quite big and hard to
read, however we are working on making it look like human-written
code.
You can put the following elisp code in your =~/.emacs= file to hide
these blocks:
#+begin_src scheme
(defun deriving-inline-forward-sexp (&optional arg)
(search-forward-regexp "\\[@@@end\\]") nil nil arg)
(defun setup-hide-deriving-inline ()
(inline)
(hs-minor-mode t)
(let ((hs-hide-comments-when-hiding-all nil))
(hs-hide-all)))
(require 'hideshow)
(add-to-list 'hs-special-modes-alist
'(tuareg-mode "\\[@@deriving_inline[^]]*\\]" "\\[@@@end\\]" nil
deriving-inline-forward-sexp nil))
(add-hook 'tuareg-mode-hook 'setup-hide-deriving-inline)
#+end_src
Things are not yet setup in the git repository to make it convenient
to change types and update the generated code, but they will be setup
soon.
** Base coding rules
There are a few coding rules across the code base that are enforced by
lint tools.
These rules are:
- Opening the =Stdlib= module is not allowed. Inside Base, the OCaml
stdlib is shadowed and accessible through the =Stdlib= module. We
forbid opening =Stdlib= so that we know exactly where things come
from.
- =Stdlib.Foo= modules cannot be aliased, one must use =Stdlib.Foo=
explicitly. This is to avoid having to remember a list of aliases
at the beginning of each file.
- For some modules that are both in the OCaml stdlib and Base, such as
=String=, we define a module =String0= for common functions that
cannot be defined directly in =Base.String= to avoid creating a
circular dependency. Except for =String= itself, other modules
are not allowed to use =Stdlib.String= and must use either =String= or
=String0= instead.
- Indentation is exactly the one of =ocp-indent=.
- A few other coding style rules enforced by
[[https://github.com/janestreet/ppx_js_style][ppx_js_style]].
The Base specific coding rules are checked by =ppx_base_lint=, in the
=lint= subfolder. The indentation rules are checked by a wrapper around
=ocp-indent= and the coding style rules are checked by =ppx_js_style=.
These checks are currently not run by =dune=, but it will soon get a
=-dev= flag to run them automatically.
** Sexp (de-)serializers
Most types in Base have ~sexp_of_t~ and ~t_of_sexp~ functions for converting
between values of that type and their sexp representations.
One pair of functions deserves special attention: ~String.sexp_of_t~ and
~String.t_of_sexp~. These functions have the same types as ~Sexp.of_string~ and
~Sexp.to_string~ but very different behavior.
~String.sexp_of_t~ and ~String.t_of_sexp~ are used to encode and decode strings
"embedded" in a sexp representation. On the other hand, ~Sexp.of_string~ and
~Sexp.to_string~ are used to encode and decode the textual form of
s-expressions.
The following example demonstrates the two pairs of functions in action:
#+begin_src ocaml
open! Base
open! Stdio
(* Embed a string in a sexp *)
let example_sexp : Sexp.t = List.sexp_of_t String.sexp_of_t [ "hello"; "world" ]
let () =
assert (Sexp.equal example_sexp (Sexp.List [ Sexp.Atom "hello"; Sexp.Atom "world" ]))
;;
let () =
assert (
List.equal
String.equal
[ "hello"; "world" ]
(List.t_of_sexp String.t_of_sexp example_sexp))
;;
(* Embed a sexp in text (string) *)
let write_sexp_to_file sexp =
Out_channel.write_all "/tmp/file" ~data:(Sexp.to_string example_sexp)
;;
(* /tmp/file now contains:
{v
(hello world)
v} *)
let () =
assert (Sexp.equal example_sexp (Sexp.of_string (In_channel.read_all "/tmp/file")))
;;
#+end_src

112
unikernel/duniverse/base/ROADMAP.md Normal file
View file

@ -0,0 +1,112 @@
# Stable Interface (v1.0)
- [X] Make the entire library `-safe-string` compliant. This will involve
introducing a `Bytes` module, removing all direct mutation on strings from
the `String` module, and "re-typing" string values that require mutation to
`bytes`.
- [X] Do not export the `\*\_intf` modules from Base. Instead, any signatures
should be exported by the `.ml` and `.mli`s.
- [X] Only expose the first-class module interface of `Hashtbl`. Accompanying
this should be cleanup of `Hashtbl_intf`, moving anything that's still
required in core_kernel to the appropriate files in that project.
- [X] Replace `Hashtbl.create (module String) ()` by just
`Hashtbl.create (module String)`
- [X] Remove `replace` from `Hashtbl_intf.Accessors`.
- [X] Label one of the arguments of `Hashtbl_intf.merge_into` to indicate the
flow of data.
- [X] Merge `Hashtbl_intf.Key_common` and `Hashtbl_intf.Key_plain`.
- [X] Use `Either.t` as the return value for `Map.partition`.
- [X] Rename `Monad_intf.all_ignore` to `Monad_intf.all_unit`.
- [ ] Eliminate all uses of `Not_found`, replacing them with descriptive error messages.
- [X] Move the various private modules to `Base.Base_private`
instead of `Base.Exported_for_specific_uses` and `Base.Not_exposed_properly`
- [X] Use `compare` rather than `cmp` as the label for comparison functions
throughout.
# Implementation Cleanup
- [ ] Remove `ignore` and `(=)` from `Sexp_conv`'s public interface. These
values are hidden from the documentation so their removal won't be
considered a breaking API change.
- [ ] Do not expose the type equality `Int63_emul.W.t = int64`.
- [ ] Replace the exception thrown by `Float.of_string` with a named
exception that's more descriptive.
- [X] Delete the `Hashable` toplevel module. This is a vestige of the previous
`Map` and `Set` implementations and is no longer needed.
- [ ] Ensure that `Map` operations that are effective NO-OPs return the same
`Map.t` they were provided. Candidate operations include e.g `add`, `remove`,
`filter`.
- [ ] Simplify the implementation of `Option.value_exn`, if possible.
- [ ] Eliminate all instances of `open! Polymorphic_compare`
- [ ] Refactor common blit code in `String.replace_all` and `String.replace_first`.
- [ ] Delete unused function aliases in `Import0`
- [ ] Put `Sexp_conv.Exn_converter` into its own file, with only an
alias in Sexp_conv, so that it doesn't get pulled unless used
- [ ] Create a file with all the basic types and their associated
combinators (`sexp_of_t`, `compare`, `hash`), and expose the
declaration
- [ ] Put all the exported private modules from
`Base.Exported_for_specific_uses` and `Base.Not_exposed_properly`
in `Base.Base_private`
- [ ] Decide on a better name for `Polymorphic_compare`.
`Polymorphic_compare_intf` contains interface for comparison
of non-polymorphic types, which is weird. Get rid of it and
inline things in `Comparable_intf`
- [X] `hashtbl_of_sexp` shouldn't live in Base.Sexp_conv since we
have our own hash tables. Move it to sexplib
# Performance Improvements
- [ ] In `Hash_set.diff`, use the size of each set to determine which to iterate
over.
- [ ] Ensure that the correct `compare` function and other related functions are
exported by all modules. These functions should not be derived from
a functor application, in order to ensure proper inlining. Implementing
this change should also include benchmarks to verify the initial result,
and to maintain it on an ongoing basis. See `bench/bench_int.ml` for
examples.
- [X] Optimize `Lazy.compare` by performing a `phys_equal` check before
forcing the lazy value. Note that this will also change the semantics of
`compare` and should be documented and rolled out with care.
- [ ] Conduct a thorough performance review of the `Sequence` module.
# Documentation
- [ ] Consolidate documentation the interface and implementation files
related to the `Hash` module.
- [ ] Add documentation to the `Ref` toplevel module.
- [ ] Document properly how `String.unescape_gen` handles malformed strings
# Changes For The Distant Future
- [ ] Make the various comparison functions return an `Ordering.t`
instead of an `int`.

35
unikernel/duniverse/base/base.opam Normal file
View file

@ -0,0 +1,35 @@
opam-version: "2.0"
version: "v0.17.3"
maintainer: "Jane Street developers"
authors: ["Jane Street Group, LLC"]
homepage: "https://github.com/janestreet/base"
bug-reports: "https://github.com/janestreet/base/issues"
dev-repo: "git+https://github.com/janestreet/base.git"
doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/base/index.html"
license: "MIT"
build: [
["dune" "build" "-p" name "-j" jobs]
]
depends: [
"ocaml" {>= "5.1.0"}
"ocaml_intrinsics_kernel" {>= "v0.17.0" & < "v0.18.0"}
"sexplib0" {>= "v0.17.0" & < "v0.18.0"}
"dune" {>= "3.11.0"}
"dune-configurator"
]
available: arch != "arm32" & arch != "x86_32"
synopsis: "Full standard library replacement for OCaml"
description: "
Full standard library replacement for OCaml
Base is a complete and portable alternative to the OCaml standard
library. It provides all standard functionalities one would expect
from a language standard library. It uses consistent conventions
across all of its module.
Base aims to be usable in any context. As a result system dependent
features such as I/O are not offered by Base. They are instead
provided by companion libraries such as stdio:
https://github.com/janestreet/stdio
"

1
unikernel/duniverse/base/dune-project Normal file
View file

@ -0,0 +1 @@
(lang dune 3.11)

5
unikernel/duniverse/base/generate/dune Normal file
View file

@ -0,0 +1,5 @@
(executables
(modes byte exe)
(names generate_pow_overflow_bounds)
(libraries num)
(preprocess no_preprocessing))

194
unikernel/duniverse/base/generate/generate_pow_overflow_bounds.ml Normal file
View file

@ -0,0 +1,194 @@
(* NB: This needs to be pure OCaml (no Base!), since we need this in order to build
Base. *)
(* This module generates lookup tables to detect integer overflow when calculating integer
exponents. At index [e], [table.[e]^e] will not overflow, but [(table[e] + 1)^e]
will. *)
type mode =
| Normal
| Atomic of
{ out_fn : string
; tmp_fn : string
}
let oc, mode =
match Sys.argv with
| [| _ |] -> stdout, Normal
| [| _; "-o"; out_fn |] | [| _; "-atomic"; "-o"; out_fn |] ->
(* Always produce the file atomically, we just have this option to remember that we
need to do it *)
let tmp_fn, oc =
Filename.open_temp_file
~temp_dir:(Filename.dirname out_fn)
"generate_pow_overflow_bounds"
".ml.tmp"
in
oc, Atomic { out_fn; tmp_fn }
| _ -> failwith "bad command line arguments"
;;
module Big_int = struct
include Big_int
let ( > ) = gt_big_int
let ( <= ) = le_big_int
let ( ^ ) = power_big_int_positive_int
let ( - ) = sub_big_int
let ( + ) = add_big_int
let one = unit_big_int
let sqrt = sqrt_big_int
let to_string = string_of_big_int
end
module Array = StdLabels.Array
type generated_type =
| Int
| Int32
| Int63
| Int64
let max_big_int_for_bits bits =
let shift = bits - 1 in
(* sign bit *)
Big_int.(shift_left_big_int one shift - one)
;;
let safe_to_print_as_int =
let int31_max = max_big_int_for_bits 31 in
fun x -> Big_int.(x <= int31_max)
;;
let format_entry typ b =
let s = Big_int.to_string b in
match typ with
| Int ->
if safe_to_print_as_int b then s else Printf.sprintf "Stdlib.Int64.to_int %sL" s
| Int32 -> s ^ "l"
| Int63 | Int64 -> s ^ "L"
;;
let bits = function
| Int -> assert false (* architecture dependent *)
| Int32 -> 32
| Int63 -> 63
| Int64 -> 64
;;
let max_val typ = max_big_int_for_bits (bits typ)
let name = function
| Int -> "int"
| Int32 -> "int32"
| Int63 -> "int63_on_int64"
| Int64 -> "int64"
;;
let ocaml_type_name = function
| Int -> "int"
| Int32 -> "int32"
| Int63 | Int64 -> "int64"
;;
let generate_negative_bounds = function
| Int -> false
| Int32 -> false
| Int63 -> false
| Int64 -> true
;;
let highest_base exponent max_val =
let open Big_int in
match exponent with
| 0 | 1 -> max_val
| 2 -> sqrt max_val
| _ ->
let rec search possible_base =
if possible_base ^ exponent > max_val
then (
let res = possible_base - one in
assert (res ^ exponent <= max_val);
res)
else search (possible_base + one)
in
search one
;;
type sign =
| Pos
| Neg
let pr fmt = Printf.fprintf oc (fmt ^^ "\n")
let gen_array ~typ ~bits ~sign ~indent =
let pr fmt = pr ("%*s" ^^ fmt) indent "" in
let max_val = max_big_int_for_bits bits in
let pos_bounds = Array.init 64 ~f:(fun i -> highest_base i max_val) in
let bounds =
match sign with
| Pos -> pos_bounds
| Neg -> Array.map pos_bounds ~f:Big_int.minus_big_int
in
pr "[| %s" (format_entry typ bounds.(0));
for i = 1 to Array.length bounds - 1 do
pr "; %s" (format_entry typ bounds.(i))
done;
pr "|]"
;;
let gen_bounds typ =
pr "let overflow_bound_max_%s_value : %s =" (name typ) (ocaml_type_name typ);
(match typ with
| Int -> pr " (-1) lsr 1"
| _ -> pr " %s" (format_entry typ (max_val typ)));
pr "";
let array_name typ sign =
Printf.sprintf
"%s_%s_overflow_bounds"
(name typ)
(match sign with
| Pos -> "positive"
| Neg -> "negative")
in
pr "let %s : %s array =" (array_name typ Pos) (ocaml_type_name typ);
(match typ with
| Int ->
pr " match Int_conversions.num_bits_int with";
pr " | 32 -> Array.map %s ~f:Stdlib.Int32.to_int" (array_name Int32 Pos);
pr " | 63 ->";
gen_array ~typ ~bits:63 ~sign:Pos ~indent:4;
pr " | 31 ->";
gen_array ~typ ~bits:31 ~sign:Pos ~indent:4;
pr " | _ -> assert false"
| _ -> gen_array ~typ ~bits:(bits typ) ~sign:Pos ~indent:2);
pr "";
if generate_negative_bounds typ
then (
pr "let %s : %s array =" (array_name typ Neg) (ocaml_type_name typ);
gen_array ~typ ~bits:(bits typ) ~sign:Neg ~indent:2)
;;
let () =
pr "(* This file was autogenerated by %s *)" Sys.argv.(0);
pr "";
pr "open! Import";
pr "";
pr "module Array = Array0";
pr "";
pr "(* We have to use Int64.to_int_exn instead of int constants to make";
pr " sure that file can be preprocessed on 32-bit machines. *)";
pr "";
gen_bounds Int32;
gen_bounds Int;
gen_bounds Int63;
gen_bounds Int64
;;
let () =
match mode with
| Normal -> ()
| Atomic { tmp_fn; out_fn } ->
close_out oc;
Sys.rename tmp_fn out_fn
;;

1
unikernel/duniverse/base/generate/generate_pow_overflow_bounds.mli Normal file
View file

@ -0,0 +1 @@
(*_ This signature is deliberately empty. *)

4
unikernel/duniverse/base/hash_types/README.org Normal file
View file

@ -0,0 +1,4 @@
#+TITLE: Base_internalhash_types
This micro-library allows hash states, seeds, and values to be type-equal
between ~Base~ and ~Base_boot~.

30
unikernel/duniverse/base/hash_types/src/base_internalhash_types.ml Normal file
View file

@ -0,0 +1,30 @@
(** [state] is defined as a subtype of [int] using the [private] keyword. This makes it an
opaque type for most purposes, and tells the compiler that the type is immediate. *)
type state = private int
type seed = int
type hash_value = int
external create_seeded : seed -> state = "%identity" [@@noalloc]
external fold_int64
: state
-> (int64[@unboxed])
-> state
= "Base_internalhash_fold_int64" "Base_internalhash_fold_int64_unboxed"
[@@noalloc]
external fold_int : state -> int -> state = "Base_internalhash_fold_int" [@@noalloc]
external fold_float
: state
-> (float[@unboxed])
-> state
= "Base_internalhash_fold_float" "Base_internalhash_fold_float_unboxed"
[@@noalloc]
external fold_string : state -> string -> state = "Base_internalhash_fold_string"
[@@noalloc]
external get_hash_value : state -> hash_value = "Base_internalhash_get_hash_value"
[@@noalloc]

11
unikernel/duniverse/base/hash_types/src/dune Normal file
View file

@ -0,0 +1,11 @@
(library
(foreign_stubs
(language c)
(names internalhash_stubs))
(name base_internalhash_types)
(public_name base.base_internalhash_types)
(libraries)
(preprocess no_preprocessing)
(js_of_ocaml
(javascript_files runtime.js))
(install_c_headers internalhash))

3
unikernel/duniverse/base/hash_types/src/internalhash.h Normal file
View file

@ -0,0 +1,3 @@
#include <stdint.h>
#include <caml/mlvalues.h>
CAMLexport uint32_t Base_internalhash_fold_blob(uint32_t h, mlsize_t len, uint8_t *s);

111
unikernel/duniverse/base/hash_types/src/internalhash_stubs.c Normal file
View file

@ -0,0 +1,111 @@
#include <stdint.h>
#include <caml/mlvalues.h>
#include <caml/hash.h>
#include "internalhash.h"
/* This pretends that the state of the OCaml internal hash function, which is an
int32, is actually stored in an OCaml int. */
CAMLprim value Base_internalhash_fold_int32(value st, value i)
{
return Val_long(caml_hash_mix_uint32(Long_val(st), Int32_val(i)));
}
CAMLprim value Base_internalhash_fold_nativeint(value st, value i)
{
return Val_long(caml_hash_mix_intnat(Long_val(st), Nativeint_val(i)));
}
CAMLprim value Base_internalhash_fold_int64(value st, value i)
{
return Val_long(caml_hash_mix_int64(Long_val(st), Int64_val(i)));
}
CAMLprim value Base_internalhash_fold_int64_unboxed(value st, int64_t i)
{
return Val_long(caml_hash_mix_int64(Long_val(st), i));
}
CAMLprim value Base_internalhash_fold_int(value st, value i)
{
return Val_long(caml_hash_mix_intnat(Long_val(st), Long_val(i)));
}
CAMLprim value Base_internalhash_fold_float(value st, value i)
{
return Val_long(caml_hash_mix_double(Long_val(st), Double_val(i)));
}
CAMLprim value Base_internalhash_fold_float_unboxed(value st, double i)
{
return Val_long(caml_hash_mix_double(Long_val(st), i));
}
/* This code mimics what hashtbl.hash does in OCaml's hash.c */
#define FINAL_MIX(h) \
h ^= h >> 16; \
h *= 0x85ebca6b; \
h ^= h >> 13; \
h *= 0xc2b2ae35; \
h ^= h >> 16;
CAMLprim value Base_internalhash_get_hash_value(value st)
{
uint32_t h = Int_val(st);
FINAL_MIX(h);
return Val_int(h & 0x3FFFFFFFU); /*30 bits*/
}
/* Macros copied from hash.c in ocaml distribution */
#define ROTL32(x,n) ((x) << n | (x) >> (32-n))
#define MIX(h,d) \
d *= 0xcc9e2d51; \
d = ROTL32(d, 15); \
d *= 0x1b873593; \
h ^= d; \
h = ROTL32(h, 13); \
h = h * 5 + 0xe6546b64;
/* Version of [caml_hash_mix_string] from hash.c - adapted for arbitrary char arrays */
CAMLexport uint32_t Base_internalhash_fold_blob(uint32_t h, mlsize_t len, uint8_t *s)
{
mlsize_t i;
uint32_t w;
/* Mix by 32-bit blocks (little-endian) */
for (i = 0; i + 4 <= len; i += 4) {
#ifdef ARCH_BIG_ENDIAN
w = s[i]
| (s[i+1] << 8)
| (s[i+2] << 16)
| (s[i+3] << 24);
#else
w = *((uint32_t *) &(s[i]));
#endif
MIX(h, w);
}
/* Finish with up to 3 bytes */
w = 0;
switch (len & 3) {
case 3: w = s[i+2] << 16; /* fallthrough */
case 2: w |= s[i+1] << 8; /* fallthrough */
case 1: w |= s[i];
MIX(h, w);
default: /*skip*/; /* len & 3 == 0, no extra bytes, do nothing */
}
/* Finally, mix in the length. Ignore the upper 32 bits, generally 0. */
h ^= (uint32_t) len;
return h;
}
CAMLprim value Base_internalhash_fold_string(value st, value v_str)
{
uint32_t h = Long_val(st);
mlsize_t len = caml_string_length(v_str);
uint8_t *s = (uint8_t *) String_val(v_str);
h = Base_internalhash_fold_blob(h, len, s);
return Val_long(h);
}

18
unikernel/duniverse/base/hash_types/src/runtime.js Normal file
View file

@ -0,0 +1,18 @@
//Provides: Base_internalhash_fold_int64
//Requires: caml_hash_mix_int64
var Base_internalhash_fold_int64 = caml_hash_mix_int64;
//Provides: Base_internalhash_fold_int
//Requires: caml_hash_mix_int
var Base_internalhash_fold_int = caml_hash_mix_int;
//Provides: Base_internalhash_fold_float
//Requires: caml_hash_mix_float
var Base_internalhash_fold_float = caml_hash_mix_float;
//Provides: Base_internalhash_fold_string
//Requires: caml_hash_mix_string
var Base_internalhash_fold_string = caml_hash_mix_string;
//Provides: Base_internalhash_get_hash_value
//Requires: caml_hash_mix_final
function Base_internalhash_get_hash_value(seed) {
var h = caml_hash_mix_final(seed);
return h & 0x3FFFFFFF;
}

5
unikernel/duniverse/base/hash_types/test/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name base_internalhash_types_test)
(libraries base expect_test_helpers_core stdio)
(preprocess
(pps ppx_jane)))

2
unikernel/duniverse/base/hash_types/test/import.ml Normal file
View file

@ -0,0 +1,2 @@
include Stdio
include Expect_test_helpers_core

14
unikernel/duniverse/base/hash_types/test/test_immediate.ml Normal file
View file

@ -0,0 +1,14 @@
open! Base
open! Import
let%expect_test "[Base.Hash.state] is still immediate" =
require_no_allocation [%here] (fun () ->
ignore (Sys.opaque_identity (Base.Hash.create ())));
[%expect {| |}]
;;
let%expect_test _ =
print_s
[%sexp (Stdlib.Obj.is_int (Stdlib.Obj.repr (Base.Hash.create ~seed:1 ())) : bool)];
[%expect {| true |}]
;;

1
unikernel/duniverse/base/hash_types/test/test_immediate.mli Normal file
View file

@ -0,0 +1 @@
(*_ This signature is deliberately empty. *)

5
unikernel/duniverse/base/lint/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name ppx_base_lint)
(kind ppx_rewriter)
(libraries compiler-libs.common base ppxlib ppx_cold)
(preprocess no_preprocessing))

189
unikernel/duniverse/base/lint/ppx_base_lint.ml Normal file
View file

@ -0,0 +1,189 @@
open Ppxlib
open Base
let error ~loc fmt = Location.raise_errorf ~loc (Stdlib.( ^^ ) "ppx_base_lint:" fmt)
type suspicious_id = Stdlib_submodule of string
let rec iter_suspicious (id : Longident.t) ~f =
match id with
| Ldot (Lident "Stdlib", s)
when String.( <> ) s ""
&&
match s.[0] with
| 'A' .. 'Z' -> true
| _ -> false -> f (Stdlib_submodule s)
| Ldot (x, _) -> iter_suspicious x ~f
| Lapply (a, b) ->
iter_suspicious a ~f;
iter_suspicious b ~f
| Lident _ -> ()
;;
let zero_modules () =
Stdlib.Sys.readdir "."
|> Array.to_list
|> List.filter ~f:(fun fn -> Stdlib.Filename.check_suffix fn "0.ml")
|> List.map ~f:(fun fn ->
String.capitalize (String.sub fn ~pos:0 ~len:(String.length fn - 4)))
|> Set.of_list (module String)
;;
let check_open (id : Longident.t Asttypes.loc) =
match id.txt with
| Lident "Stdlib" -> error ~loc:id.loc "you are not allowed to open Stdlib inside Base"
| _ -> ()
;;
let rec is_stdlib_dot_something : Longident.t -> bool = function
| Ldot (Lident "Stdlib", _) -> true
| Ldot (id, _) -> is_stdlib_dot_something id
| _ -> false
;;
let print_payload ppf = function
| PStr x -> Pprintast.structure ppf x
| PSig x -> Pprintast.signature ppf x
| PTyp x -> Pprintast.core_type ppf x
| PPat (x, None) -> Pprintast.pattern ppf x
| PPat (x, Some w) ->
Stdlib.Format.fprintf ppf "%a@ when@ %a" Pprintast.pattern x Pprintast.expression w
;;
let remove_loc =
object
inherit Ast_traverse.map
method! location _ = Location.none
method! location_stack _ = []
end
;;
let check current_module =
let zero_modules = zero_modules () in
object
inherit Ast_traverse.iter as super
method! longident_loc { txt = id; loc } =
(* Note: we don't distinguish between module identifiers and constructors names.
Since there is no [Stdlib.String], [Stdlib.Array], ... constructors this is not a
problem. *)
iter_suspicious id ~f:(fun (Stdlib_submodule m) ->
if not (Set.mem zero_modules m)
then (* We are allowed to use Stdlib modules that don't have a Foo0 version *)
()
else if String.equal (m ^ "0") current_module
then () (* Foo0 is allowed to use Stdlib.Foo *)
else (
match current_module with
| "Import0" | "Base" -> ()
| _ -> error ~loc "you cannot use [Stdlib.%s] here, use [%s0] instead" m m))
(* We allow references to Stdlib in types. This is primarily to allow ppx-derived code
to refer to Stdlib. *)
method! core_type _ = ()
method! expression e =
super#expression e;
match e.pexp_desc with
| Pexp_open ({ popen_expr = { pmod_desc = Pmod_ident id; _ }; _ }, _) ->
check_open id
| _ -> ()
method! open_description op =
super#open_description op;
check_open op.popen_expr
method! module_binding mb =
super#module_binding mb;
match current_module with
| "Import0" -> ()
| _ ->
(match mb.pmb_expr.pmod_desc with
| Pmod_ident { txt = id; _ } when is_stdlib_dot_something id ->
error
~loc:mb.pmb_loc
"you cannot alias [Stdlib] sub-modules, use them directly"
| _ -> ())
method! attributes attrs =
super#attributes attrs;
let is_cold attr = String.equal attr.attr_name.txt "cold" in
match List.find attrs ~f:is_cold with
| None -> ()
| Some attr ->
let expansion =
Ppx_cold.expand_cold_attribute attr
|> List.map ~f:(fun a ->
{ a with
attr_name =
{ a.attr_name with
txt =
String.chop_prefix a.attr_name.txt ~prefix:"ocaml."
|> Option.value ~default:a.attr_name.txt
}
})
in
let is_part_of_expansion attr =
List.exists expansion ~f:(fun a ->
String.equal a.attr_name.txt attr.attr_name.txt
|| String.equal ("ocaml." ^ a.attr_name.txt) attr.attr_name.txt)
in
let new_attrs =
List.concat_map attrs ~f:(fun a ->
if is_cold a
then a :: expansion
else if is_part_of_expansion a
then []
else [ a ])
in
if not
(Poly.equal (remove_loc#attributes attrs) (remove_loc#attributes new_attrs))
then (
(* Remove attributes written by the user that correspond to attributes in the
expansion *)
List.iter attrs ~f:(fun a ->
if is_part_of_expansion a
then Driver.register_correction ~loc:a.attr_loc ~repl:"");
let attribute_level =
String.make
(attr.attr_name.loc.loc_start.pos_cnum
- attr.attr_loc.loc_start.pos_cnum
- 1)
'@'
in
let repl =
Stdlib.Format.asprintf
"@[<h>%a@]"
(Stdlib.Format.pp_print_list (fun ppf x ->
Stdlib.Format.fprintf
ppf
"[%s%s@ %a]"
attribute_level
x.attr_name.txt
print_payload
x.attr_payload))
(attr :: expansion)
in
Driver.register_correction ~loc:attr.attr_loc ~repl)
end
;;
let module_of_loc (loc : Location.t) =
String.capitalize
(Stdlib.Filename.chop_extension (Stdlib.Filename.basename loc.loc_start.pos_fname))
;;
let () =
Ppxlib.Driver.register_transformation
"base_lint"
~impl:(function
| [] -> []
| { pstr_loc = loc; _ } :: _ as st ->
(check (module_of_loc loc))#structure st;
st)
~intf:(function
| [] -> []
| { psig_loc = loc; _ } :: _ as sg ->
(check (module_of_loc loc))#signature sg;
sg)
;;

6
unikernel/duniverse/base/md5/src/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name md5_lib)
(public_name base.md5)
(preprocess no_preprocessing)
(libraries)
(js_of_ocaml (javascript_files)))

21
unikernel/duniverse/base/md5/src/md5_lib.ml Normal file
View file

@ -0,0 +1,21 @@
type t = string
(* Share the digest of the empty string *)
let empty = Digest.string ""
let make s = if s = empty then empty else s
let compare = compare
let length = 16
let to_binary s = s
let to_binary_local s = s
let of_binary_exn s =
assert (String.length s = length);
make s
;;
let unsafe_of_binary = make
let to_hex = Digest.to_hex
let of_hex_exn s = make (Digest.from_hex s)
let string s = make (Digest.string s)
let bytes s = make (Digest.bytes s)
let subbytes bytes ~pos ~len = make (Digest.subbytes bytes pos len)

19
unikernel/duniverse/base/md5/src/md5_lib.mli Normal file
View file

@ -0,0 +1,19 @@
type t
val compare : t -> t -> int
(** [length = 16] is the size of the digest in bytes. *)
val length : int
val to_binary : t -> string
val to_binary_local : t -> string
val of_binary_exn : string -> t
(** assumes the input is 16 bytes without checking *)
val unsafe_of_binary : string -> t
val to_hex : t -> string
val of_hex_exn : string -> t
val string : string -> t
val bytes : bytes -> t
val subbytes : bytes -> pos:int -> len:int -> t

8
unikernel/duniverse/base/shadow-stdlib/gen/dune Normal file
View file

@ -0,0 +1,8 @@
(executables
(modes byte exe)
(names gen)
(libraries str compiler-libs.common)
(link_flags -linkall)
(preprocess no_preprocessing))
(ocamllex mapper)

35
unikernel/duniverse/base/shadow-stdlib/gen/gen.ml Normal file
View file

@ -0,0 +1,35 @@
open StdLabels
let () =
(* -permissive indicates that we should tolerate additions to stdlib.
It's [true] in public-release so that new versions of the stdlib can be compatible
with base, but it should be [false] internally so that we remember to
consider implementing the equivalents in base. *)
let permissive, cmi_fn, oc =
match Sys.argv with
| [| _; "-caml-cmi"; cmi_fn; "-o"; fn |] -> false, cmi_fn, open_out fn
| [| _; "-caml-cmi"; "-permissive"; cmi_fn1; cmi_fn2; "-o"; fn |] ->
let cmi_fn = if Sys.file_exists cmi_fn1 then cmi_fn1 else cmi_fn2 in
true, cmi_fn, open_out fn
| _ -> failwith "bad command line arguments"
in
try
let cmi = Cmi_format.read_cmi cmi_fn in
let buf = Buffer.create 512 in
let pp = Format.formatter_of_buffer buf in
Format.pp_set_margin pp max_int;
(* so we can parse line by line below *)
Format.fprintf pp "%a@." Printtyp.signature cmi.Cmi_format.cmi_sign;
let s = Buffer.contents buf in
let lines = Str.split (Str.regexp "\n") s in
Printf.fprintf oc "[@@@warning \"-3\"]\n\n";
Mapper.permissive := permissive;
List.iter lines ~f:(fun line ->
let repl = Mapper.line (Lexing.from_string line) in
if repl <> "" then Printf.fprintf oc "%s\n\n" repl);
flush oc
with
| exn ->
Location.report_exception Format.err_formatter exn;
exit 2
;;

1
unikernel/duniverse/base/shadow-stdlib/gen/gen.mli Normal file
View file

@ -0,0 +1 @@
(*_ This signature is deliberately empty. *)

350
unikernel/duniverse/base/shadow-stdlib/gen/mapper.mll Normal file
View file

@ -0,0 +1,350 @@
{
open StdLabels
open Printf
let deprecated_msg ~is_exn what =
sprintf
"[%sdeprecated \"\\\n\
[2016-09] this element comes from the stdlib distributed with OCaml.\n\
Referring to the stdlib directly is discouraged by Base. You should either\n\
use the equivalent functionality offered by Base, or if you really want to\n\
refer to the stdlib, use Stdlib.%s instead\"]"
(if is_exn then "@" else "@@")
what
let deprecated_msg_no_equivalent ~is_exn what =
sprintf
"[%sdeprecated \"\\\n\
[2016-09] this element comes from the stdlib distributed with OCaml.\n\
There is not equivalent functionality in Base or Stdio at the moment,\n\
so you need to use [Stdlib.%s] instead\"]"
(if is_exn then "@" else "@@")
what
let deprecated_msg_with_repl_text ~is_exn text =
sprintf
"[%sdeprecated \"\\\n\
[2016-09] this element comes from the stdlib distributed with OCaml.\n\
%s.\"]"
(if is_exn then "@" else "@@")
text
let deprecated_msg_with_repl ~is_exn repl =
deprecated_msg_with_repl_text ~is_exn (sprintf "Use [%s] instead" repl)
let deprecated_msg_with_approx_repl ~is_exn ~id repl =
sprintf
"[%sdeprecated \"\\\n\
[2016-09] this element comes from the stdlib distributed with OCaml.\n\
There is no equivalent functionality in Base or Stdio but you can use\n\
[%s] instead.\n\
Alternatively, if you really want to refer the stdlib you can use\n\
[Stdlib.%s].\"]"
(if is_exn then "@" else "@@")
repl id
type replacement =
| No_equivalent
| Repl of string
| Repl_text of string
| Approx of string
let permissive = ref false
let val_replacement = function
| "( ! )" -> No_equivalent
| "( != )" -> Repl "not (phys_equal ...)"
| "( & )" -> No_equivalent
| "( && )" -> No_equivalent
| "( * )" -> No_equivalent
| "( ** )" -> Repl "**."
| "( *. )" -> No_equivalent
| "( + )" -> No_equivalent
| "( +. )" -> No_equivalent
| "( - )" -> No_equivalent
| "( -. )" -> No_equivalent
| "( / )" -> No_equivalent
| "( /. )" -> No_equivalent
| "( := )" -> No_equivalent
| "( < )" -> No_equivalent
| "( <= )" -> No_equivalent
| "( <> )" -> No_equivalent
| "( = )" -> No_equivalent
| "( == )" -> Repl "phys_equal"
| "( > )" -> No_equivalent
| "( >= )" -> No_equivalent
| "( @ )" -> No_equivalent
| "( @@ )" -> No_equivalent
| "( ^ )" -> No_equivalent
| "( ^^ )" -> No_equivalent
| "( asr )" -> No_equivalent
| "( land )" -> No_equivalent
| "( lor )" -> No_equivalent
| "( lsl )" -> No_equivalent
| "( lsr )" -> No_equivalent
| "( lxor )" -> No_equivalent
| "( mod )" -> Repl_text "Use (%), which has slightly different semantics, or Int.rem which is equivalent"
| "( or )" -> No_equivalent
| "( |> )" -> No_equivalent
| "( || )" -> No_equivalent
| "( ~+ )" -> No_equivalent
| "( ~+. )" -> No_equivalent
| "( ~- )" -> No_equivalent
| "( ~-. )" -> No_equivalent
| "__FILE__" -> No_equivalent
| "__FUNCTION__" -> No_equivalent
| "__LINE__" -> No_equivalent
| "__LINE_OF__" -> No_equivalent
| "__LOC__" -> No_equivalent
| "__LOC_OF__" -> No_equivalent
| "__MODULE__" -> No_equivalent
| "__POS__" -> No_equivalent
| "__POS_OF__" -> No_equivalent
| "abs" -> No_equivalent
| "abs_float" -> No_equivalent
| "acos" -> Repl "Float.acos"
| "acosh" -> Repl "Float.acosh"
| "asinh" -> Repl "Float.asinh"
| "atanh" -> Repl "Float.atanh"
| "asin" -> Repl "Float.asin"
| "at_exit" -> No_equivalent
| "atan" -> Repl "Float.atan"
| "atan2" -> Repl "Float.atan2"
| "bool_of_string" -> Repl "Bool.of_string"
| "bool_of_string_opt" -> No_equivalent
| "ceil" -> Repl "Float.round_up"
| "char_of_int" -> Repl "Char.of_int_exn"
| "classify_float" -> Repl "Float.classify"
| "close_in" -> Repl "Stdio.In_channel.close"
| "close_in_noerr" -> Repl "Stdio.In_channel.close"
| "close_out" -> Repl "Stdio.Out_channel.close"
| "close_out_noerr" -> Repl "Stdio.Out_channel.close"
| "compare" -> No_equivalent
| "copysign" -> Repl "Float.copysign"
| "cos" -> Repl "Float.cos"
| "cosh" -> Repl "Float.cosh"
| "decr" -> Repl "Int.decr"
| "do_at_exit" -> No_equivalent
| "do_domain_local_at_exit" -> No_equivalent
| "epsilon_float" -> Repl "Float.epsilon_float"
| "exit" -> No_equivalent
| "exp" -> Repl "Float.exp"
| "expm1" -> Repl "Float.expm1"
| "failwith" -> No_equivalent
| "float" -> Repl "Float.of_int"
| "float_of_int" -> Repl "Float.of_int"
| "float_of_string" -> Repl "Float.of_string"
| "float_of_string_opt" -> No_equivalent
| "floor" -> Repl "Float.round_down"
| "flush" -> Repl "Stdio.Out_channel.flush"
| "flush_all" -> No_equivalent
| "format_of_string" -> No_equivalent
| "frexp" -> Repl "Float.frexp"
| "fst" -> No_equivalent
| "hypot" -> Repl "Float.hypot"
| "ignore" -> No_equivalent
| "in_channel_length" -> Repl "Stdio.In_channel.length"
| "incr" -> Repl "Int.incr"
| "infinity" -> Repl "Float.infinity"
| "input" -> Repl "Stdio.In_channel.input"
| "input_binary_int" -> Repl "Stdio.In_channel.input_binary_int"
| "input_byte" -> Repl "Stdio.In_channel.input_byte"
| "input_char" -> Repl "Stdio.In_channel.input_char"
| "input_line" -> Repl "Stdio.In_channel.input_line"
| "input_value" -> Repl "Stdio.In_channel.unsafe_input_value"
| "int_of_char" -> Repl "Char.to_int"
| "int_of_float" -> Repl "Int.of_float"
| "int_of_string" -> Repl "Int.of_string"
| "int_of_string_opt" -> No_equivalent
| "invalid_arg" -> No_equivalent
| "ldexp" -> Repl "Float.ldexp"
| "lnot" -> No_equivalent
| "log" -> Repl "Float.log"
| "log10" -> Repl "Float.log10"
| "log1p" -> Repl "Float.log1p"
| "max" -> No_equivalent
| "max_float" -> Repl "Float.max_finite_value"
| "max_int" -> Repl "Int.max_value"
| "min" -> No_equivalent
| "min_float" -> Repl "Float.min_positive_normal_value"
| "min_int" -> Repl "Int.min_value"
| "mod_float" -> Repl "Float.mod_float"
| "modf" -> Repl "Float.modf"
| "nan" -> Repl "Float.nan"
| "neg_infinity" -> Repl "Float.neg_infinity"
| "not" -> No_equivalent
| "open_in" -> Repl "Stdio.In_channel.create"
| "open_in_bin" -> Repl "Stdio.In_channel.create"
| "open_in_gen" -> No_equivalent
| "open_out" -> Repl "Stdio.Out_channel.create"
| "open_out_bin" -> Repl "Stdio.Out_channel.create"
| "open_out_gen" -> No_equivalent
| "out_channel_length" -> Repl "Stdio.Out_channel.length"
| "output" -> Repl "Stdio.Out_channel.output"
| "output_binary_int" -> Repl "Stdio.Out_channel.output_binary_int"
| "output_byte" -> Repl "Stdio.Out_channel.output_byte"
| "output_bytes" -> Repl "Stdio.Out_channel.output_bytes"
| "output_char" -> Repl "Stdio.Out_channel.output_char"
| "output_string" -> Repl "Stdio.Out_channel.output_string"
| "output_substring" -> Repl "Stdio.Out_channel.output"
| "output_value" -> Repl "Stdio.Out_channel.output_value"
| "pos_in" -> Repl "Stdio.In_channel.pos"
| "pos_out" -> Repl "Stdio.Out_channel.pos"
| "pred" -> Repl "Int.pred"
| "prerr_bytes" -> Repl "Stdio.Out_channel.output_bytes Stdio.stderr"
| "prerr_char" -> Repl "Stdio.Out_channel.output_char Stdio.stderr"
| "prerr_endline" -> Repl "Stdio.prerr_endline"
| "prerr_float" -> Repl "Stdio.eprintf \"%f\""
| "prerr_int" -> Repl "Stdio.eprintf \"%d\""
| "prerr_newline" -> Repl "Stdio.eprintf \"\n%!\""
| "prerr_string" -> Repl "Stdio.Out_channel.output_string Stdio.stderr"
| "print_bytes" -> Repl "Stdio.Out_channel.output_bytes Stdio.stdout"
| "print_char" -> Repl "Stdio.Out_channel.output_char Stdio.stdout"
| "print_endline" -> Repl "Stdio.print_endline"
| "print_float" -> Repl "Stdio.eprintf \"%f\""
| "print_int" -> Repl "Stdio.eprintf \"%d\""
| "print_newline" -> Repl "Stdio.eprintf \"\n%!\""
| "print_string" -> Repl "Stdio.Out_channel.output_string Stdio.stdout"
| "raise" -> No_equivalent
| "raise_notrace" -> No_equivalent
| "read_float" -> No_equivalent
| "read_float_opt" -> No_equivalent
| "read_int" -> No_equivalent
| "read_int_opt" -> No_equivalent
| "read_line" -> Repl "Stdio.In_channel.input_line"
| "really_input" -> Repl "Stdio.In_channel.really_input"
| "really_input_string" -> Approx "Stdio.In_channel"
| "ref" -> No_equivalent
| "seek_in" -> Repl "Stdio.In_channel.seek"
| "seek_out" -> Repl "Stdio.Out_channel.seek"
| "set_binary_mode_in" -> Repl "Stdio.In_channel.set_binary_mode"
| "set_binary_mode_out" -> Repl "Stdio.Out_channel.set_binary_mode"
| "sin" -> Repl "Float.sin"
| "sinh" -> Repl "Float.sinh"
| "snd" -> No_equivalent
| "sqrt" -> Repl "Float.sqrt"
| "stderr" -> Repl "Stdio.stderr"
| "stdin" -> Repl "Stdio.stdin"
| "stdout" -> Repl "Stdio.stdout"
| "string_of_bool" -> Repl "Bool.to_string"
| "string_of_float" -> Repl "Float.to_string"
| "string_of_format" -> No_equivalent
| "string_of_int" -> Repl "Int.to_string"
| "succ" -> Repl "Int.succ"
| "tan" -> Repl "Float.tan"
| "tanh" -> Repl "Float.tanh"
| "truncate" -> Repl "Int.of_float"
| "unsafe_really_input" -> No_equivalent
| "valid_float_lexem" -> No_equivalent
| symbol ->
if !permissive then No_equivalent
else
failwith
(sprintf
"Consider adding to [Base] an equivalent for symbol %S defined in stdlib"
symbol)
;;
let exception_replacement = function
| "Not_found" ->
Some (Repl_text "\
Instead of raising [Not_found], consider using [raise_s] with an informative error\n\
message. If code needs to distinguish [Not_found] from other exceptions, please change\n\
it to handle both [Not_found] and [Not_found_s]. Then, instead of raising [Not_found],\n\
raise [Not_found_s] with an informative error message")
| _ -> None
let type_replacement = function
| "in_channel" -> Some (Repl "Stdio.In_channel.t")
| "out_channel" -> Some (Repl "Stdio.Out_channel.t")
| "result" -> Some (Repl "Result.t")
| _ -> None
;;
let module_replacement = function
| "Format" ->
let repl_text =
"[Base] doesn't export a [Format] module, although the \n\
[Stdlib.Format.formatter] type is available (as [Formatter.t])\n\
for interaction with other libraries"
in
Some (Repl_text repl_text)
| "Fun" -> Some (Repl "Fn")
| "Gc" -> Some No_equivalent
| "Printexc" -> Some (Repl_text "Use [Exn] or [Backtrace] instead")
| "Seq" -> Some (Approx "Sequence")
| _ -> None
let replace ~is_exn id replacement =
match replacement with
| No_equivalent -> deprecated_msg_no_equivalent ~is_exn id
| Repl repl -> deprecated_msg_with_repl ~is_exn repl
| Repl_text text -> deprecated_msg_with_repl_text ~is_exn text
| Approx repl -> deprecated_msg_with_approx_repl ~is_exn repl ~id
;;
let is_alias = function
| "format" | "format4" | "format6" -> true
| _ -> false
}
let id_trail = ['a'-'z' 'A'-'Z' '_' '0'-'9']*
let id = ['a'-'z' 'A'-'Z' '_' '0'-'9'] id_trail
let val_id = id | '(' [^ ')']* ')'
let params = ('(' [^')']* ')' | ['+' '-']? '\'' id) " "
let val_ = "val " | "external "
rule line = parse
| "module Camlinternal" _*
{ "" (* We can't deprecate these *) }
| "module Bigarray" _* { "" (* Don't deprecate it yet *) }
| "type " (params? as params) (id as id) (_* as def)
{ sprintf "type nonrec %s%s = %sStdlib.%s%s\n%s"
params id
params id
(if is_alias id then "" else def)
(match type_replacement id with
| Some replacement -> replace ~is_exn:false id replacement
| None -> deprecated_msg ~is_exn:false id) }
| val_ (val_id as id) _* as line
{ sprintf "%s\n%s" line (replace ~is_exn:false id (val_replacement id)) }
| "module " (id as id) " = Stdlib__" (id as id2) (_* as line)
{
Printf.sprintf "module %s = Stdlib.%s %s\n%s"
id (String.capitalize_ascii id2) line
(match module_replacement id with
| Some replacement -> replace ~is_exn:false id replacement
| None -> deprecated_msg ~is_exn:false id) }
| "exception " (id as id) _* as line
{ match exception_replacement id with
| Some replacement -> sprintf "%s\n%s" line (replace ~is_exn:true id replacement)
| None ->
let predefined_exceptions =
[ "Out_of_memory"
; "Sys_error"
; "Failure"
; "Invalid_argument"
; "End_of_file"
; "Division_by_zero"
; "Not_found"
; "Match_failure"
; "Stack_overflow"
; "Sys_blocked_io"
; "Assert_failure"
; "Undefined_recursive_module" ]
in
if List.mem id ~set:predefined_exceptions
then ""
else sprintf "%s\n%s" line (deprecated_msg ~is_exn:true id)
}
| "module " (id as id) _*
{ sprintf "module %s = Stdlib.%s\n%s" id id
(match module_replacement id with
| Some replacement -> replace ~is_exn:false id replacement
| None -> deprecated_msg ~is_exn:false id) }
| _* as line
{ ksprintf failwith "cannot parse this: %s" line }

12
unikernel/duniverse/base/shadow-stdlib/src/dune Normal file
View file

@ -0,0 +1,12 @@
(library
(name shadow_stdlib)
(public_name base.shadow_stdlib)
(libraries)
(preprocess no_preprocessing))
(rule
(targets shadow_stdlib.mli)
(deps %{ocaml_where}/stdlib.cma)
(action
(run ../gen/gen.exe -caml-cmi -permissive %{ocaml_where}/stdlib.cmi
%{ocaml_where}/stdlib.cma -o %{targets})))

1
unikernel/duniverse/base/shadow-stdlib/src/shadow_stdlib.ml Normal file
View file

@ -0,0 +1 @@
include Stdlib

6
unikernel/duniverse/base/src/am_testing.c Normal file
View file

@ -0,0 +1,6 @@
#include <caml/mlvalues.h>
/* The default [Base_am_testing] value is [false]. [ppx_inline_test] overrides
the default by linking against an implementation of [Base_am_testing] that
returns [true]. */
CAMLprim CAMLweakdef value Base_am_testing() { return Val_false; }

9
unikernel/duniverse/base/src/am_testing.h Normal file
View file

@ -0,0 +1,9 @@
#ifndef BASE_AM_TESTING_H
#define BASE_AM_TESTING_H
#include <caml/mlvalues.h>
CAMLprim value Base_am_testing();
static inline int am_testing() { return Bool_val(Base_am_testing()); }
#endif

272
unikernel/duniverse/base/src/applicative.ml Normal file
View file

@ -0,0 +1,272 @@
open! Import
include Applicative_intf
module List = List0
(** This module serves mostly as a partial check that [S2] and [S] are in sync, but
actually calling it is occasionally useful. *)
module S_to_S2 (X : S) : S2 with type ('a, 'e) t = 'a X.t = struct
include X
type ('a, 'e) t = 'a X.t
end
module S2_to_S (T : T.T) (X : S2) : S with type 'a t = ('a, T.t) X.t = struct
include X
type 'a t = ('a, T.t) X.t
end
module S2_to_S3 (X : S2) : S3 with type ('a, 'd, 'e) t = ('a, 'd) X.t = struct
include X
type ('a, 'd, 'e) t = ('a, 'd) X.t
end
module S3_to_S2 (T : T.T) (X : S3) : S2 with type ('a, 'd) t = ('a, 'd, T.t) X.t = struct
include X
type ('a, 'd) t = ('a, 'd, T.t) X.t
end
module S3_to_S (T1 : T.T) (T2 : T.T) (X : S3) : S with type 'a t = ('a, T1.t, T2.t) X.t =
struct
include X
type 'a t = ('a, T1.t, T2.t) X.t
end
module Make3 (X : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct
include X
let ( <*> ) = apply
let derived_map t ~f = return f <*> t
let map =
match X.map with
| `Define_using_apply -> derived_map
| `Custom x -> x
;;
let ( >>| ) t f = map t ~f
let map2 ta tb ~f = map ~f ta <*> tb
let map3 ta tb tc ~f = map ~f ta <*> tb <*> tc
let all ts = List.fold_right ts ~init:(return []) ~f:(map2 ~f:(fun x xs -> x :: xs))
let both ta tb = map2 ta tb ~f:(fun a b -> a, b)
let ( *> ) u v = return (fun () y -> y) <*> u <*> v
let ( <* ) u v = return (fun x () -> x) <*> u <*> v
let all_unit ts = List.fold ts ~init:(return ()) ~f:( *> )
module Applicative_infix = struct
let ( <*> ) = ( <*> )
let ( *> ) = ( *> )
let ( <* ) = ( <* )
let ( >>| ) = ( >>| )
end
end
module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t = Make3 (struct
include X
type ('a, 'd, 'e) t = ('a, 'd) X.t
end)
module Make (X : Basic) : S with type 'a t := 'a X.t = Make2 (struct
include X
type ('a, 'e) t = 'a X.t
end)
module Make_let_syntax3
(X : For_let_syntax3) (Intf : sig
module type S
end)
(Impl : Intf.S) =
struct
module Let_syntax = struct
include X
module Let_syntax = struct
include X
module Open_on_rhs = Impl
end
end
end
module Make_let_syntax2
(X : For_let_syntax2) (Intf : sig
module type S
end)
(Impl : Intf.S) =
Make_let_syntax3
(struct
include X
type ('a, 'd, _) t = ('a, 'd) X.t
end)
(Intf)
(Impl)
module Make_let_syntax
(X : For_let_syntax) (Intf : sig
module type S
end)
(Impl : Intf.S) =
Make_let_syntax2
(struct
include X
type ('a, _) t = 'a X.t
end)
(Intf)
(Impl)
(** This functor closely resembles [Make3], and indeed it could be implemented
much shorter in terms of [Make3]. However, we implement it by hand so that
the resulting functions are more efficient, e.g. using [map2] directly instead of
defining [apply] in terms of it and then [map2] in terms of that. For most
applicatives this does not matter, but for some (such as Bonsai.Value.t), it has a
larger impact. *)
module Make3_using_map2 (X : Basic3_using_map2) :
S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct
include X
let apply tf ta = map2 tf ta ~f:(fun f a -> f a)
let ( <*> ) = apply
let derived_map t ~f = return f <*> t
let map =
match X.map with
| `Define_using_map2 -> derived_map
| `Custom x -> x
;;
let ( >>| ) t f = map t ~f
let both ta tb = map2 ta tb ~f:(fun a b -> a, b)
let map3 ta tb tc ~f = map2 (map2 ta tb ~f) tc ~f:(fun fab c -> fab c)
let all ts = List.fold_right ts ~init:(return []) ~f:(map2 ~f:(fun x xs -> x :: xs))
let ( *> ) u v = map2 u v ~f:(fun () y -> y)
let ( <* ) u v = map2 u v ~f:(fun x () -> x)
let all_unit ts = List.fold ts ~init:(return ()) ~f:( *> )
module Applicative_infix = struct
let ( <*> ) = ( <*> )
let ( *> ) = ( *> )
let ( <* ) = ( <* )
let ( >>| ) = ( >>| )
end
end
module Make2_using_map2 (X : Basic2_using_map2) :
S2 with type ('a, 'e) t := ('a, 'e) X.t = Make3_using_map2 (struct
include X
type ('a, 'd, 'e) t = ('a, 'd) X.t
end)
module Make_using_map2 (X : Basic_using_map2) : S with type 'a t := 'a X.t =
Make2_using_map2 (struct
include X
type ('a, 'e) t = 'a X.t
end)
module Make3_using_map2_local (X : Basic3_using_map2_local) :
S3_local with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t = struct
include X
let apply tf ta = map2 tf ta ~f:(fun f a -> f a)
let ( <*> ) = apply
let derived_map t ~f = map2 ~f:(fun () -> f) (return ()) t [@nontail]
let map =
match X.map with
| `Define_using_map2 -> derived_map
| `Custom map -> map
;;
let ( >>| ) t f = map t ~f
let both ta tb = map2 ta tb ~f:(fun a b -> a, b)
let map3 ta tb tc ~f =
let res = map2 (both ta tb) tc ~f:(fun (a, b) c -> f a b c) in
res
;;
let all ts = List.fold_right ts ~init:(return []) ~f:(map2 ~f:(fun x xs -> x :: xs))
let ( *> ) u v = map2 u v ~f:(fun () y -> y)
let ( <* ) u v = map2 u v ~f:(fun x () -> x)
let all_unit ts = List.fold ts ~init:(return ()) ~f:( *> )
module Applicative_infix = struct
let ( <*> ) = ( <*> )
let ( *> ) = ( *> )
let ( <* ) = ( <* )
let ( >>| ) = ( >>| )
end
end
module Make2_using_map2_local (X : Basic2_using_map2_local) :
S2_local with type ('a, 'e) t := ('a, 'e) X.t = Make3_using_map2_local (struct
include X
type ('a, 'd, 'e) t = ('a, 'd) X.t
end)
module Make_using_map2_local (X : Basic_using_map2_local) :
S_local with type 'a t := 'a X.t = Make2_using_map2_local (struct
include X
type ('a, 'e) t = 'a X.t
end)
module Of_monad2 (M : Monad.S2) : S2 with type ('a, 'e) t := ('a, 'e) M.t = Make2 (struct
type ('a, 'e) t = ('a, 'e) M.t
let return = M.return
let apply mf mx = M.bind mf ~f:(fun f -> M.map mx ~f)
let map = `Custom M.map
end)
module Of_monad (M : Monad.S) : S with type 'a t := 'a M.t = Of_monad2 (struct
include M
type ('a, _) t = 'a M.t
end)
module Compose (F : S) (G : S) : S with type 'a t = 'a F.t G.t = struct
type 'a t = 'a F.t G.t
include Make (struct
type nonrec 'a t = 'a t
let return a = G.return (F.return a)
let apply tf tx = G.apply (G.map ~f:F.apply tf) tx
let custom_map t ~f = G.map ~f:(F.map ~f) t
let map = `Custom custom_map
end)
end
module Pair (F : S) (G : S) : S with type 'a t = 'a F.t * 'a G.t = struct
type 'a t = 'a F.t * 'a G.t
include Make (struct
type nonrec 'a t = 'a t
let return a = F.return a, G.return a
let apply tf tx = F.apply (fst tf) (fst tx), G.apply (snd tf) (snd tx)
let custom_map t ~f = F.map ~f (fst t), G.map ~f (snd t)
let map = `Custom custom_map
end)
end
module Ident = struct
type 'a t = 'a
include Make_using_map2_local (struct
type nonrec 'a t = 'a t
let return = Fn.id
let map2 a b ~f = f a b
let map = `Custom (fun a ~f -> f a)
end)
end

1
unikernel/duniverse/base/src/applicative.mli Normal file
View file

@ -0,0 +1 @@
include Applicative_intf.Applicative (** @inline *)

534
unikernel/duniverse/base/src/applicative_intf.ml Normal file
View file

@ -0,0 +1,534 @@
(** Applicatives model computations in which values computed by subcomputations cannot
affect what subsequent computations will take place.
Relative to monads, this restriction takes power away from the user of the interface
and gives it to the implementation. In particular, because the structure of the
entire computation is known, one can augment its definition with some description of
that structure.
For more information, see:
{v
Applicative Programming with Effects.
Conor McBride and Ross Paterson.
Journal of Functional Programming 18:1 (2008), pages 1-13.
http://staff.city.ac.uk/~ross/papers/Applicative.pdf
v} *)
open! Import
module type Basic = sig
type 'a t
val return : 'a -> 'a t
val apply : ('a -> 'b) t -> 'a t -> 'b t
(** The following identities ought to hold for every Applicative (for some value of =):
- identity: [return Fn.id <*> t = t]
- composition: [return Fn.compose <*> tf <*> tg <*> tx = tf <*> (tg <*> tx)]
- homomorphism: [return f <*> return x = return (f x)]
- interchange: [tf <*> return x = return (fun f -> f x) <*> tf]
Note: <*> is the infix notation for apply. *)
(** The [map] argument to [Applicative.Make] says how to implement the applicative's
[map] function. [`Define_using_apply] means to define [map t ~f = return f <*> t].
[`Custom] overrides the default implementation, presumably with something more
efficient.
Some other functions returned by [Applicative.Make] are defined in terms of [map],
so passing in a more efficient [map] will improve their efficiency as well. *)
val map : [ `Define_using_apply | `Custom of 'a t -> f:('a -> 'b) -> 'b t ]
end
(** Similar to [Basic], with the same laws, and the additional requirement that ['a t]
can be mapped with a local function. *)
module type Basic_local = sig
type 'a t
val return : 'a -> 'a t
val apply : ('a -> 'b) t -> 'a t -> 'b t
val map : 'a t -> f:('a -> 'b) -> 'b t
end
module type Basic_using_map2 = sig
type 'a t
val return : 'a -> 'a t
val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
val map : [ `Define_using_map2 | `Custom of 'a t -> f:('a -> 'b) -> 'b t ]
end
module type Basic_using_map2_local = sig
type 'a t
val return : 'a -> 'a t
val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
val map : [ `Define_using_map2 | `Custom of 'a t -> f:('a -> 'b) -> 'b t ]
end
module type Applicative_infix_gen = sig
type 'a t
type ('a, 'b) fn
(** same as [apply] *)
val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t
val ( <* ) : 'a t -> unit t -> 'a t
val ( *> ) : unit t -> 'a t -> 'a t
val ( >>| ) : 'a t -> ('a -> 'b, 'b t) fn
end
module type Applicative_infix = Applicative_infix_gen with type ('a, 'b) fn := 'a -> 'b
module type Applicative_infix_local =
Applicative_infix_gen with type ('a, 'b) fn := 'a -> 'b
module type For_let_syntax_gen = sig
type 'a t
type ('a, 'b) fn
type ('a, 'b) f_labeled_fn
val return : 'a -> 'a t
val map : 'a t -> ('a -> 'b, 'b t) f_labeled_fn
val both : 'a t -> 'b t -> ('a * 'b) t
include Applicative_infix_gen with type 'a t := 'a t and type ('a, 'b) fn := ('a, 'b) fn
end
module type For_let_syntax =
For_let_syntax_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
module type For_let_syntax_local =
For_let_syntax_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
module type S_gen = sig
include For_let_syntax_gen
type ('a, 'b, 'c) fun2
type ('a, 'b, 'c, 'd) fun3
val apply : ('a -> 'b) t -> 'a t -> 'b t
val map2 : 'a t -> 'b t -> (('a, 'b, 'c) fun2, 'c t) f_labeled_fn
val map3 : 'a t -> 'b t -> 'c t -> (('a, 'b, 'c, 'd) fun3, 'd t) f_labeled_fn
val all : 'a t list -> 'a list t
val all_unit : unit t list -> unit t
module Applicative_infix :
Applicative_infix_gen with type 'a t := 'a t and type ('a, 'b) fn := ('a, 'b) fn
end
module type S =
S_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c
and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd
module type S_local =
S_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c
and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd
module type Let_syntax = sig
type 'a t
module Open_on_rhs_intf : sig
module type S
end
module Let_syntax : sig
val return : 'a -> 'a t
include Applicative_infix with type 'a t := 'a t
module Let_syntax : sig
val return : 'a -> 'a t
val map : 'a t -> f:('a -> 'b) -> 'b t
val both : 'a t -> 'b t -> ('a * 'b) t
module Open_on_rhs : Open_on_rhs_intf.S
end
end
end
module type Basic2 = sig
type ('a, 'e) t
val return : 'a -> ('a, _) t
val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t
val map : [ `Define_using_apply | `Custom of ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t ]
end
module type Basic2_local = sig
type ('a, 'e) t
val return : 'a -> ('a, _) t
val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t
val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t
end
module type Basic2_using_map2 = sig
type ('a, 'e) t
val return : 'a -> ('a, _) t
val map2 : ('a, 'e) t -> ('b, 'e) t -> f:('a -> 'b -> 'c) -> ('c, 'e) t
val map : [ `Define_using_map2 | `Custom of ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t ]
end
module type Basic2_using_map2_local = sig
type ('a, 'e) t
val return : 'a -> ('a, _) t
val map2 : ('a, 'e) t -> ('b, 'e) t -> f:('a -> 'b -> 'c) -> ('c, 'e) t
val map : [ `Define_using_map2 | `Custom of ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t ]
end
module type Applicative_infix2_gen = sig
type ('a, 'e) t
type ('a, 'b) fn
val ( <*> ) : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t
val ( <* ) : ('a, 'e) t -> (unit, 'e) t -> ('a, 'e) t
val ( *> ) : (unit, 'e) t -> ('a, 'e) t -> ('a, 'e) t
val ( >>| ) : ('a, 'e) t -> ('a -> 'b, ('b, 'e) t) fn
end
module type Applicative_infix2 = Applicative_infix2_gen with type ('a, 'b) fn := 'a -> 'b
module type Applicative_infix2_local =
Applicative_infix2_gen with type ('a, 'b) fn := 'a -> 'b
module type For_let_syntax2_gen = sig
type ('a, 'e) t
type ('a, 'b) fn
type ('a, 'b) f_labeled_fn
val return : 'a -> ('a, _) t
val map : ('a, 'e) t -> ('a -> 'b, ('b, 'e) t) f_labeled_fn
val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t
include
Applicative_infix2_gen
with type ('a, 'e) t := ('a, 'e) t
and type ('a, 'b) fn := ('a, 'b) fn
end
module type For_let_syntax2 =
For_let_syntax2_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
module type For_let_syntax2_local =
For_let_syntax2_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
module type S2_gen = sig
include For_let_syntax2_gen
type ('a, 'b, 'c) fun2
type ('a, 'b, 'c, 'd) fun3
val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t
val map2 : ('a, 'e) t -> ('b, 'e) t -> (('a, 'b, 'c) fun2, ('c, 'e) t) f_labeled_fn
val map3
: ('a, 'e) t
-> ('b, 'e) t
-> ('c, 'e) t
-> (('a, 'b, 'c, 'd) fun3, ('d, 'e) t) f_labeled_fn
val all : ('a, 'e) t list -> ('a list, 'e) t
val all_unit : (unit, 'e) t list -> (unit, 'e) t
module Applicative_infix :
Applicative_infix2_gen
with type ('a, 'e) t := ('a, 'e) t
and type ('a, 'b) fn := ('a, 'b) fn
end
module type S2 =
S2_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c
and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd
module type S2_local =
S2_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c
and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd
module type Let_syntax2 = sig
type ('a, 'e) t
module Open_on_rhs_intf : sig
module type S
end
module Let_syntax : sig
val return : 'a -> ('a, _) t
include Applicative_infix2 with type ('a, 'e) t := ('a, 'e) t
module Let_syntax : sig
val return : 'a -> ('a, _) t
val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t
val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t
module Open_on_rhs : Open_on_rhs_intf.S
end
end
end
module type Basic3 = sig
type ('a, 'd, 'e) t
val return : 'a -> ('a, _, _) t
val apply : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t
val map
: [ `Define_using_apply
| `Custom of ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t
]
end
module type Basic3_using_map2 = sig
type ('a, 'd, 'e) t
val return : 'a -> ('a, _, _) t
val map2 : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> f:('a -> 'b -> 'c) -> ('c, 'd, 'e) t
val map
: [ `Define_using_map2 | `Custom of ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t ]
end
module type Basic3_using_map2_local = sig
type ('a, 'd, 'e) t
val return : 'a -> ('a, _, _) t
val map2 : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> f:('a -> 'b -> 'c) -> ('c, 'd, 'e) t
val map
: [ `Define_using_map2 | `Custom of ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t ]
end
module type Applicative_infix3_gen = sig
type ('a, 'd, 'e) t
type ('a, 'b) fn
val ( <*> ) : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t
val ( <* ) : ('a, 'd, 'e) t -> (unit, 'd, 'e) t -> ('a, 'd, 'e) t
val ( *> ) : (unit, 'd, 'e) t -> ('a, 'd, 'e) t -> ('a, 'd, 'e) t
val ( >>| ) : ('a, 'd, 'e) t -> ('a -> 'b, ('b, 'd, 'e) t) fn
end
module type Applicative_infix3 = Applicative_infix3_gen with type ('a, 'b) fn := 'a -> 'b
module type Applicative_infix3_local =
Applicative_infix3_gen with type ('a, 'b) fn := 'a -> 'b
module type For_let_syntax3_gen = sig
type ('a, 'd, 'e) t
type ('a, 'b) fn
type ('a, 'b) f_labeled_fn
val return : 'a -> ('a, _, _) t
val map : ('a, 'd, 'e) t -> ('a -> 'b, ('b, 'd, 'e) t) f_labeled_fn
val both : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> ('a * 'b, 'd, 'e) t
include
Applicative_infix3_gen
with type ('a, 'd, 'e) t := ('a, 'd, 'e) t
and type ('a, 'b) fn := ('a, 'b) fn
end
module type For_let_syntax3 =
For_let_syntax3_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
module type For_let_syntax3_local =
For_let_syntax3_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
module type S3_gen = sig
include For_let_syntax3_gen
type ('a, 'b, 'c) fun2
type ('a, 'b, 'c, 'd) fun3
val apply : ('a -> 'b, 'd, 'e) t -> ('a, 'd, 'e) t -> ('b, 'd, 'e) t
val map2
: ('a, 'd, 'e) t
-> ('b, 'd, 'e) t
-> (('a, 'b, 'c) fun2, ('c, 'd, 'e) t) f_labeled_fn
val map3
: ('a, 'd, 'e) t
-> ('b, 'd, 'e) t
-> ('c, 'd, 'e) t
-> (('a, 'b, 'c, 'result) fun3, ('result, 'd, 'e) t) f_labeled_fn
val all : ('a, 'd, 'e) t list -> ('a list, 'd, 'e) t
val all_unit : (unit, 'd, 'e) t list -> (unit, 'd, 'e) t
module Applicative_infix :
Applicative_infix3_gen
with type ('a, 'd, 'e) t := ('a, 'd, 'e) t
and type ('a, 'b) fn := ('a, 'b) fn
end
module type S3 =
S3_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c
and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd
module type S3_local =
S3_gen
with type ('a, 'b) fn := 'a -> 'b
and type ('a, 'b) f_labeled_fn := f:'a -> 'b
and type ('a, 'b, 'c) fun2 := 'a -> 'b -> 'c
and type ('a, 'b, 'c, 'd) fun3 := 'a -> 'b -> 'c -> 'd
module type Let_syntax3 = sig
type ('a, 'd, 'e) t
module Open_on_rhs_intf : sig
module type S
end
module Let_syntax : sig
val return : 'a -> ('a, _, _) t
include Applicative_infix3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) t
module Let_syntax : sig
val return : 'a -> ('a, _, _) t
val map : ('a, 'd, 'e) t -> f:('a -> 'b) -> ('b, 'd, 'e) t
val both : ('a, 'd, 'e) t -> ('b, 'd, 'e) t -> ('a * 'b, 'd, 'e) t
module Open_on_rhs : Open_on_rhs_intf.S
end
end
end
(** [Lazy_applicative] is an applicative whose structure may be computed on-demand,
instead of being constructed up-front. This is useful when implementing traversals
over large data structures, where otherwise we have to pay O(n) up-front cost both
in time and in memory. *)
module type Lazy_applicative = sig
include S
val of_thunk : (unit -> 'a t) -> 'a t
end
module type Applicative = sig
module type Applicative_infix = Applicative_infix
module type Applicative_infix2 = Applicative_infix2
module type Applicative_infix3 = Applicative_infix3
module type Applicative_infix_local = Applicative_infix_local
module type Applicative_infix2_local = Applicative_infix2_local
module type Basic = Basic
module type Basic2 = Basic2
module type Basic3 = Basic3
module type Basic_local = Basic_local
module type Basic2_local = Basic2_local
module type Basic_using_map2 = Basic_using_map2
module type Basic2_using_map2 = Basic2_using_map2
module type Basic3_using_map2 = Basic3_using_map2
module type Basic_using_map2_local = Basic_using_map2_local
module type Basic2_using_map2_local = Basic2_using_map2_local
module type Basic3_using_map2_local = Basic3_using_map2_local
module type Let_syntax = Let_syntax
module type Let_syntax2 = Let_syntax2
module type Let_syntax3 = Let_syntax3
module type S = S
module type S2 = S2
module type S3 = S3
module type Lazy_applicative = Lazy_applicative
module type S_local = S_local
module type S2_local = S2_local
module Ident : S_local with type 'a t = 'a
module S2_to_S (T : T.T) (X : S2) : S with type 'a t = ('a, T.t) X.t
module S_to_S2 (X : S) : S2 with type ('a, 'e) t = 'a X.t
module S3_to_S2 (T : T.T) (X : S3) : S2 with type ('a, 'd) t = ('a, 'd, T.t) X.t
module S3_to_S (T1 : T.T) (T2 : T.T) (X : S3) : S with type 'a t = ('a, T1.t, T2.t) X.t
module S2_to_S3 (X : S2) : S3 with type ('a, 'd, 'e) t = ('a, 'd) X.t
module Make (X : Basic) : S with type 'a t := 'a X.t
module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t
module Make3 (X : Basic3) : S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t
module Make_let_syntax
(X : For_let_syntax) (Intf : sig
module type S
end)
(Impl : Intf.S) :
Let_syntax with type 'a t := 'a X.t with module Open_on_rhs_intf := Intf
module Make_let_syntax2
(X : For_let_syntax2) (Intf : sig
module type S
end)
(Impl : Intf.S) :
Let_syntax2 with type ('a, 'e) t := ('a, 'e) X.t with module Open_on_rhs_intf := Intf
module Make_let_syntax3
(X : For_let_syntax3) (Intf : sig
module type S
end)
(Impl : Intf.S) :
Let_syntax3
with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t
with module Open_on_rhs_intf := Intf
module Make_using_map2 (X : Basic_using_map2) : S with type 'a t := 'a X.t
module Make2_using_map2 (X : Basic2_using_map2) :
S2 with type ('a, 'e) t := ('a, 'e) X.t
module Make3_using_map2 (X : Basic3_using_map2) :
S3 with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t
module Make_using_map2_local (X : Basic_using_map2_local) :
S_local with type 'a t := 'a X.t
module Make2_using_map2_local (X : Basic2_using_map2_local) :
S2_local with type ('a, 'e) t := ('a, 'e) X.t
module Make3_using_map2_local (X : Basic3_using_map2_local) :
S3_local with type ('a, 'd, 'e) t := ('a, 'd, 'e) X.t
(** The following functors give a sense of what Applicatives one can define.
Of these, [Of_monad] is likely the most useful. The others are mostly didactic. *)
(** Every monad is Applicative via:
{[
let apply mf mx =
mf >>= fun f ->
mx >>| fun x ->
f x
]} *)
module Of_monad (M : Monad.S) : S with type 'a t := 'a M.t
module Of_monad2 (M : Monad.S2) : S2 with type ('a, 'e) t := ('a, 'e) M.t
module Compose (F : S) (G : S) : S with type 'a t = 'a F.t G.t
module Pair (F : S) (G : S) : S with type 'a t = 'a F.t * 'a G.t
end

929
unikernel/duniverse/base/src/array.ml Normal file
View file

@ -0,0 +1,929 @@
open! Import
include Array0
type 'a t = 'a array [@@deriving_inline compare ~localize, globalize, sexp, sexp_grammar]
let compare__local : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_array__local
let compare : 'a. ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_array
let globalize : 'a. ('a -> 'a) -> 'a t -> 'a t =
fun (type a__009_) : ((a__009_ -> a__009_) -> a__009_ t -> a__009_ t) -> globalize_array
;;
let t_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a t = array_of_sexp
let sexp_of_t : 'a. ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t = sexp_of_array
let t_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t =
fun _'a_sexp_grammar -> array_sexp_grammar _'a_sexp_grammar
;;
[@@@end]
(* This module implements a new in-place, constant heap sorting algorithm to replace the
one used by the standard libraries. Its only purpose is to be faster (hopefully
strictly faster) than the base sort and stable_sort.
At a high level the algorithm is:
- pick two pivot points by:
- pick 5 arbitrary elements from the array
- sort them within the array
- take the elements on either side of the middle element of the sort as the pivots
- sort the array with:
- all elements less than pivot1 to the left (range 1)
- all elements >= pivot1 and <= pivot2 in the middle (range 2)
- all elements > pivot2 to the right (range 3)
- if pivot1 and pivot2 are equal, then the middle range is sorted, so ignore it
- recurse into range 1, 2 (if pivot1 and pivot2 are unequal), and 3
- during recursion there are two inflection points:
- if the size of the current range is small, use insertion sort to sort it
- if the stack depth is large, sort the range with heap-sort to avoid n^2 worst-case
behavior
See the following for more information:
- "Dual-Pivot Quicksort" by Vladimir Yaroslavskiy.
Available at
http://www.kriche.com.ar/root/programming/spaceTimeComplexity/DualPivotQuicksort.pdf
- "Quicksort is Optimal" by Sedgewick and Bentley.
Slides at http://www.cs.princeton.edu/~rs/talks/QuicksortIsOptimal.pdf
- http://www.sorting-algorithms.com/quick-sort-3-way *)
module Sorter (S : sig
type 'a t
val get : 'a t -> int -> 'a
val set : 'a t -> int -> 'a -> unit
val length : 'a t -> int
end) =
struct
include S
let swap arr i j =
let tmp = get arr i in
set arr i (get arr j);
set arr j tmp
;;
module type Sort = sig
val sort
: 'a t
-> compare:('a -> 'a -> int)
-> left:int (* leftmost index of sub-array to sort *)
-> right:int (* rightmost index of sub-array to sort *)
-> unit
end
(* http://en.wikipedia.org/wiki/Insertion_sort *)
module Insertion_sort : Sort = struct
(* loop invariants:
1. the subarray arr[left .. i-1] is sorted
2. the subarray arr[i+1 .. pos] is sorted and contains only elements > v
3. arr[i] may be thought of as containing v
*)
let rec insert_loop arr ~left ~compare i v =
let i_next = i - 1 in
if i_next >= left && compare (get arr i_next) v > 0
then (
set arr i (get arr i_next);
insert_loop arr ~left ~compare i_next v)
else i
;;
let sort arr ~compare ~left ~right =
(* loop invariant:
[arr] is sorted from [left] to [pos - 1], inclusive *)
for pos = left + 1 to right do
let v = get arr pos in
let final_pos = insert_loop arr ~left ~compare pos v in
set arr final_pos v
done
;;
end
(* http://en.wikipedia.org/wiki/Heapsort *)
module Heap_sort : Sort = struct
(* loop invariant:
root's children are both either roots of max-heaps or > right *)
let rec heapify arr ~compare root ~left ~right =
let relative_root = root - left in
let left_child = (2 * relative_root) + left + 1 in
let right_child = (2 * relative_root) + left + 2 in
let largest =
if left_child <= right && compare (get arr left_child) (get arr root) > 0
then left_child
else root
in
let largest =
if right_child <= right && compare (get arr right_child) (get arr largest) > 0
then right_child
else largest
in
if largest <> root
then (
swap arr root largest;
heapify arr ~compare largest ~left ~right)
;;
let build_heap arr ~compare ~left ~right =
(* Elements in the second half of the array are already heaps of size 1. We move
through the first half of the array from back to front examining the element at
hand, and the left and right children, fixing the heap property as we go. *)
for i = (left + right) / 2 downto left do
heapify arr ~compare i ~left ~right
done
;;
let sort arr ~compare ~left ~right =
build_heap arr ~compare ~left ~right;
(* loop invariants:
1. the subarray arr[left ... i] is a max-heap H
2. the subarray arr[i+1 ... right] is sorted (call it S)
3. every element of H is less than every element of S *)
for i = right downto left + 1 do
swap arr left i;
heapify arr ~compare left ~left ~right:(i - 1)
done
;;
end
(* http://en.wikipedia.org/wiki/Introsort *)
module Intro_sort : sig
include Sort
val five_element_sort
: 'a t
-> compare:('a -> 'a -> int)
-> int
-> int
-> int
-> int
-> int
-> unit
end = struct
let five_element_sort arr ~(compare : _ -> _ -> _) m1 m2 m3 m4 m5 =
let compare_and_swap i j =
if compare (get arr i) (get arr j) > 0 then swap arr i j
in
(* Optimal 5-element sorting network:
{v
1--o-----o-----o--------------1
| | |
2--o-----|--o--|-----o--o-----2
| | | | |
3--------o--o--|--o--|--o-----3
| | |
4-----o--------o--o--|-----o--4
| | |
5-----o--------------o-----o--5
v} *)
compare_and_swap m1 m2;
compare_and_swap m4 m5;
compare_and_swap m1 m3;
compare_and_swap m2 m3;
compare_and_swap m1 m4;
compare_and_swap m3 m4;
compare_and_swap m2 m5;
compare_and_swap m2 m3;
compare_and_swap m4 m5 [@nontail]
;;
(* choose pivots for the array by sorting 5 elements and examining the center three
elements. The goal is to choose two pivots that will either:
- break the range up into 3 even partitions
or
- eliminate a commonly appearing element by sorting it into the center partition
by itself
To this end we look at the center 3 elements of the 5 and return pairs of equal
elements or the widest range *)
let choose_pivots arr ~(compare : _ -> _ -> _) ~left ~right =
let sixth = (right - left) / 6 in
let m1 = left + sixth in
let m2 = m1 + sixth in
let m3 = m2 + sixth in
let m4 = m3 + sixth in
let m5 = m4 + sixth in
five_element_sort arr ~compare m1 m2 m3 m4 m5;
let m2_val = get arr m2 in
let m3_val = get arr m3 in
let m4_val = get arr m4 in
if compare m2_val m3_val = 0
then m2_val, m3_val, true
else if compare m3_val m4_val = 0
then m3_val, m4_val, true
else m2_val, m4_val, false
;;
let dual_pivot_partition arr ~(compare : _ -> _ -> _) ~left ~right =
let pivot1, pivot2, pivots_equal = choose_pivots arr ~compare ~left ~right in
(* loop invariants:
1. left <= l < r <= right
2. l <= p <= r
3. l <= x < p implies arr[x] >= pivot1
and arr[x] <= pivot2
4. left <= x < l implies arr[x] < pivot1
5. r < x <= right implies arr[x] > pivot2 *)
let rec loop l p r =
let pv = get arr p in
if compare pv pivot1 < 0
then (
swap arr p l;
cont (l + 1) (p + 1) r)
else if compare pv pivot2 > 0
then (
(* loop invariants: same as those of the outer loop *)
let rec scan_backwards r =
if r > p && compare (get arr r) pivot2 > 0 then scan_backwards (r - 1) else r
in
let r = scan_backwards r in
swap arr r p;
cont l p (r - 1))
else cont l (p + 1) r
and cont l p r = if p > r then l, r else loop l p r in
let l, r = cont left left right in
l, r, pivots_equal
;;
let rec intro_sort arr ~max_depth ~compare ~left ~right =
let len = right - left + 1 in
(* This takes care of some edge cases, such as left > right or very short arrays,
since Insertion_sort.sort handles these cases properly. Thus we don't need to
make sure that left and right are valid in recursive calls. *)
if len <= 32
then Insertion_sort.sort arr ~compare ~left ~right
else if max_depth < 0
then Heap_sort.sort arr ~compare ~left ~right
else (
let max_depth = max_depth - 1 in
let l, r, middle_sorted = dual_pivot_partition arr ~compare ~left ~right in
intro_sort arr ~max_depth ~compare ~left ~right:(l - 1);
if not middle_sorted then intro_sort arr ~max_depth ~compare ~left:l ~right:r;
intro_sort arr ~max_depth ~compare ~left:(r + 1) ~right)
;;
let sort arr ~compare ~left ~right =
let heap_sort_switch_depth =
(* We bail out to heap sort at a recursion depth of 32. GNU introsort uses 2lg(n).
The expected recursion depth for perfect 3-way splits is log_3(n).
Using 32 means a balanced 3-way split would work up to 3^32 elements (roughly
2^50 or 10^15). GNU reaches a depth of 32 at 65536 elements.
For small arrays, this makes us less likely to bail out to heap sort, but the
32*N cost before we do is not that much.
For large arrays, this means we are more likely to bail out to heap sort at
some point if we get some bad splits or if the array is huge. But that's only a
constant factor cost in the final stages of recursion.
All in all, this seems to be a small tradeoff and avoids paying a cost to
compute a logarithm at the start. *)
32
in
intro_sort arr ~max_depth:heap_sort_switch_depth ~compare ~left ~right
;;
end
let sort ?pos ?len arr ~(compare : _ -> _ -> _) =
let pos, len =
Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length arr)
in
Intro_sort.sort arr ~compare ~left:pos ~right:(pos + len - 1)
;;
end
[@@inline]
module Sort = Sorter (struct
type nonrec 'a t = 'a t
let get = unsafe_get
let set = unsafe_set
let length = length
end)
let sort = Sort.sort
let of_array t = t
let to_array t = t
let is_empty t = length t = 0
let is_sorted t ~compare =
let i = ref (length t - 1) in
let result = ref true in
while !i > 0 && !result do
let elt_i = unsafe_get t !i in
let elt_i_minus_1 = unsafe_get t (!i - 1) in
if compare elt_i_minus_1 elt_i > 0 then result := false;
decr i
done;
!result
;;
let is_sorted_strictly t ~compare =
let i = ref (length t - 1) in
let result = ref true in
while !i > 0 && !result do
let elt_i = unsafe_get t !i in
let elt_i_minus_1 = unsafe_get t (!i - 1) in
if compare elt_i_minus_1 elt_i >= 0 then result := false;
decr i
done;
!result
;;
let merge a1 a2 ~compare =
let l1 = Array.length a1 in
let l2 = Array.length a2 in
if l1 = 0
then copy a2
else if l2 = 0
then copy a1
else if compare (unsafe_get a2 0) (unsafe_get a1 (l1 - 1)) >= 0
then append a1 a2
else if compare (unsafe_get a1 0) (unsafe_get a2 (l2 - 1)) > 0
then append a2 a1
else (
let len = l1 + l2 in
let merged = create ~len (unsafe_get a1 0) in
let a1_index = ref 0 in
let a2_index = ref 0 in
for i = 0 to len - 1 do
let use_a1 =
if l1 = !a1_index
then false
else if l2 = !a2_index
then true
else compare (unsafe_get a1 !a1_index) (unsafe_get a2 !a2_index) <= 0
in
if use_a1
then (
unsafe_set merged i (unsafe_get a1 !a1_index);
a1_index := !a1_index + 1)
else (
unsafe_set merged i (unsafe_get a2 !a2_index);
a2_index := !a2_index + 1)
done;
merged)
;;
let copy_matrix = map ~f:copy
let folding_map t ~init ~f =
let acc = ref init in
map t ~f:(fun x ->
let new_acc, y = f !acc x in
acc := new_acc;
y) [@nontail]
;;
let fold_map t ~init ~f =
let acc = ref init in
let result =
map t ~f:(fun x ->
let new_acc, y = f !acc x in
acc := new_acc;
y)
in
!acc, result
;;
let fold_result t ~init ~f = Container.fold_result ~fold ~init ~f t
let fold_until t ~init ~f ~finish = Container.fold_until ~fold ~init ~f t ~finish
let sum m t ~f = Container.sum ~fold m t ~f
let[@inline always] extremal_element t ~compare ~keep_left_if =
if is_empty t
then None
else (
let result = ref (unsafe_get t 0) in
for i = 1 to length t - 1 do
let x = unsafe_get t i in
result := Bool.select ((keep_left_if [@inlined]) (compare x !result)) x !result
done;
Some !result)
;;
let min_elt t ~compare =
(extremal_element [@inlined]) t ~compare ~keep_left_if:(fun compare_result ->
compare_result < 0)
;;
let max_elt t ~compare =
(extremal_element [@inlined]) t ~compare ~keep_left_if:(fun compare_result ->
compare_result > 0)
;;
let foldi t ~init ~f =
let acc = ref init in
for i = 0 to length t - 1 do
acc := f i !acc (unsafe_get t i)
done;
!acc
;;
let folding_mapi t ~init ~f =
let acc = ref init in
mapi t ~f:(fun i x ->
let new_acc, y = f i !acc x in
acc := new_acc;
y) [@nontail]
;;
let fold_mapi t ~init ~f =
let acc = ref init in
let result =
mapi t ~f:(fun i x ->
let new_acc, y = f i !acc x in
acc := new_acc;
y)
in
!acc, result
;;
let count t ~f =
let result = ref 0 in
for i = 0 to Array.length t - 1 do
result := !result + (f (Array.unsafe_get t i) |> Bool.to_int)
done;
!result
;;
let counti t ~f =
let result = ref 0 in
for i = 0 to Array.length t - 1 do
result := !result + (f i (Array.unsafe_get t i) |> Bool.to_int)
done;
!result
;;
let concat_map t ~f = concat (to_list (map ~f t))
let concat_mapi t ~f = concat (to_list (mapi ~f t))
let rev_inplace t =
let i = ref 0 in
let j = ref (length t - 1) in
while !i < !j do
swap t !i !j;
incr i;
decr j
done
;;
let rev t =
let t = copy t in
rev_inplace t;
t
;;
let of_list_rev l =
match l with
| [] -> [||]
| a :: l ->
let len = 1 + List.length l in
let t = create ~len a in
let r = ref l in
(* We start at [len - 2] because we already put [a] at [t.(len - 1)]. *)
for i = len - 2 downto 0 do
match !r with
| [] -> assert false
| a :: l ->
t.(i) <- a;
r := l
done;
t
;;
(* [of_list_map] and [of_list_rev_map] are based on functions from the OCaml
distribution. *)
let of_list_map xs ~f =
match xs with
| [] -> [||]
| hd :: tl ->
let a = create ~len:(1 + List.length tl) (f hd) in
let rec fill i = function
| [] -> a
| hd :: tl ->
unsafe_set a i (f hd);
fill (i + 1) tl
in
fill 1 tl [@nontail]
;;
let of_list_mapi xs ~f =
match xs with
| [] -> [||]
| hd :: tl ->
let a = create ~len:(1 + List.length tl) (f 0 hd) in
let rec fill a i = function
| [] -> a
| hd :: tl ->
unsafe_set a i (f i hd);
fill a (i + 1) tl
in
fill a 1 tl [@nontail]
;;
let of_list_rev_map xs ~f =
let t = of_list_map xs ~f in
rev_inplace t;
t
;;
let of_list_rev_mapi xs ~f =
let t = of_list_mapi xs ~f in
rev_inplace t;
t
;;
let filter_mapi t ~f =
let r = ref [||] in
let k = ref 0 in
for i = 0 to length t - 1 do
match f i (unsafe_get t i) with
| None -> ()
| Some a ->
if !k = 0 then r := create ~len:(length t) a;
unsafe_set !r !k a;
incr k
done;
if !k = length t then !r else if !k > 0 then sub ~pos:0 ~len:!k !r else [||]
;;
let filter_map t ~f = filter_mapi t ~f:(fun _i a -> f a) [@nontail]
let filter_opt t = filter_map t ~f:Fn.id
let raise_length_mismatch name n1 n2 =
invalid_argf "length mismatch in %s: %d <> %d" name n1 n2 ()
[@@cold] [@@inline never] [@@local never] [@@specialise never]
;;
let check_length2_exn name t1 t2 =
let n1 = length t1 in
let n2 = length t2 in
if n1 <> n2 then raise_length_mismatch name n1 n2
;;
let iter2_exn t1 t2 ~f =
check_length2_exn "Array.iter2_exn" t1 t2;
iteri t1 ~f:(fun i x1 -> f x1 (unsafe_get t2 i)) [@nontail]
;;
let map2_exn t1 t2 ~f =
check_length2_exn "Array.map2_exn" t1 t2;
init (length t1) ~f:(fun i -> f (unsafe_get t1 i) (unsafe_get t2 i)) [@nontail]
;;
let fold2_exn t1 t2 ~init ~f =
check_length2_exn "Array.fold2_exn" t1 t2;
foldi t1 ~init ~f:(fun i ac x -> f ac x (unsafe_get t2 i)) [@nontail]
;;
let filter t ~f = filter_map t ~f:(fun x -> if f x then Some x else None) [@nontail]
let filteri t ~f = filter_mapi t ~f:(fun i x -> if f i x then Some x else None) [@nontail]
let exists t ~f =
let i = ref (length t - 1) in
let result = ref false in
while !i >= 0 && not !result do
if f (unsafe_get t !i) then result := true else decr i
done;
!result
;;
let existsi t ~f =
let i = ref (length t - 1) in
let result = ref false in
while !i >= 0 && not !result do
if f !i (unsafe_get t !i) then result := true else decr i
done;
!result
;;
let mem t a ~equal = exists t ~f:(equal a) [@nontail]
let for_all t ~f =
let i = ref (length t - 1) in
let result = ref true in
while !i >= 0 && !result do
if not (f (unsafe_get t !i)) then result := false else decr i
done;
!result
;;
let for_alli t ~f =
let length = length t in
let i = ref (length - 1) in
let result = ref true in
while !i >= 0 && !result do
if not (f !i (unsafe_get t !i)) then result := false else decr i
done;
!result
;;
let exists2_exn t1 t2 ~f =
check_length2_exn "Array.exists2_exn" t1 t2;
let i = ref (length t1 - 1) in
let result = ref false in
while !i >= 0 && not !result do
if f (unsafe_get t1 !i) (unsafe_get t2 !i) then result := true else decr i
done;
!result
;;
let for_all2_local_exn t1 t2 ~f =
check_length2_exn "Array.for_all2_exn" t1 t2;
let i = ref (length t1 - 1) in
let result = ref true in
while !i >= 0 && !result do
if not (f (unsafe_get t1 !i) (unsafe_get t2 !i)) then result := false else decr i
done;
!result
;;
let for_all2_exn t1 t2 ~f = for_all2_local_exn t1 t2 ~f
let equal__local equal t1 t2 = length t1 = length t2 && for_all2_local_exn t1 t2 ~f:equal
let equal equal t1 t2 = equal__local equal t1 t2
let map_inplace t ~f =
for i = 0 to length t - 1 do
unsafe_set t i (f (unsafe_get t i))
done
;;
let[@inline always] findi_internal t ~f ~if_found ~if_not_found =
let length = length t in
if length = 0
then if_not_found ()
else (
let i = ref 0 in
let found = ref false in
let value_found = ref (unsafe_get t 0) in
while (not !found) && !i < length do
let value = unsafe_get t !i in
if f !i value
then (
value_found := value;
found := true)
else incr i
done;
if !found then if_found ~i:!i ~value:!value_found else if_not_found ())
;;
let findi t ~f =
findi_internal
t
~f
~if_found:(fun ~i ~value -> Some (i, value))
~if_not_found:(fun () -> None)
;;
let findi_exn t ~f =
findi_internal
t
~f
~if_found:(fun ~i ~value -> i, value)
~if_not_found:(fun () -> raise (Not_found_s (Atom "Array.findi_exn: not found")))
;;
let find_exn t ~f =
findi_internal
t
~f:(fun _i x -> f x)
~if_found:(fun ~i:_ ~value -> value)
~if_not_found:(fun () -> raise (Not_found_s (Atom "Array.find_exn: not found")))
[@nontail]
;;
let find t ~f = Option.map (findi t ~f:(fun _i x -> f x)) ~f:(fun (_i, x) -> x)
let find_map t ~f =
let length = length t in
if length = 0
then None
else (
let i = ref 0 in
let value_found = ref None in
while Option.is_none !value_found && !i < length do
let value = unsafe_get t !i in
value_found := f value;
incr i
done;
!value_found)
;;
let find_map_exn =
let not_found = Not_found_s (Atom "Array.find_map_exn: not found") in
let find_map_exn t ~f =
match find_map t ~f with
| None -> raise not_found
| Some x -> x
in
(* named to preserve symbol in compiled binary *)
find_map_exn
;;
let find_mapi t ~f =
let length = length t in
if length = 0
then None
else (
let i = ref 0 in
let value_found = ref None in
while Option.is_none !value_found && !i < length do
let value = unsafe_get t !i in
value_found := f !i value;
incr i
done;
!value_found)
;;
let find_mapi_exn =
let not_found = Not_found_s (Atom "Array.find_mapi_exn: not found") in
let find_mapi_exn t ~f =
match find_mapi t ~f with
| None -> raise not_found
| Some x -> x
in
(* named to preserve symbol in compiled binary *)
find_mapi_exn
;;
let find_consecutive_duplicate t ~equal =
let n = length t in
if n <= 1
then None
else (
let result = ref None in
let i = ref 1 in
let prev = ref (unsafe_get t 0) in
while !i < n do
let cur = unsafe_get t !i in
if equal cur !prev
then (
result := Some (!prev, cur);
i := n)
else (
prev := cur;
incr i)
done;
!result)
;;
let reduce t ~f =
if length t = 0
then None
else (
let r = ref (unsafe_get t 0) in
for i = 1 to length t - 1 do
r := f !r (unsafe_get t i)
done;
Some !r)
;;
let reduce_exn t ~f =
match reduce t ~f with
| None -> invalid_arg "Array.reduce_exn"
| Some v -> v
;;
let permute = Array_permute.permute
let random_element_exn ?(random_state = Random.State.default) t =
if is_empty t
then failwith "Array.random_element_exn: empty array"
else t.(Random.State.int random_state (length t))
;;
let random_element ?(random_state = Random.State.default) t =
try Some (random_element_exn ~random_state t) with
| _ -> None
;;
let zip t1 t2 =
if length t1 <> length t2 then None else Some (map2_exn t1 t2 ~f:(fun x1 x2 -> x1, x2))
;;
let zip_exn t1 t2 =
if length t1 <> length t2
then failwith "Array.zip_exn"
else map2_exn t1 t2 ~f:(fun x1 x2 -> x1, x2)
;;
let unzip t =
let n = length t in
if n = 0
then [||], [||]
else (
let x, y = t.(0) in
let res1 = create ~len:n x in
let res2 = create ~len:n y in
for i = 1 to n - 1 do
let x, y = t.(i) in
res1.(i) <- x;
res2.(i) <- y
done;
res1, res2)
;;
let sorted_copy t ~compare =
let t1 = copy t in
sort t1 ~compare;
t1
;;
let partition_mapi t ~f =
let (both : _ Either.t t) = mapi t ~f in
let firsts =
filter_map both ~f:(function
| First x -> Some x
| Second _ -> None)
in
let seconds =
filter_map both ~f:(function
| First _ -> None
| Second x -> Some x)
in
firsts, seconds
;;
let partitioni_tf t ~f =
partition_mapi t ~f:(fun i x -> if f i x then First x else Second x) [@nontail]
;;
let partition_map t ~f = partition_mapi t ~f:(fun _ x -> f x) [@nontail]
let partition_tf t ~f = partitioni_tf t ~f:(fun _ x -> f x) [@nontail]
let last t = t.(length t - 1)
(* Convert to a sequence but does not attempt to protect against modification
in the array. *)
let to_sequence_mutable t =
Sequence.unfold_step ~init:0 ~f:(fun i ->
if i >= length t
then Sequence.Step.Done
else Sequence.Step.Yield { value = t.(i); state = i + 1 })
;;
let to_sequence t = to_sequence_mutable (copy t)
let cartesian_product t1 t2 =
if is_empty t1 || is_empty t2
then [||]
else (
let n1 = length t1 in
let n2 = length t2 in
let t = create ~len:(n1 * n2) (t1.(0), t2.(0)) in
let r = ref 0 in
for i1 = 0 to n1 - 1 do
for i2 = 0 to n2 - 1 do
t.(!r) <- t1.(i1), t2.(i2);
incr r
done
done;
t)
;;
let transpose tt =
if length tt = 0
then Some [||]
else (
let width = length tt in
let depth = length tt.(0) in
if exists tt ~f:(fun t -> length t <> depth)
then None
else Some (init depth ~f:(fun d -> init width ~f:(fun w -> tt.(w).(d)))))
;;
let transpose_exn tt =
match transpose tt with
| None -> invalid_arg "Array.transpose_exn"
| Some tt' -> tt'
;;
include Binary_searchable.Make1 (struct
type nonrec 'a t = 'a t
let get = get
let length = length
end)
include Blit.Make1 (struct
type nonrec 'a t = 'a t
let length = length
let create_like ~len t =
if len = 0
then [||]
else (
assert (length t > 0);
create ~len t.(0))
;;
let unsafe_blit = unsafe_blit
end)
let invariant invariant_a t = iter t ~f:invariant_a
module Private = struct
module Sort = Sort
module Sorter = Sorter
end

314
unikernel/duniverse/base/src/array.mli Normal file
View file

@ -0,0 +1,314 @@
(** Fixed-length, mutable vector of elements with O(1) [get] and [set] operations. *)
open! Import
type 'a t = 'a array [@@deriving_inline compare ~localize, globalize, sexp, sexp_grammar]
include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t
include Ppx_compare_lib.Comparable.S_local1 with type 'a t := 'a t
val globalize : ('a -> 'a) -> 'a t -> 'a t
include Sexplib0.Sexpable.S1 with type 'a t := 'a t
val t_sexp_grammar : 'a Sexplib0.Sexp_grammar.t -> 'a t Sexplib0.Sexp_grammar.t
[@@@end]
include Binary_searchable.S1 with type 'a t := 'a t
include Indexed_container.S1_with_creators with type 'a t := 'a t
include Invariant.S1 with type 'a t := 'a t
(** Maximum length of a normal array. The maximum length of a float array is
[max_length/2] on 32-bit machines and [max_length] on 64-bit machines. *)
val max_length : int
(*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when
compiling without cross library inlining. *)
external length : ('a t[@local_opt]) -> int = "%array_length"
(** [Array.get a n] returns the element number [n] of array [a].
The first element has number 0.
The last element has number [Array.length a - 1].
You can also write [a.(n)] instead of [Array.get a n].
Raise [Invalid_argument "index out of bounds"]
if [n] is outside the range 0 to [(Array.length a - 1)]. *)
external get : ('a t[@local_opt]) -> (int[@local_opt]) -> 'a = "%array_safe_get"
(** [Array.set a n x] modifies array [a] in place, replacing
element number [n] with [x].
You can also write [a.(n) <- x] instead of [Array.set a n x].
Raise [Invalid_argument "index out of bounds"]
if [n] is outside the range 0 to [Array.length a - 1]. *)
external set : ('a t[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = "%array_safe_set"
(** Unsafe version of [get]. Can cause arbitrary behavior when used for an out-of-bounds
array access. *)
external unsafe_get : ('a t[@local_opt]) -> (int[@local_opt]) -> 'a = "%array_unsafe_get"
(** Unsafe version of [set]. Can cause arbitrary behavior when used for an out-of-bounds
array access. *)
external unsafe_set
: ('a t[@local_opt])
-> (int[@local_opt])
-> 'a
-> unit
= "%array_unsafe_set"
(** [create ~len x] creates an array of length [len] with the value [x] populated in
each element. *)
val create : len:int -> 'a -> 'a t
(** [create_local ~len x] is like [create]. It allocates the array on the local stack. The
array's elements are still global. *)
val create_local : len:int -> 'a -> 'a t
(** [create_float_uninitialized ~len] creates a float array of length [len] with
uninitialized elements -- that is, they may contain arbitrary, nondeterministic float
values. This can be significantly faster than using [create], when unboxed float array
representations are enabled. *)
val create_float_uninitialized : len:int -> float t
(** [Array.make_matrix dimx dimy e] returns a two-dimensional array (an array of arrays)
with first dimension [dimx] and second dimension [dimy]. All the elements of this new
matrix are initially physically equal to [e]. The element ([x,y]) of a matrix [m] is
accessed with the notation [m.(x).(y)].
Raise [Invalid_argument] if [dimx] or [dimy] is negative or greater than
[Array.max_length].
If the value of [e] is a floating-point number, then the maximum size is only
[Array.max_length / 2]. *)
val make_matrix : dimx:int -> dimy:int -> 'a -> 'a t t
(** [Array.copy_matrix t] returns a fresh copy of the array of arrays [t]. This is
typically used when [t] is a matrix created by [Array.make_matrix]. *)
val copy_matrix : 'a t t -> 'a t t
(** Like [Array.append], but concatenates a list of arrays. *)
val concat : 'a t list -> 'a t
(** [Array.copy a] returns a copy of [a], that is, a fresh array
containing the same elements as [a]. *)
val copy : 'a t -> 'a t
(** [Array.fill a ofs len x] modifies the array [a] in place, storing [x] in elements
number [ofs] to [ofs + len - 1].
Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not designate a valid
subarray of [a]. *)
val fill : 'a t -> pos:int -> len:int -> 'a -> unit
(** [Array.blit v1 o1 v2 o2 len] copies [len] elements from array [v1], starting at
element number [o1], to array [v2], starting at element number [o2]. It works
correctly even if [v1] and [v2] are the same array, and the source and destination
chunks overlap.
Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not designate a valid
subarray of [v1], or if [o2] and [len] do not designate a valid subarray of [v2].
[int_blit] and [float_blit] provide fast bound-checked blits for immediate
data types. The unsafe versions do not bound-check the arguments. *)
include Blit.S1 with type 'a t := 'a t
(** [folding_map] is a version of [map] that threads an accumulator through calls to
[f]. *)
val folding_map : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc * 'b) -> 'b t
val folding_mapi : 'a t -> init:'acc -> f:(int -> 'acc -> 'a -> 'acc * 'b) -> 'b t
(** [Array.fold_map] is a combination of [Array.fold] and [Array.map] that threads an
accumulator through calls to [f]. *)
val fold_map : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc * 'b) -> 'acc * 'b t
val fold_mapi : 'a t -> init:'acc -> f:(int -> 'acc -> 'a -> 'acc * 'b) -> 'acc * 'b t
(** [Array.fold_right f a ~init] computes [f a.(0) (f a.(1) ( ... (f a.(n-1) init) ...))],
where [n] is the length of the array [a]. *)
val fold_right : 'a t -> f:('a -> 'acc -> 'acc) -> init:'acc -> 'acc
(** All sort functions in this module sort in increasing order by default. *)
(** [sort] uses constant heap space. [stable_sort] uses linear heap space.
To sort only part of the array, specify [pos] to be the index to start sorting from
and [len] indicating how many elements to sort. *)
val sort : ?pos:int -> ?len:int -> 'a t -> compare:('a -> 'a -> int) -> unit
val stable_sort : 'a t -> compare:('a -> 'a -> int) -> unit
val is_sorted : 'a t -> compare:('a -> 'a -> int) -> bool
(** [is_sorted_strictly xs ~compare] iff [is_sorted xs ~compare] and no two
consecutive elements in [xs] are equal according to [compare]. *)
val is_sorted_strictly : 'a t -> compare:('a -> 'a -> int) -> bool
(** Merges two arrays: assuming that [a1] and [a2] are sorted according to the comparison
function [compare], [merge a1 a2 ~compare] will return a sorted array containing all
the elements of [a1] and [a2]. If several elements compare equal, the elements of [a1]
will be before the elements of [a2]. *)
val merge : 'a t -> 'a t -> compare:('a -> 'a -> int) -> 'a t
val partitioni_tf : 'a t -> f:(int -> 'a -> bool) -> 'a t * 'a t
val cartesian_product : 'a t -> 'b t -> ('a * 'b) t
(** [transpose] in the sense of a matrix transpose. It returns [None] if the arrays are
not all the same length. *)
val transpose : 'a t t -> 'a t t option
val transpose_exn : 'a t t -> 'a t t
(** [filter_opt array] returns a new array where [None] entries are omitted and [Some x]
entries are replaced with [x]. Note that this changes the index at which elements
will appear. *)
val filter_opt : 'a option t -> 'a t
(** Functions with the 2 suffix raise an exception if the lengths of the two given arrays
aren't the same. *)
val iter2_exn : 'a t -> 'b t -> f:('a -> 'b -> unit) -> unit
val map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
val fold2_exn : 'a t -> 'b t -> init:'acc -> f:('acc -> 'a -> 'b -> 'acc) -> 'acc
(** [for_all2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *)
val for_all2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool
(** [exists2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *)
val exists2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool
(** [swap arr i j] swaps the value at index [i] with that at index [j]. *)
val swap : 'a t -> int -> int -> unit
(** [rev_inplace t] reverses [t] in place. *)
val rev_inplace : 'a t -> unit
(** [rev t] returns a reversed copy of [t] *)
val rev : 'a t -> 'a t
(** [of_list_rev l] converts from list then reverses in place. *)
val of_list_rev : 'a list -> 'a t
(** [of_list_map l ~f] is the same as [of_list (List.map l ~f)]. *)
val of_list_map : 'a list -> f:('a -> 'b) -> 'b t
(** [of_list_mapi l ~f] is the same as [of_list (List.mapi l ~f)]. *)
val of_list_mapi : 'a list -> f:(int -> 'a -> 'b) -> 'b t
(** [of_list_rev_map l ~f] is the same as [of_list (List.rev_map l ~f)]. *)
val of_list_rev_map : 'a list -> f:('a -> 'b) -> 'b t
(** [of_list_rev_mapi l ~f] is the same as [of_list (List.rev_mapi l ~f)]. *)
val of_list_rev_mapi : 'a list -> f:(int -> 'a -> 'b) -> 'b t
(** Modifies an array in place, applying [f] to every element of the array *)
val map_inplace : 'a t -> f:('a -> 'a) -> unit
(** [find_exn f t] returns the first [a] in [t] for which [f t.(i)] is true. It raises
[Stdlib.Not_found] or [Not_found_s] if there is no such [a]. *)
val find_exn : 'a t -> f:('a -> bool) -> 'a
(** Returns the first evaluation of [f] that returns [Some]. Raises [Stdlib.Not_found] or
[Not_found_s] if [f] always returns [None]. *)
val find_map_exn : 'a t -> f:('a -> 'b option) -> 'b
(** [findi_exn t f] returns the first index [i] of [t] for which [f i t.(i)] is true. It
raises [Stdlib.Not_found] or [Not_found_s] if there is no such element. *)
val findi_exn : 'a t -> f:(int -> 'a -> bool) -> int * 'a
(** [find_mapi_exn] is like [find_map_exn] but passes the index as an argument. *)
val find_mapi_exn : 'a t -> f:(int -> 'a -> 'b option) -> 'b
(** [find_consecutive_duplicate t ~equal] returns the first pair of consecutive elements
[(a1, a2)] in [t] such that [equal a1 a2]. They are returned in the same order as
they appear in [t]. *)
val find_consecutive_duplicate : 'a t -> equal:('a -> 'a -> bool) -> ('a * 'a) option
(** [reduce f [a1; ...; an]] is [Some (f (... (f (f a1 a2) a3) ...) an)]. Returns [None]
on the empty array. *)
val reduce : 'a t -> f:('a -> 'a -> 'a) -> 'a option
val reduce_exn : 'a t -> f:('a -> 'a -> 'a) -> 'a
(** [permute ?random_state ?pos ?len t] randomly permutes [t] in place.
To permute only part of the array, specify [pos] to be the index to start permuting
from and [len] indicating how many elements to permute.
[permute] side-effects [random_state] by repeated calls to [Random.State.int]. If
[random_state] is not supplied, [permute] uses [Random.State.default]. *)
val permute : ?random_state:Random.State.t -> ?pos:int -> ?len:int -> 'a t -> unit
(** [random_element ?random_state t] is [None] if [t] is empty, else it is [Some x] for
some [x] chosen uniformly at random from [t].
[random_element] side-effects [random_state] by calling [Random.State.int]. If
[random_state] is not supplied, [random_element] uses [Random.State.default]. *)
val random_element : ?random_state:Random.State.t -> 'a t -> 'a option
val random_element_exn : ?random_state:Random.State.t -> 'a t -> 'a
(** [zip] is like [List.zip], but for arrays. *)
val zip : 'a t -> 'b t -> ('a * 'b) t option
val zip_exn : 'a t -> 'b t -> ('a * 'b) t
(** [unzip] is like [List.unzip], but for arrays. *)
val unzip : ('a * 'b) t -> 'a t * 'b t
(** [sorted_copy ar compare] returns a shallow copy of [ar] that is sorted. Similar to
List.sort *)
val sorted_copy : 'a t -> compare:('a -> 'a -> int) -> 'a t
val last : 'a t -> 'a
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val equal__local : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
(** The input array is copied internally so that future modifications of it do not change
the sequence. *)
val to_sequence : 'a t -> 'a Sequence.t
(** The input array is shared with the sequence and modifications of it will result in
modification of the sequence. *)
val to_sequence_mutable : 'a t -> 'a Sequence.t
(**/**)
(*_ See the Jane Street Style Guide for an explanation of [Private] submodules:
https://opensource.janestreet.com/standards/#private-submodules *)
module Private : sig
module Sort : sig
module type Sort = sig
val sort : 'a t -> compare:('a -> 'a -> int) -> left:int -> right:int -> unit
end
module Insertion_sort : Sort
module Heap_sort : Sort
module Intro_sort : sig
include Sort
val five_element_sort
: 'a t
-> compare:('a -> 'a -> int)
-> int
-> int
-> int
-> int
-> int
-> unit
end
end
module Sorter (S : sig
type 'a t
val get : 'a t -> int -> 'a
val set : 'a t -> int -> 'a -> unit
val length : 'a t -> int
end) : sig
val sort : ?pos:int -> ?len:int -> 'a S.t -> compare:('a -> 'a -> int) -> unit
end
end

156
unikernel/duniverse/base/src/array0.ml Normal file
View file

@ -0,0 +1,156 @@
(* [Array0] defines array functions that are primitives or can be simply defined in terms
of [Stdlib.Array]. [Array0] is intended to completely express the part of [Stdlib.Array]
that [Base] uses -- no other file in Base other than array0.ml should use [Stdlib.Array].
[Array0] has few dependencies, and so is available early in Base's build order. All
Base files that need to use arrays and come before [Base.Array] in build order should
do [module Array = Array0]. This includes uses of subscript syntax ([x.(i)], [x.(i) <-
e]), which the OCaml parser desugars into calls to [Array.get] and [Array.set].
Defining [module Array = Array0] is also necessary because it prevents ocamldep from
mistakenly causing a file to depend on [Base.Array]. *)
open! Import0
module Sys = Sys0
let invalid_argf = Printf.invalid_argf
module Array = struct
external create : int -> 'a -> 'a array = "caml_make_vect"
external create_local : int -> 'a -> 'a array = "caml_make_vect"
external create_float_uninitialized : int -> float array = "caml_make_float_vect"
external get : ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = "%array_safe_get"
external length : ('a array[@local_opt]) -> int = "%array_length"
external set
: ('a array[@local_opt])
-> (int[@local_opt])
-> 'a
-> unit
= "%array_safe_set"
external unsafe_get
: ('a array[@local_opt])
-> (int[@local_opt])
-> 'a
= "%array_unsafe_get"
external unsafe_set
: ('a array[@local_opt])
-> (int[@local_opt])
-> 'a
-> unit
= "%array_unsafe_set"
external unsafe_blit
: src:('a array[@local_opt])
-> src_pos:int
-> dst:('a array[@local_opt])
-> dst_pos:int
-> len:int
-> unit
= "caml_array_blit"
end
include Array
let max_length = Sys.max_array_length
let create ~len x =
try create len x with
| Invalid_argument _ -> invalid_argf "Array.create ~len:%d: invalid length" len ()
;;
let create_local ~len x =
try create_local len x with
| Invalid_argument _ -> invalid_argf "Array.create_local ~len:%d: invalid length" len ()
;;
let create_float_uninitialized ~len =
try create_float_uninitialized len with
| Invalid_argument _ ->
invalid_argf "Array.create_float_uninitialized ~len:%d: invalid length" len ()
;;
let append = Stdlib.Array.append
let blit = Stdlib.Array.blit
let concat = Stdlib.Array.concat
let copy = Stdlib.Array.copy
let fill = Stdlib.Array.fill
let init len ~(f : _ -> _) =
if len = 0
then [||]
else if len < 0
then invalid_arg "Array.init"
else (
let res = create ~len (f 0) in
for i = 1 to Int0.pred len do
unsafe_set res i (f i)
done;
res)
;;
let make_matrix = Stdlib.Array.make_matrix
let of_list = Stdlib.Array.of_list
let sub = Stdlib.Array.sub
let to_list = Stdlib.Array.to_list
let fold t ~init ~(f : _ -> _ -> _) =
let r = ref init in
for i = 0 to length t - 1 do
r := f !r (unsafe_get t i)
done;
!r
;;
let fold_right t ~(f : _ -> _ -> _) ~init =
let r = ref init in
for i = length t - 1 downto 0 do
r := f (unsafe_get t i) !r
done;
!r
;;
let iter t ~(f : _ -> _) =
for i = 0 to length t - 1 do
f (unsafe_get t i)
done
;;
let iteri t ~(f : _ -> _ -> _) =
for i = 0 to length t - 1 do
f i (unsafe_get t i)
done
;;
let map t ~(f : _ -> _) =
let len = length t in
if len = 0
then [||]
else (
let r = create ~len (f (unsafe_get t 0)) in
for i = 1 to len - 1 do
unsafe_set r i (f (unsafe_get t i))
done;
r)
;;
let mapi t ~(f : _ -> _ -> _) =
let len = length t in
if len = 0
then [||]
else (
let r = create ~len (f 0 (unsafe_get t 0)) in
for i = 1 to len - 1 do
unsafe_set r i (f i (unsafe_get t i))
done;
r)
;;
let stable_sort t ~compare = Stdlib.Array.stable_sort t ~cmp:compare
let swap t i j =
let elt_i = t.(i) in
let elt_j = t.(j) in
unsafe_set t i elt_j;
unsafe_set t j elt_i
;;

24
unikernel/duniverse/base/src/array_permute.ml Normal file
View file

@ -0,0 +1,24 @@
(** An internal-only module factored out due to a circular dependency between core_array
and core_list. Contains code for permuting an array. *)
open! Import
include Array0
let permute ?(random_state = Random.State.default) ?(pos = 0) ?len t =
(* Copied from [Ordered_collection_common0] to avoid allocating a tuple when compiling
without flambda. *)
let total_length = length t in
let len =
match len with
| Some l -> l
| None -> total_length - pos
in
Ordered_collection_common0.check_pos_len_exn ~pos ~len ~total_length;
let num_swaps = len - 1 in
for i = num_swaps downto 1 do
let this_i = pos + i in
(* [random_i] is drawn from [pos,this_i] *)
let random_i = pos + Random.State.int random_state (i + 1) in
swap t this_i random_i
done
;;

509
unikernel/duniverse/base/src/avltree.ml Normal file
View file

@ -0,0 +1,509 @@
(* A few small things copied from other parts of Base because they depend on us, so we
can't use them. *)
open! Import
let raise_s = Error.raise_s
module Int = struct
type t = int
let max (x : t) y = if x > y then x else y
end
(* Its important that Empty have no args. It's tempting to make this type a record
(e.g. to hold the compare function), but a lot of memory is saved by Empty being an
immediate, since all unused buckets in the hashtbl don't use any memory (besides the
array cell) *)
type ('k, 'v) t =
| Empty
| Node of
{ mutable left : ('k, 'v) t
; key : 'k
; mutable value : 'v
; mutable height : int
; mutable right : ('k, 'v) t
}
| Leaf of
{ key : 'k
; mutable value : 'v
}
let empty = Empty
let is_empty = function
| Empty -> true
| Leaf _ | Node _ -> false
;;
let height = function
| Empty -> 0
| Leaf _ -> 1
| Node { left = _; key = _; value = _; height; right = _ } -> height
;;
let invariant compare =
let legal_left_key key = function
| Empty -> ()
| Leaf { key = left_key; value = _ }
| Node { left = _; key = left_key; value = _; height = _; right = _ } ->
assert (compare left_key key < 0)
in
let legal_right_key key = function
| Empty -> ()
| Leaf { key = right_key; value = _ }
| Node { left = _; key = right_key; value = _; height = _; right = _ } ->
assert (compare right_key key > 0)
in
let rec inv = function
| Empty | Leaf _ -> ()
| Node { left; key = k; value = _; height = h; right } ->
let hl, hr = height left, height right in
inv left;
inv right;
legal_left_key k left;
legal_right_key k right;
assert (h = Int.max hl hr + 1);
assert (abs (hl - hr) <= 2)
in
inv
;;
let invariant t ~compare = invariant compare t
(* In the following comments,
't is balanced' means that 'invariant t' does not
raise an exception. This implies of course that each node's height field is
correct.
't is balanceable' means that height of the left and right subtrees of t
differ by at most 3. *)
(* @pre: left and right subtrees have correct heights
@post: output has the correct height *)
let update_height = function
| Node ({ left; key = _; value = _; height = old_height; right } as x) ->
let new_height = Int.max (height left) (height right) + 1 in
if new_height <> old_height then x.height <- new_height
| Empty | Leaf _ -> assert false
;;
(* @pre: left and right subtrees are balanced
@pre: tree is balanceable
@post: output is balanced (in particular, height is correct) *)
let balance tree =
match tree with
| Empty | Leaf _ -> tree
| Node ({ left; key = _; value = _; height = _; right } as root_node) ->
let hl = height left
and hr = height right in
(* + 2 is critically important, lowering it to 1 will break the Leaf
assumptions in the code below, and will force us to promote leaf nodes in
the balance routine. It's also faster, since it will balance less often.
Note that the following code is delicate. The update_height calls must
occur in the correct order, since update_height assumes its children have
the correct heights. *)
if hl > hr + 2
then (
match left with
(* It cannot be a leaf, because even if right is empty, a leaf
is only height 1 *)
| Empty | Leaf _ -> assert false
| Node
({ left = left_node_left
; key = _
; value = _
; height = _
; right = left_node_right
} as left_node) ->
if height left_node_left >= height left_node_right
then (
root_node.left <- left_node_right;
left_node.right <- tree;
update_height tree;
update_height left;
left)
else (
(* if right is a leaf, then left must be empty. That means
height is 2. Even if hr is empty we still can't get here. *)
match left_node_right with
| Empty | Leaf _ -> assert false
| Node
({ left = lr_left; key = _; value = _; height = _; right = lr_right } as
lr_node) ->
left_node.right <- lr_left;
root_node.left <- lr_right;
lr_node.right <- tree;
lr_node.left <- left;
update_height left;
update_height tree;
update_height left_node_right;
left_node_right))
else if hr > hl + 2
then (
(* see above for an explanation of why right cannot be a leaf *)
match right with
| Empty | Leaf _ -> assert false
| Node
({ left = right_node_left
; key = _
; value = _
; height = _
; right = right_node_right
} as right_node) ->
if height right_node_right >= height right_node_left
then (
root_node.right <- right_node_left;
right_node.left <- tree;
update_height tree;
update_height right;
right)
else (
(* see above for an explanation of why this cannot be a leaf *)
match right_node_left with
| Empty | Leaf _ -> assert false
| Node
({ left = rl_left; key = _; value = _; height = _; right = rl_right } as
rl_node) ->
right_node.left <- rl_right;
root_node.right <- rl_left;
rl_node.left <- tree;
rl_node.right <- right;
update_height right;
update_height tree;
update_height right_node_left;
right_node_left))
else (
update_height tree;
tree)
;;
(* @pre: t is balanced.
@post: result is balanced, with new node inserted
@post: !added = true iff the shape of the input tree changed. *)
let rec add t ~replace ~compare ~added ~key:k ~data:v =
match t with
| Empty ->
added := true;
Leaf { key = k; value = v }
| Leaf ({ key = k'; value = _ } as r) ->
let c = compare k' k in
(* This compare is reversed on purpose, we are pretending
that the leaf was just inserted instead of the other way
round, that way we only allocate one node. *)
if c = 0
then (
added := false;
if replace then r.value <- v;
t)
else (
added := true;
if c < 0
then Node { left = t; key = k; value = v; height = 2; right = Empty }
else Node { left = Empty; key = k; value = v; height = 2; right = t })
| Node ({ left; key = k'; value = _; height = _; right } as r) ->
let c = compare k k' in
if c = 0
then (
added := false;
if replace then r.value <- v;
t)
else (
if c < 0
then (
let left' = add left ~replace ~added ~compare ~key:k ~data:v in
if not (phys_equal left' left) then r.left <- left')
else (
let right' = add right ~replace ~added ~compare ~key:k ~data:v in
if not (phys_equal right' right) then r.right <- right');
if !added then balance t else t)
;;
let rec first t =
match t with
| Empty -> None
| Leaf { key = k; value = v }
| Node { left = Empty; key = k; value = v; height = _; right = _ } -> Some (k, v)
| Node { left = l; key = _; value = _; height = _; right = _ } -> first l
;;
let rec last t =
match t with
| Empty -> None
| Leaf { key = k; value = v }
| Node { left = _; key = k; value = v; height = _; right = Empty } -> Some (k, v)
| Node { left = _; key = _; value = _; height = _; right = r } -> last r
;;
let[@inline always] rec findi_and_call_impl
t
~compare
k
arg1
arg2
~call_if_found
~call_if_not_found
~if_found
~if_not_found
=
match t with
| Empty -> call_if_not_found ~if_not_found k arg1 arg2
| Leaf { key = k'; value = v } ->
if compare k k' = 0
then call_if_found ~if_found ~key:k' ~data:v arg1 arg2
else call_if_not_found ~if_not_found k arg1 arg2
| Node { left; key = k'; value = v; height = _; right } ->
let c = compare k k' in
if c = 0
then call_if_found ~if_found ~key:k' ~data:v arg1 arg2
else
findi_and_call_impl
(if c < 0 then left else right)
~compare
k
arg1
arg2
~call_if_found
~call_if_not_found
~if_found
~if_not_found
;;
let find_and_call =
let call_if_found ~if_found ~key:_ ~data () () = if_found data in
let call_if_not_found ~if_not_found key () () = if_not_found key in
fun t ~compare k ~if_found ~if_not_found ->
findi_and_call_impl
t
~compare
k
()
()
~call_if_found
~call_if_not_found
~if_found
~if_not_found
;;
let findi_and_call =
let call_if_found ~if_found ~key ~data () () = if_found ~key ~data in
let call_if_not_found ~if_not_found key () () = if_not_found key in
fun t ~compare k ~if_found ~if_not_found ->
findi_and_call_impl
t
~compare
k
()
()
~call_if_found
~call_if_not_found
~if_found
~if_not_found
;;
let find_and_call1 =
let call_if_found ~if_found ~key:_ ~data arg () = if_found data arg in
let call_if_not_found ~if_not_found key arg () = if_not_found key arg in
fun t ~compare k ~a ~if_found ~if_not_found ->
findi_and_call_impl
t
~compare
k
a
()
~call_if_found
~call_if_not_found
~if_found
~if_not_found
;;
let findi_and_call1 =
let call_if_found ~if_found ~key ~data arg () = if_found ~key ~data arg in
let call_if_not_found ~if_not_found key arg () = if_not_found key arg in
fun t ~compare k ~a ~if_found ~if_not_found ->
findi_and_call_impl
t
~compare
k
a
()
~call_if_found
~call_if_not_found
~if_found
~if_not_found
;;
let find_and_call2 =
let call_if_found ~if_found ~key:_ ~data arg1 arg2 = if_found data arg1 arg2 in
let call_if_not_found ~if_not_found key arg1 arg2 = if_not_found key arg1 arg2 in
fun t ~compare k ~a ~b ~if_found ~if_not_found ->
findi_and_call_impl
t
~compare
k
a
b
~call_if_found
~call_if_not_found
~if_found
~if_not_found
;;
let findi_and_call2 =
let call_if_found ~if_found ~key ~data arg1 arg2 = if_found ~key ~data arg1 arg2 in
let call_if_not_found ~if_not_found key arg1 arg2 = if_not_found key arg1 arg2 in
fun t ~compare k ~a ~b ~if_found ~if_not_found ->
findi_and_call_impl
t
~compare
k
a
b
~call_if_found
~call_if_not_found
~if_found
~if_not_found
;;
let find =
let if_found v = Some v in
let if_not_found _ = None in
fun t ~compare k -> find_and_call t ~compare k ~if_found ~if_not_found
;;
let mem =
let if_found _ = true in
let if_not_found _ = false in
fun t ~compare k -> find_and_call t ~compare k ~if_found ~if_not_found
;;
let rec remove =
let rec min_elt tree =
match tree with
| Empty -> Empty
| Leaf _ -> tree
| Node { left = Empty; key = _; value = _; height = _; right = _ } -> tree
| Node { left; key = _; value = _; height = _; right = _ } -> min_elt left
in
let rec remove_min_elt tree =
match tree with
| Empty -> assert false
| Leaf _ -> Empty
| Node { left = Empty; key = _; value = _; height = _; right } -> right
| Node { left = Leaf _; key = k; value = v; height = _; right = Empty } ->
Leaf { key = k; value = v }
| Node ({ left; key = _; value = _; height = _; right = _ } as r) ->
r.left <- remove_min_elt left;
balance tree
in
let merge t1 t2 =
match t1, t2 with
| Empty, t -> t
| t, Empty -> t
| _, _ ->
let tree = min_elt t2 in
balance
(match tree with
| Empty -> assert false
| Leaf { key = k; value = v } ->
let t2 = remove_min_elt t2 in
Node
{ left = t1
; key = k
; value = v
; height = Int.max (height t1) (height t2) + 1
; right = t2
}
| Node r ->
r.right <- remove_min_elt t2;
r.left <- t1;
tree)
in
fun t ~removed ~compare k ->
match t with
| Empty ->
removed := false;
Empty
| Leaf { key = k'; value = _ } ->
if compare k k' = 0
then (
removed := true;
Empty)
else (
removed := false;
t)
| Node ({ left; key = k'; value = _; height = _; right } as r) ->
let c = compare k k' in
if c = 0
then (
removed := true;
merge left right)
else (
if c < 0
then (
let left' = remove left ~removed ~compare k in
if not (phys_equal left' left) then r.left <- left')
else (
let right' = remove right ~removed ~compare k in
if not (phys_equal right' right) then r.right <- right');
if !removed then balance t else t)
;;
let rec fold t ~init ~f =
match t with
| Empty -> init
| Leaf { key; value = data } -> f ~key ~data init
| Node
{ left = Leaf { key = lkey; value = ldata }
; key
; value = data
; height = _
; right = Leaf { key = rkey; value = rdata }
} -> f ~key:rkey ~data:rdata (f ~key ~data (f ~key:lkey ~data:ldata init))
| Node
{ left = Leaf { key = lkey; value = ldata }
; key
; value = data
; height = _
; right = Empty
} -> f ~key ~data (f ~key:lkey ~data:ldata init)
| Node
{ left = Empty
; key
; value = data
; height = _
; right = Leaf { key = rkey; value = rdata }
} -> f ~key:rkey ~data:rdata (f ~key ~data init)
| Node
{ left; key; value = data; height = _; right = Leaf { key = rkey; value = rdata } }
-> f ~key:rkey ~data:rdata (f ~key ~data (fold left ~init ~f))
| Node
{ left = Leaf { key = lkey; value = ldata }; key; value = data; height = _; right }
-> fold right ~init:(f ~key ~data (f ~key:lkey ~data:ldata init)) ~f
| Node { left; key; value = data; height = _; right } ->
fold right ~init:(f ~key ~data (fold left ~init ~f)) ~f
;;
let rec iter t ~f =
match t with
| Empty -> ()
| Leaf { key; value = data } -> f ~key ~data
| Node { left; key; value = data; height = _; right } ->
iter left ~f;
f ~key ~data;
iter right ~f
;;
let rec mapi_inplace t ~f =
match t with
| Empty -> ()
| Leaf ({ key; value } as t) -> t.value <- f ~key ~data:value
| Node ({ left; key; value; height = _; right } as t) ->
mapi_inplace ~f left;
t.value <- f ~key ~data:value;
mapi_inplace ~f right
;;
let choose_exn = function
| Empty -> raise_s (Sexp.message "[Avltree.choose_exn] of empty hashtbl" [])
| Leaf { key; value; _ } | Node { key; value; _ } -> key, value
;;

172
unikernel/duniverse/base/src/avltree.mli Normal file
View file

@ -0,0 +1,172 @@
(** A low-level, mutable AVL tree.
It is not intended to be used directly by casual users. It is used for implementing
other data structures. The interface is somewhat ugly, and it's that way for a
reason: the goal of this module is minimum memory overhead and maximum performance.
{2 Caveats}
1. [compare] is passed to every function where it is used. If you pass a different
[compare] to functions on the same tree, then behavior is indeterminate. Why? Because
otherwise we'd need a top-level record to store [compare], and when building a hash
table, or other structure, that little [t] is a block that increases memory
overhead. However, if an empty tree is just a constructor [Empty], then it's just a
number, and uses no extra memory beyond the array bucket that holds it. That's the
first secret of how Hashtbl's memory overhead isn't higher than INRIA's, even though
it uses a tree instead of a list for buckets.
2. But if it's mutable, why do all the "mutators" return [t]? Answer: it is mutable,
but the root node might change due to balancing. Since we have no top-level record to
hold the current root node (see point 1), you have to do it. If you fail to do it, and
use an old root node, you're responsible for the (sure to be nasty) consequences.
3. What on earth is up with the [~removed] argument to some functions? See point 1:
since there is no top-level node, it isn't possible to keep track of how many nodes
are in the tree unless each mutator tells you whether or not it added or removed a
node (vs. replacing an existing one). If you intend to keep a count (as you must in a
hash table), then you will need to pay attention to this flag.
After all this, you're probably asking yourself whether all these hacks are worth
it. Yes! They are! With them, we built a hash table that is faster than INRIA's (no
small feat) with the same memory overhead, sane add semantics (the add semantics they
used were a performance hack), and worst-case log(N) insertion, lookup, and
removal. *)
open! Import
(** We expose [t] to allow an optimization in Hashtbl that makes iter and fold more than
twice as fast. We keep the type private to reduce opportunities for external code to
violate avltree invariants. *)
type ('k, 'v) t = private
| Empty
| Node of
{ mutable left : ('k, 'v) t
; key : 'k
; mutable value : 'v
; mutable height : int
; mutable right : ('k, 'v) t
}
| Leaf of
{ key : 'k
; mutable value : 'v
}
val empty : ('k, 'v) t
val is_empty : _ t -> bool
(** Checks invariants, raising an exception if any invariants fail. *)
val invariant : ('k, 'v) t -> compare:('k -> 'k -> int) -> unit
(** Adds the specified key and data to the tree destructively (previous [t]'s are no
longer valid) using the specified comparison function. O(log(N)) time, O(1) space.
The returned [t] is the new root node of the tree, and should be used on all further
calls to any other function in this module. The bool [ref], added, will be set to
[true] if a new node is added to the tree, or [false] if an existing node is replaced
(in the case that the key already exists).
If [replace] (default true) is true then [add] will overwrite any existing mapping for
[key]. If [replace] is false, and there is an existing mapping for key, then [add] has
no effect. *)
val add
: ('k, 'v) t
-> replace:bool
-> compare:('k -> 'k -> int)
-> added:bool ref
-> key:'k
-> data:'v
-> ('k, 'v) t
(** Returns the first (leftmost) or last (rightmost) element in the tree. *)
val first : ('k, 'v) t -> ('k * 'v) option
val last : ('k, 'v) t -> ('k * 'v) option
(** If the specified key exists in the tree, returns the corresponding value. O(log(N))
time and O(1) space. *)
val find : ('k, 'v) t -> compare:('k -> 'k -> int) -> 'k -> 'v option
(** [find_and_call t ~compare k ~if_found ~if_not_found]
is equivalent to:
[match find t ~compare k with Some v -> if_found v | None -> if_not_found k]
except that it doesn't allocate the option. *)
val find_and_call
: ('k, 'v) t
-> compare:('k -> 'k -> int)
-> 'k
-> if_found:('v -> 'a)
-> if_not_found:('k -> 'a)
-> 'a
val find_and_call1
: ('k, 'v) t
-> compare:('k -> 'k -> int)
-> 'k
-> a:'a
-> if_found:('v -> 'a -> 'b)
-> if_not_found:('k -> 'a -> 'b)
-> 'b
val find_and_call2
: ('k, 'v) t
-> compare:('k -> 'k -> int)
-> 'k
-> a:'a
-> b:'b
-> if_found:('v -> 'a -> 'b -> 'c)
-> if_not_found:('k -> 'a -> 'b -> 'c)
-> 'c
val findi_and_call
: ('k, 'v) t
-> compare:('k -> 'k -> int)
-> 'k
-> if_found:(key:'k -> data:'v -> 'a)
-> if_not_found:('k -> 'a)
-> 'a
val findi_and_call1
: ('k, 'v) t
-> compare:('k -> 'k -> int)
-> 'k
-> a:'a
-> if_found:(key:'k -> data:'v -> 'a -> 'b)
-> if_not_found:('k -> 'a -> 'b)
-> 'b
val findi_and_call2
: ('k, 'v) t
-> compare:('k -> 'k -> int)
-> 'k
-> a:'a
-> b:'b
-> if_found:(key:'k -> data:'v -> 'a -> 'b -> 'c)
-> if_not_found:('k -> 'a -> 'b -> 'c)
-> 'c
(** Returns true if key is present in the tree, and false otherwise. *)
val mem : ('k, 'v) t -> compare:('k -> 'k -> int) -> 'k -> bool
(** Removes key destructively from the tree if it exists, returning the new root node.
Previous root nodes are not usable anymore; do so at your peril. The [removed] ref
will be set to true if a node was actually removed, and false otherwise. *)
val remove
: ('k, 'v) t
-> removed:bool ref
-> compare:('k -> 'k -> int)
-> 'k
-> ('k, 'v) t
(** Folds over the tree. *)
val fold : ('k, 'v) t -> init:'acc -> f:(key:'k -> data:'v -> 'acc -> 'acc) -> 'acc
(** Iterates over the tree. *)
val iter : ('k, 'v) t -> f:(key:'k -> data:'v -> unit) -> unit
(** Map over the the tree, changing the data in place. *)
val mapi_inplace : ('k, 'v) t -> f:(key:'k -> data:'v -> 'v) -> unit
val choose_exn : ('k, 'v) t -> 'k * 'v

48
unikernel/duniverse/base/src/backtrace.ml Normal file
View file

@ -0,0 +1,48 @@
open! Import
module Sys = Sys0
type t = Stdlib.Printexc.raw_backtrace
let elide = ref false
let elided_message = "<backtrace elided in test>"
let get ?(at_most_num_frames = Int.max_value) () =
Stdlib.Printexc.get_callstack at_most_num_frames
;;
let to_string t =
if !elide then elided_message else Stdlib.Printexc.raw_backtrace_to_string t
;;
let to_string_list t = String.split_lines (to_string t)
let sexp_of_t t = Sexp.List (List.map (to_string_list t) ~f:(fun x -> Sexp.Atom x))
module Exn = struct
let set_recording = Stdlib.Printexc.record_backtrace
let am_recording = Stdlib.Printexc.backtrace_status
let most_recent () = Stdlib.Printexc.get_raw_backtrace ()
let most_recent_for_exn exn =
if Exn.is_phys_equal_most_recent exn then Some (most_recent ()) else None
;;
(* We turn on backtraces by default if OCAMLRUNPARAM doesn't explicitly mention them. *)
let maybe_set_recording () =
let ocamlrunparam_mentions_backtraces =
match Sys.getenv "OCAMLRUNPARAM" with
| None -> false
| Some x -> List.exists (String.split x ~on:',') ~f:(String.is_prefix ~prefix:"b")
in
if not ocamlrunparam_mentions_backtraces then set_recording true
;;
(* the caller set something, they are responsible *)
let with_recording b ~f =
let saved = am_recording () in
set_recording b;
Exn.protect ~f ~finally:(fun () -> set_recording saved)
;;
end
let initialize_module () = Exn.maybe_set_recording ()

105
unikernel/duniverse/base/src/backtrace.mli Normal file
View file

@ -0,0 +1,105 @@
(** Module for managing stack backtraces.
The [Backtrace] module deals with two different kinds of backtraces:
+ Snapshots of the stack obtained on demand ([Backtrace.get])
+ The stack frames unwound when an exception is raised ([Backtrace.Exn])
*)
open! Import
(** A [Backtrace.t] is a snapshot of the stack obtained by calling [Backtrace.get]. It is
represented as a string with newlines separating the frames. [sexp_of_t] splits the
string at newlines and removes some of the cruft, leaving a human-friendly list of
frames, but [to_string] does not. *)
type t = Stdlib.Printexc.raw_backtrace [@@deriving_inline sexp_of]
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
val get : ?at_most_num_frames:int -> unit -> t
val to_string : t -> string
val to_string_list : t -> string list
(** The value of [elide] controls the behavior of backtrace serialization functions such
as {!to_string}, {!to_string_list}, and {!sexp_of_t}. When set to [false], these
functions behave as expected, returning a faithful representation of their argument.
When set to [true], these functions will ignore their argument and return a message
indicating that behavior.
The default value is [false]. *)
val elide : bool ref
(** [Backtrace.Exn] has functions for controlling and printing the backtrace of the most
recently raised exception.
When an exception is raised, the runtime "unwinds" the stack, i.e., removes stack
frames, until it reaches a frame with an exception handler. It then matches the
exception against the patterns in the handler. If the exception matches, then the
program continues. If not, then the runtime continues unwinding the stack to the next
handler.
If [am_recording () = true], then while the runtime is unwinding the stack, it keeps
track of the part of the stack that is unwound. This is available as a backtrace via
[most_recent ()]. Calling [most_recent] if [am_recording () = false] will yield the
empty backtrace.
With [am_recording () = true], OCaml keeps only a backtrace for the most recently
raised exception. When one raises an exception, OCaml checks if it is physically equal
to the most recently raised exception. If it is, then OCaml appends the string
representation of the stack unwound by the current raise to the stored backtrace. If
the exception being raised is not physically equally to the most recently raised
exception, then OCaml starts recording a new backtrace. Thus one must call
[most_recent] before a subsequent [raise] of a (physically) distinct exception, or the
backtrace is lost.
The initial value of [am_recording ()] is determined by the environment variable
OCAMLRUNPARAM. If OCAMLRUNPARAM is set and contains a "b" parameter, then
[am_recording ()] is set according to OCAMLRUNPARAM: true if "b" or "b=1" appears;
false if "b=0" appears. If OCAMLRUNPARAM is not set (as is always the case when
running in a web browser) or does not contain a "b" parameter, then [am_recording ()]
is initially true.
This is the same functionality as provided by the OCaml stdlib [Printexc] functions
[backtrace_status], [record_backtraces], [get_backtrace]. *)
module Exn : sig
val am_recording : unit -> bool
val set_recording : bool -> unit
val with_recording : bool -> f:(unit -> 'a) -> 'a
(** [most_recent ()] returns a backtrace containing the stack that was unwound by the
most recently raised exception.
Normally this includes just the function calls that lead from the exception handler
being set up to the exception being raised. However, due to inlining, the stack
frame that has the exception handler may correspond to a chain of multiple function
calls. All of those function calls are then reported in this backtrace, even though
they are not themselves on the path from the exception handler to the "raise". *)
val most_recent : unit -> t
(** [most_recent_for_exn exn] returns a backtrace containing the stack that was unwound
when raising [exn] if [exn] is the most recently raised exception. Otherwise it
returns [None].
Note that this may return a misleading backtrace instead of [None] if
different raise events happen to raise physically equal exceptions.
Consider the example below. Here if [e = Not_found] and [g] usees
[Not_found] internally then the backtrace will correspond to the
internal backtrace in [g] instead of the one used in [f], which is
not desirable.
{[
try f () with
| e ->
g ();
let bt = Backtrace.Exn.most_recent_for_exn e in
...
]}
*)
val most_recent_for_exn : Exn.t -> t option
end
(** User code never calls this. It is called only in [base.ml], as a top-level side
effect, to initialize [am_recording ()] as specified above. *)
val initialize_module : unit -> unit

712
unikernel/duniverse/base/src/base.ml Normal file
View file

@ -0,0 +1,712 @@
(** This module is the toplevel of the Base library; it's what you get when you write
[open Base].
The goal of Base is both to be a more complete standard library, with richer APIs,
and to be more consistent in its design. For instance, in the standard library
some things have modules and others don't; in Base, everything is a module.
Base extends some modules and data structures from the standard library, like [Array],
[Buffer], [Bytes], [Char], [Hashtbl], [Int32], [Int64], [Lazy], [List], [Map],
[Nativeint], [Printf], [Random], [Set], [String], [Sys], and [Uchar]. One key
difference is that Base doesn't use exceptions as much as the standard library and
instead makes heavy use of the [Result] type, as in:
{[ type ('a,'b) result = Ok of 'a | Error of 'b ]}
Base also adds entirely new modules, most notably:
- [Comparable], [Comparator], and [Comparisons] in lieu of polymorphic compare.
- [Container], which provides a consistent interface across container-like data
structures (arrays, lists, strings).
- [Result], [Error], and [Or_error], supporting the or-error pattern.
*)
(*_ We hide this from the web docs because the line wrapping is bad, making it
pretty much inscrutable. *)
(**/**)
(* The intent is to shadow all of INRIA's standard library. Modules below would cause
compilation errors without being removed from [Shadow_stdlib] before inclusion. *)
include (
Shadow_stdlib :
module type of struct
include Shadow_stdlib
end
(* Modules defined in Base *)
with module Array := Shadow_stdlib.Array
with module Atomic := Shadow_stdlib.Atomic
with module Bool := Shadow_stdlib.Bool
with module Buffer := Shadow_stdlib.Buffer
with module Bytes := Shadow_stdlib.Bytes
with module Char := Shadow_stdlib.Char
with module Condition := Shadow_stdlib.Condition
with module Either := Shadow_stdlib.Either
with module Float := Shadow_stdlib.Float
with module Hashtbl := Shadow_stdlib.Hashtbl
with module In_channel := Shadow_stdlib.In_channel
with module Int := Shadow_stdlib.Int
with module Int32 := Shadow_stdlib.Int32
with module Int64 := Shadow_stdlib.Int64
with module Lazy := Shadow_stdlib.Lazy
with module List := Shadow_stdlib.List
with module Map := Shadow_stdlib.Map
with module Nativeint := Shadow_stdlib.Nativeint
with module Option := Shadow_stdlib.Option
with module Out_channel := Shadow_stdlib.Out_channel
with module Printf := Shadow_stdlib.Printf
with module Queue := Shadow_stdlib.Queue
with module Random := Shadow_stdlib.Random
with module Result := Shadow_stdlib.Result
with module Set := Shadow_stdlib.Set
with module Semaphore := Shadow_stdlib.Semaphore
with module Stack := Shadow_stdlib.Stack
with module String := Shadow_stdlib.String
with module Sys := Shadow_stdlib.Sys
with module Uchar := Shadow_stdlib.Uchar
with module Unit := Shadow_stdlib.Unit
(* OCaml 5-related modules we don't want to start shadowing yet. *)
with module Domain := Shadow_stdlib.Domain
with module Type := Shadow_stdlib.Type
(* Support for generated lexers *)
with module Lexing := Shadow_stdlib.Lexing
with type ('a, 'b, 'c) format := ('a, 'b, 'c) format
with type ('a, 'b, 'c, 'd) format4 := ('a, 'b, 'c, 'd) format4
with type ('a, 'b, 'c, 'd, 'e, 'f) format6 := ('a, 'b, 'c, 'd, 'e, 'f) format6
with type 'a ref := 'a ref)
[@ocaml.warning "-3"]
(**/**)
open! Import
module Applicative = Applicative
module Array = Array
module Avltree = Avltree
module Backtrace = Backtrace
module Binary_search = Binary_search
module Binary_searchable = Binary_searchable
module Blit = Blit
module Bool = Bool
module Buffer = Buffer
module Bytes = Bytes
module Char = Char
module Comparable = Comparable
module Comparator = Comparator
module Comparisons = Comparisons
module Container = Container
module Either = Either
module Equal = Equal
module Error = Error
module Exn = Exn
module Field = Field
module Float = Float
module Floatable = Floatable
module Fn = Fn
module Formatter = Formatter
module Hash = Hash
module Hash_set = Hash_set
module Hashable = Hashable
module Hasher = Hasher
module Hashtbl = Hashtbl
module Identifiable = Identifiable
module Indexed_container = Indexed_container
module Info = Info
module Int = Int
module Int32 = Int32
module Int63 = Int63
module Int64 = Int64
module Intable = Intable
module Int_math = Int_math
module Invariant = Invariant
module Dictionary_immutable = Dictionary_immutable
module Dictionary_mutable = Dictionary_mutable
module Lazy = Lazy
module List = List
module Map = Map
module Maybe_bound = Maybe_bound
module Monad = Monad
module Nativeint = Nativeint
module Nothing = Nothing
module Option = Option
module Option_array = Option_array
module Or_error = Or_error
module Ordered_collection_common = Ordered_collection_common
module Ordering = Ordering
module Poly = Poly
module Pretty_printer = Pretty_printer
module Printf = Printf
module Linked_queue = Linked_queue
module Queue = Queue
module Random = Random
module Ref = Ref
module Result = Result
module Sequence = Sequence
module Set = Set
module Sexpable = Sexpable
module Sign = Sign
module Sign_or_nan = Sign_or_nan
module Source_code_position = Source_code_position
module Stack = Stack
module Staged = Staged
module String = String
module Stringable = Stringable
module Sys = Sys
module T = T
module Type_equal = Type_equal
module Uniform_array = Uniform_array
module Unit = Unit
module Uchar = Uchar
module Variant = Variant
module With_return = With_return
module Word_size = Word_size
(* Avoid a level of indirection for uses of the signatures defined in [T]. *)
include T
(* This is a hack so that odoc creates better documentation. *)
module Sexp = struct
include Sexp_with_comparable (** @inline *)
end
(* [Int_string_conversions] is separated from [Int_conversions] for dependency reasons,
but this separation is not important for clients. *)
module Int_conversions = struct
include Int_conversions
include Int_string_conversions
end
(**/**)
module Exported_for_specific_uses = struct
module Fieldslib = Fieldslib
module Globalize = Globalize
module Obj_local = Obj_local
module Ppx_compare_lib = Ppx_compare_lib
module Ppx_enumerate_lib = Ppx_enumerate_lib
module Ppx_hash_lib = Ppx_hash_lib
module Variantslib = Variantslib
let am_testing = am_testing
end
(**/**)
module Export = struct
(* [deriving hash] is missing for [array] and [ref] since these types are mutable. *)
type 'a array = 'a Array.t
[@@deriving_inline compare ~localize, equal ~localize, globalize, sexp, sexp_grammar]
let compare_array__local : 'a. ('a -> 'a -> int) -> 'a array -> 'a array -> int =
Array.compare__local
;;
let compare_array : 'a. ('a -> 'a -> int) -> 'a array -> 'a array -> int = Array.compare
let equal_array__local : 'a. ('a -> 'a -> bool) -> 'a array -> 'a array -> bool =
Array.equal__local
;;
let equal_array : 'a. ('a -> 'a -> bool) -> 'a array -> 'a array -> bool = Array.equal
let globalize_array : 'a. ('a -> 'a) -> 'a array -> 'a array =
fun (type a__017_) : ((a__017_ -> a__017_) -> a__017_ array -> a__017_ array) ->
Array.globalize
;;
let array_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a array =
Array.t_of_sexp
;;
let sexp_of_array : 'a. ('a -> Sexplib0.Sexp.t) -> 'a array -> Sexplib0.Sexp.t =
Array.sexp_of_t
;;
let array_sexp_grammar :
'a. 'a Sexplib0.Sexp_grammar.t -> 'a array Sexplib0.Sexp_grammar.t
=
fun _'a_sexp_grammar -> Array.t_sexp_grammar _'a_sexp_grammar
;;
[@@@end]
type bool = Bool.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_bool__local = (Bool.compare__local : bool -> bool -> int)
let compare_bool = (fun a b -> compare_bool__local a b : bool -> bool -> int)
let equal_bool__local = (Bool.equal__local : bool -> bool -> bool)
let equal_bool = (fun a b -> equal_bool__local a b : bool -> bool -> bool)
let (globalize_bool : bool -> bool) = (Bool.globalize : bool -> bool)
let (hash_fold_bool :
Ppx_hash_lib.Std.Hash.state -> bool -> Ppx_hash_lib.Std.Hash.state)
=
Bool.hash_fold_t
and (hash_bool : bool -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = Bool.hash in
fun x -> func x
;;
let bool_of_sexp = (Bool.t_of_sexp : Sexplib0.Sexp.t -> bool)
let sexp_of_bool = (Bool.sexp_of_t : bool -> Sexplib0.Sexp.t)
let (bool_sexp_grammar : bool Sexplib0.Sexp_grammar.t) = Bool.t_sexp_grammar
[@@@end]
type char = Char.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_char__local = (Char.compare__local : char -> char -> int)
let compare_char = (fun a b -> compare_char__local a b : char -> char -> int)
let equal_char__local = (Char.equal__local : char -> char -> bool)
let equal_char = (fun a b -> equal_char__local a b : char -> char -> bool)
let (globalize_char : char -> char) = (Char.globalize : char -> char)
let (hash_fold_char :
Ppx_hash_lib.Std.Hash.state -> char -> Ppx_hash_lib.Std.Hash.state)
=
Char.hash_fold_t
and (hash_char : char -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = Char.hash in
fun x -> func x
;;
let char_of_sexp = (Char.t_of_sexp : Sexplib0.Sexp.t -> char)
let sexp_of_char = (Char.sexp_of_t : char -> Sexplib0.Sexp.t)
let (char_sexp_grammar : char Sexplib0.Sexp_grammar.t) = Char.t_sexp_grammar
[@@@end]
type exn = Exn.t [@@deriving_inline sexp_of]
let sexp_of_exn = (Exn.sexp_of_t : exn -> Sexplib0.Sexp.t)
[@@@end]
type float = Float.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_float__local = (Float.compare__local : float -> float -> int)
let compare_float = (fun a b -> compare_float__local a b : float -> float -> int)
let equal_float__local = (Float.equal__local : float -> float -> bool)
let equal_float = (fun a b -> equal_float__local a b : float -> float -> bool)
let (globalize_float : float -> float) = (Float.globalize : float -> float)
let (hash_fold_float :
Ppx_hash_lib.Std.Hash.state -> float -> Ppx_hash_lib.Std.Hash.state)
=
Float.hash_fold_t
and (hash_float : float -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = Float.hash in
fun x -> func x
;;
let float_of_sexp = (Float.t_of_sexp : Sexplib0.Sexp.t -> float)
let sexp_of_float = (Float.sexp_of_t : float -> Sexplib0.Sexp.t)
let (float_sexp_grammar : float Sexplib0.Sexp_grammar.t) = Float.t_sexp_grammar
[@@@end]
type int = Int.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_int__local = (Int.compare__local : int -> int -> int)
let compare_int = (fun a b -> compare_int__local a b : int -> int -> int)
let equal_int__local = (Int.equal__local : int -> int -> bool)
let equal_int = (fun a b -> equal_int__local a b : int -> int -> bool)
let (globalize_int : int -> int) = (Int.globalize : int -> int)
let (hash_fold_int : Ppx_hash_lib.Std.Hash.state -> int -> Ppx_hash_lib.Std.Hash.state) =
Int.hash_fold_t
and (hash_int : int -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = Int.hash in
fun x -> func x
;;
let int_of_sexp = (Int.t_of_sexp : Sexplib0.Sexp.t -> int)
let sexp_of_int = (Int.sexp_of_t : int -> Sexplib0.Sexp.t)
let (int_sexp_grammar : int Sexplib0.Sexp_grammar.t) = Int.t_sexp_grammar
[@@@end]
type int32 = Int32.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_int32__local = (Int32.compare__local : int32 -> int32 -> int)
let compare_int32 = (fun a b -> compare_int32__local a b : int32 -> int32 -> int)
let equal_int32__local = (Int32.equal__local : int32 -> int32 -> bool)
let equal_int32 = (fun a b -> equal_int32__local a b : int32 -> int32 -> bool)
let (globalize_int32 : int32 -> int32) = (Int32.globalize : int32 -> int32)
let (hash_fold_int32 :
Ppx_hash_lib.Std.Hash.state -> int32 -> Ppx_hash_lib.Std.Hash.state)
=
Int32.hash_fold_t
and (hash_int32 : int32 -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = Int32.hash in
fun x -> func x
;;
let int32_of_sexp = (Int32.t_of_sexp : Sexplib0.Sexp.t -> int32)
let sexp_of_int32 = (Int32.sexp_of_t : int32 -> Sexplib0.Sexp.t)
let (int32_sexp_grammar : int32 Sexplib0.Sexp_grammar.t) = Int32.t_sexp_grammar
[@@@end]
type int64 = Int64.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_int64__local = (Int64.compare__local : int64 -> int64 -> int)
let compare_int64 = (fun a b -> compare_int64__local a b : int64 -> int64 -> int)
let equal_int64__local = (Int64.equal__local : int64 -> int64 -> bool)
let equal_int64 = (fun a b -> equal_int64__local a b : int64 -> int64 -> bool)
let (globalize_int64 : int64 -> int64) = (Int64.globalize : int64 -> int64)
let (hash_fold_int64 :
Ppx_hash_lib.Std.Hash.state -> int64 -> Ppx_hash_lib.Std.Hash.state)
=
Int64.hash_fold_t
and (hash_int64 : int64 -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = Int64.hash in
fun x -> func x
;;
let int64_of_sexp = (Int64.t_of_sexp : Sexplib0.Sexp.t -> int64)
let sexp_of_int64 = (Int64.sexp_of_t : int64 -> Sexplib0.Sexp.t)
let (int64_sexp_grammar : int64 Sexplib0.Sexp_grammar.t) = Int64.t_sexp_grammar
[@@@end]
type 'a list = 'a List.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_list__local : 'a. ('a -> 'a -> int) -> 'a list -> 'a list -> int =
List.compare__local
;;
let compare_list : 'a. ('a -> 'a -> int) -> 'a list -> 'a list -> int = List.compare
let equal_list__local : 'a. ('a -> 'a -> bool) -> 'a list -> 'a list -> bool =
List.equal__local
;;
let equal_list : 'a. ('a -> 'a -> bool) -> 'a list -> 'a list -> bool = List.equal
let globalize_list : 'a. ('a -> 'a) -> 'a list -> 'a list =
fun (type a__078_) : ((a__078_ -> a__078_) -> a__078_ list -> a__078_ list) ->
List.globalize
;;
let hash_fold_list :
'a.
(Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state)
-> Ppx_hash_lib.Std.Hash.state
-> 'a list
-> Ppx_hash_lib.Std.Hash.state
=
List.hash_fold_t
;;
let list_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a list =
List.t_of_sexp
;;
let sexp_of_list : 'a. ('a -> Sexplib0.Sexp.t) -> 'a list -> Sexplib0.Sexp.t =
List.sexp_of_t
;;
let list_sexp_grammar :
'a. 'a Sexplib0.Sexp_grammar.t -> 'a list Sexplib0.Sexp_grammar.t
=
fun _'a_sexp_grammar -> List.t_sexp_grammar _'a_sexp_grammar
;;
[@@@end]
type nativeint = Nativeint.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_nativeint__local =
(Nativeint.compare__local : nativeint -> nativeint -> int)
;;
let compare_nativeint =
(fun a b -> compare_nativeint__local a b : nativeint -> nativeint -> int)
;;
let equal_nativeint__local = (Nativeint.equal__local : nativeint -> nativeint -> bool)
let equal_nativeint =
(fun a b -> equal_nativeint__local a b : nativeint -> nativeint -> bool)
;;
let (globalize_nativeint : nativeint -> nativeint) =
(Nativeint.globalize : nativeint -> nativeint)
;;
let (hash_fold_nativeint :
Ppx_hash_lib.Std.Hash.state -> nativeint -> Ppx_hash_lib.Std.Hash.state)
=
Nativeint.hash_fold_t
and (hash_nativeint : nativeint -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = Nativeint.hash in
fun x -> func x
;;
let nativeint_of_sexp = (Nativeint.t_of_sexp : Sexplib0.Sexp.t -> nativeint)
let sexp_of_nativeint = (Nativeint.sexp_of_t : nativeint -> Sexplib0.Sexp.t)
let (nativeint_sexp_grammar : nativeint Sexplib0.Sexp_grammar.t) =
Nativeint.t_sexp_grammar
;;
[@@@end]
type 'a option = 'a Option.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_option__local : 'a. ('a -> 'a -> int) -> 'a option -> 'a option -> int =
Option.compare__local
;;
let compare_option : 'a. ('a -> 'a -> int) -> 'a option -> 'a option -> int =
Option.compare
;;
let equal_option__local : 'a. ('a -> 'a -> bool) -> 'a option -> 'a option -> bool =
Option.equal__local
;;
let equal_option : 'a. ('a -> 'a -> bool) -> 'a option -> 'a option -> bool =
Option.equal
;;
let globalize_option : 'a. ('a -> 'a) -> 'a option -> 'a option =
fun (type a__109_) : ((a__109_ -> a__109_) -> a__109_ option -> a__109_ option) ->
Option.globalize
;;
let hash_fold_option :
'a.
(Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state)
-> Ppx_hash_lib.Std.Hash.state
-> 'a option
-> Ppx_hash_lib.Std.Hash.state
=
Option.hash_fold_t
;;
let option_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a option =
Option.t_of_sexp
;;
let sexp_of_option : 'a. ('a -> Sexplib0.Sexp.t) -> 'a option -> Sexplib0.Sexp.t =
Option.sexp_of_t
;;
let option_sexp_grammar :
'a. 'a Sexplib0.Sexp_grammar.t -> 'a option Sexplib0.Sexp_grammar.t
=
fun _'a_sexp_grammar -> Option.t_sexp_grammar _'a_sexp_grammar
;;
[@@@end]
type 'a ref = 'a Ref.t
[@@deriving_inline compare ~localize, equal ~localize, globalize, sexp, sexp_grammar]
let compare_ref__local : 'a. ('a -> 'a -> int) -> 'a ref -> 'a ref -> int =
Ref.compare__local
;;
let compare_ref : 'a. ('a -> 'a -> int) -> 'a ref -> 'a ref -> int = Ref.compare
let equal_ref__local : 'a. ('a -> 'a -> bool) -> 'a ref -> 'a ref -> bool =
Ref.equal__local
;;
let equal_ref : 'a. ('a -> 'a -> bool) -> 'a ref -> 'a ref -> bool = Ref.equal
let globalize_ref : 'a. ('a -> 'a) -> 'a ref -> 'a ref =
fun (type a__134_) : ((a__134_ -> a__134_) -> a__134_ ref -> a__134_ ref) ->
Ref.globalize
;;
let ref_of_sexp : 'a. (Sexplib0.Sexp.t -> 'a) -> Sexplib0.Sexp.t -> 'a ref =
Ref.t_of_sexp
;;
let sexp_of_ref : 'a. ('a -> Sexplib0.Sexp.t) -> 'a ref -> Sexplib0.Sexp.t =
Ref.sexp_of_t
;;
let ref_sexp_grammar : 'a. 'a Sexplib0.Sexp_grammar.t -> 'a ref Sexplib0.Sexp_grammar.t =
fun _'a_sexp_grammar -> Ref.t_sexp_grammar _'a_sexp_grammar
;;
[@@@end]
type string = String.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_string__local = (String.compare__local : string -> string -> int)
let compare_string = (fun a b -> compare_string__local a b : string -> string -> int)
let equal_string__local = (String.equal__local : string -> string -> bool)
let equal_string = (fun a b -> equal_string__local a b : string -> string -> bool)
let (globalize_string : string -> string) = (String.globalize : string -> string)
let (hash_fold_string :
Ppx_hash_lib.Std.Hash.state -> string -> Ppx_hash_lib.Std.Hash.state)
=
String.hash_fold_t
and (hash_string : string -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = String.hash in
fun x -> func x
;;
let string_of_sexp = (String.t_of_sexp : Sexplib0.Sexp.t -> string)
let sexp_of_string = (String.sexp_of_t : string -> Sexplib0.Sexp.t)
let (string_sexp_grammar : string Sexplib0.Sexp_grammar.t) = String.t_sexp_grammar
[@@@end]
type bytes = Bytes.t
[@@deriving_inline compare ~localize, equal ~localize, globalize, sexp, sexp_grammar]
let compare_bytes__local = (Bytes.compare__local : bytes -> bytes -> int)
let compare_bytes = (fun a b -> compare_bytes__local a b : bytes -> bytes -> int)
let equal_bytes__local = (Bytes.equal__local : bytes -> bytes -> bool)
let equal_bytes = (fun a b -> equal_bytes__local a b : bytes -> bytes -> bool)
let (globalize_bytes : bytes -> bytes) = (Bytes.globalize : bytes -> bytes)
let bytes_of_sexp = (Bytes.t_of_sexp : Sexplib0.Sexp.t -> bytes)
let sexp_of_bytes = (Bytes.sexp_of_t : bytes -> Sexplib0.Sexp.t)
let (bytes_sexp_grammar : bytes Sexplib0.Sexp_grammar.t) = Bytes.t_sexp_grammar
[@@@end]
type unit = Unit.t
[@@deriving_inline
compare ~localize, equal ~localize, globalize, hash, sexp, sexp_grammar]
let compare_unit__local = (Unit.compare__local : unit -> unit -> int)
let compare_unit = (fun a b -> compare_unit__local a b : unit -> unit -> int)
let equal_unit__local = (Unit.equal__local : unit -> unit -> bool)
let equal_unit = (fun a b -> equal_unit__local a b : unit -> unit -> bool)
let (globalize_unit : unit -> unit) = (Unit.globalize : unit -> unit)
let (hash_fold_unit :
Ppx_hash_lib.Std.Hash.state -> unit -> Ppx_hash_lib.Std.Hash.state)
=
Unit.hash_fold_t
and (hash_unit : unit -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = Unit.hash in
fun x -> func x
;;
let unit_of_sexp = (Unit.t_of_sexp : Sexplib0.Sexp.t -> unit)
let sexp_of_unit = (Unit.sexp_of_t : unit -> Sexplib0.Sexp.t)
let (unit_sexp_grammar : unit Sexplib0.Sexp_grammar.t) = Unit.t_sexp_grammar
[@@@end]
(** Format stuff *)
type nonrec ('a, 'b, 'c) format = ('a, 'b, 'c) format
type nonrec ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) format4
type nonrec ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) format6
(** List operators *)
include List.Infix
(** Int operators and comparisons *)
include Int.O
include Int_replace_polymorphic_compare
(** Float operators *)
include Float.O_dot
(* This is declared as an external to be optimized away in more contexts. *)
(** Reverse application operator. [x |> g |> f] is equivalent to [f (g (x))]. *)
external ( |> ) : 'a -> (('a -> 'b)[@local_opt]) -> 'b = "%revapply"
(** Application operator. [g @@ f @@ x] is equivalent to [g (f (x))]. *)
external ( @@ ) : (('a -> 'b)[@local_opt]) -> 'a -> 'b = "%apply"
(** Boolean operations *)
(* These need to be declared as an external to get the lazy behavior *)
external ( && ) : (bool[@local_opt]) -> (bool[@local_opt]) -> bool = "%sequand"
external ( || ) : (bool[@local_opt]) -> (bool[@local_opt]) -> bool = "%sequor"
external not : (bool[@local_opt]) -> bool = "%boolnot"
(* This must be declared as an external for the warnings to work properly. *)
external ignore : (_[@local_opt]) -> unit = "%ignore"
(** Common string operations *)
let ( ^ ) = String.( ^ )
(** Reference operations *)
(* Declared as an externals so that the compiler skips the caml_modify when possible and
to keep reference unboxing working *)
external ( ! ) : ('a ref[@local_opt]) -> 'a = "%field0"
external ref : 'a -> ('a ref[@local_opt]) = "%makemutable"
external ( := ) : ('a ref[@local_opt]) -> 'a -> unit = "%setfield0"
(** Pair operations *)
let fst = fst
let snd = snd
(** Exceptions stuff *)
(* Declared as an external so that the compiler may rewrite '%raise' as '%reraise'. *)
external raise : exn -> _ = "%raise"
let failwith = failwith
let invalid_arg = invalid_arg
let raise_s = Error.raise_s
(** Misc *)
external phys_equal : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%eq"
external force : ('a Lazy.t[@local_opt]) -> 'a = "%lazy_force"
end
include Export
include Container_intf.Export (** @inline *)
exception Not_found_s = Not_found_s
(* We perform these side effects here because we want them to run for any code that uses
[Base]. If this were in another module in [Base] that was not used in some program,
then the side effects might not be run in that program. This will run as long as the
program refers to at least one value directly in [Base]; referring to values in
[Base.Bool], for example, is not sufficient. *)
let () = Backtrace.initialize_module ()
module Caml = struct end [@@deprecated "[since 2023-01] use Stdlib instead of Caml"]

123
unikernel/duniverse/base/src/binary_search.ml Normal file
View file

@ -0,0 +1,123 @@
open! Import
open Int_replace_polymorphic_compare
(* These functions implement a search for the first (resp. last) element
satisfying a predicate, assuming that the predicate is increasing on
the container, meaning that, if the container is [u1...un], there exists a
k such that p(u1)=....=p(uk) = false and p(uk+1)=....=p(un)= true.
If this k = 1 (resp n), find_last_not_satisfying (resp find_first_satisfying)
will return None. *)
let rec linear_search_first_satisfying t ~get ~lo ~hi ~pred =
if lo > hi
then None
else if pred (get t lo)
then Some lo
else linear_search_first_satisfying t ~get ~lo:(lo + 1) ~hi ~pred
;;
(* Takes a container [t], a predicate [pred] and two indices [lo < hi], such that
[pred] is increasing on [t] between [lo] and [hi].
return a range (lo, hi) where:
- lo and hi are close enough together for a linear search
- If [pred] is not constantly [false] on [t] between [lo] and [hi], the first element
on which [pred] is [true] is between [lo] and [hi]. *)
(* Invariant: the first element satisfying [pred], if it exists is between [lo] and [hi] *)
let rec find_range_near_first_satisfying t ~get ~lo ~hi ~pred =
(* Warning: this function will not terminate if the constant (currently 8) is
set <= 1 *)
if hi - lo <= 8
then lo, hi
else (
let mid = lo + ((hi - lo) / 2) in
if pred (get t mid)
(* INVARIANT check: it means the first satisfying element is between [lo] and [mid] *)
then
find_range_near_first_satisfying t ~get ~lo ~hi:mid ~pred
(* INVARIANT check: it means the first satisfying element, if it exists,
is between [mid+1] and [hi] *)
else find_range_near_first_satisfying t ~get ~lo:(mid + 1) ~hi ~pred)
;;
let find_first_satisfying ?pos ?len t ~get ~length ~pred =
let pos, len =
Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length t)
in
let lo = pos in
let hi = pos + len - 1 in
let lo, hi = find_range_near_first_satisfying t ~get ~lo ~hi ~pred in
linear_search_first_satisfying t ~get ~lo ~hi ~pred
;;
(* Takes an array with shape [true,...true,false,...false] (i.e., the _reverse_ of what
is described above) and returns the index of the last true or None if there are no
true*)
let find_last_satisfying ?pos ?len t ~pred ~get ~length =
let pos, len =
Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length t)
in
if len = 0
then None
else (
(* The last satisfying is the one just before the first not satisfying *)
match
find_first_satisfying ~pos ~len t ~get ~length ~pred:(fun x -> not (pred x))
with
| None -> Some (pos + len - 1)
(* This means that all elements satisfy pred.
There is at least an element as (len > 0) *)
| Some i when i = pos -> None (* no element satisfies pred *)
| Some i -> Some (i - 1))
;;
let binary_search
?pos
?len
t
~(length : _ -> _)
~(get : _ -> _ -> _)
~(compare : _ -> _ -> _)
how
v
=
match how with
| `Last_strictly_less_than ->
find_last_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v < 0) [@nontail
]
| `Last_less_than_or_equal_to ->
find_last_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v <= 0) [@nontail
]
| `First_equal_to ->
(match
find_first_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v >= 0)
with
| Some x when compare (get t x) v = 0 -> Some x
| None | Some _ -> None)
| `Last_equal_to ->
(match
find_last_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v <= 0)
with
| Some x when compare (get t x) v = 0 -> Some x
| None | Some _ -> None)
| `First_greater_than_or_equal_to ->
find_first_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v >= 0) [@nontail
]
| `First_strictly_greater_than ->
find_first_satisfying ?pos ?len t ~get ~length ~pred:(fun x -> compare x v > 0) [@nontail
]
;;
let binary_search_segmented ?pos ?len t ~length ~get ~segment_of how =
let is_left x =
match segment_of x with
| `Left -> true
| `Right -> false
in
let is_right x = not (is_left x) in
match how with
| `Last_on_left ->
find_last_satisfying ?pos ?len t ~length ~get ~pred:is_left [@nontail]
| `First_on_right ->
find_first_satisfying ?pos ?len t ~length ~get ~pred:is_right [@nontail]
;;

86
unikernel/duniverse/base/src/binary_search.mli Normal file
View file

@ -0,0 +1,86 @@
(** Functions for performing binary searches over ordered sequences given
[length] and [get] functions.
These functions can be specialized and added to a data structure using the functors
supplied in {{!Base.Binary_searchable}[Binary_searchable]} and described in
{{!Base.Binary_searchable_intf}[Binary_searchable_intf]}.
{2:examples Examples}
Below we assume that the functions [get], [length] and [compare] are in scope:
{[
(* Find the index of an element [e] in [t] *)
binary_search t ~get ~length ~compare `First_equal_to e;
(* Find the index where an element [e] should be inserted *)
binary_search t ~get ~length ~compare `First_greater_than_or_equal_to e;
(* Find the index in [t] where all elements to the left are less than [e] *)
binary_search_segmented t ~get ~length ~segment_of:(fun e' ->
if compare e' e <= 0 then `Left else `Right) `First_on_right
]} *)
open! Import
(** [binary_search ?pos ?len t ~length ~get ~compare which elt] takes [t] that is sorted
in increasing order according to [compare], where [compare] and [elt] divide [t] into
three (possibly empty) segments:
{v
| < elt | = elt | > elt |
v}
[binary_search] returns the index in [t] of an element on the boundary of segments
as specified by [which]. See the diagram below next to the [which] variants.
By default, [binary_search] searches the entire [t]. One can supply [?pos] or
[?len] to search a slice of [t].
[binary_search] does not check that [compare] orders [t], and behavior is
unspecified if [compare] doesn't order [t]. Behavior is also unspecified if
[compare] mutates [t]. *)
val binary_search
: ?pos:int
-> ?len:int
-> 't
-> length:('t -> int)
-> get:('t -> int -> 'elt)
-> compare:('elt -> 'key -> int)
-> [ `Last_strictly_less_than (** {v | < elt X | v} *)
| `Last_less_than_or_equal_to (** {v | <= elt X | v} *)
| `Last_equal_to (** {v | = elt X | v} *)
| `First_equal_to (** {v | X = elt | v} *)
| `First_greater_than_or_equal_to (** {v | X >= elt | v} *)
| `First_strictly_greater_than (** {v | X > elt | v} *)
]
-> 'key
-> int option
(** [binary_search_segmented ?pos ?len t ~length ~get ~segment_of which] takes a
[segment_of] function that divides [t] into two (possibly empty) segments:
{v
| segment_of elt = `Left | segment_of elt = `Right |
v}
[binary_search_segmented] returns the index of the element on the boundary of the
segments as specified by [which]: [`Last_on_left] yields the index of the last
element of the left segment, while [`First_on_right] yields the index of the first
element of the right segment. It returns [None] if the segment is empty.
By default, [binary_search] searches the entire [t]. One can supply [?pos] or
[?len] to search a slice of [t].
[binary_search_segmented] does not check that [segment_of] segments [t] as in the
diagram, and behavior is unspecified if [segment_of] doesn't segment [t]. Behavior
is also unspecified if [segment_of] mutates [t]. *)
val binary_search_segmented
: ?pos:int
-> ?len:int
-> 't
-> length:('t -> int)
-> get:('t -> int -> 'elt)
-> segment_of:('elt -> [ `Left | `Right ])
-> [ `Last_on_left | `First_on_right ]
-> int option

38
unikernel/duniverse/base/src/binary_searchable.ml Normal file
View file

@ -0,0 +1,38 @@
open! Import
include Binary_searchable_intf
module type Arg = sig
type 'a elt
type 'a t
val get : 'a t -> int -> 'a elt
val length : _ t -> int
end
module Make_gen (T : Arg) = struct
let get = T.get
let length = T.length
let binary_search ?pos ?len t ~compare how v =
Binary_search.binary_search ?pos ?len t ~get ~length ~compare how v
;;
let binary_search_segmented ?pos ?len t ~segment_of how =
Binary_search.binary_search_segmented ?pos ?len t ~get ~length ~segment_of how
;;
end
module Make (T : Indexable) = Make_gen (struct
include T
type 'a elt = T.elt
type 'a t = T.t
end)
module Make1 (T : Indexable1) = Make_gen (struct
type 'a elt = 'a
type 'a t = 'a T.t
let get = T.get
let length = T.length
end)

1
unikernel/duniverse/base/src/binary_searchable.mli Normal file
View file

@ -0,0 +1 @@
include Binary_searchable_intf.Binary_searchable (** @inline *)

110
unikernel/duniverse/base/src/binary_searchable_intf.ml Normal file
View file

@ -0,0 +1,110 @@
(** Module types for a [binary_search] function for a sequence, and functors for building
[binary_search] functions. *)
open! Import
(** An [Indexable] type is a finite sequence of elements indexed by consecutive integers
[0] ... [length t - 1]. [get] and [length] must be O(1) for the resulting
[binary_search] to be lg(n). *)
module type Indexable = sig
type elt
type t
val get : t -> int -> elt
val length : t -> int
end
module type Indexable1 = sig
type 'a t
val get : 'a t -> int -> 'a
val length : _ t -> int
end
module Which_target_by_key = struct
type t =
[ `Last_strictly_less_than (** {v | < elt X | v} *)
| `Last_less_than_or_equal_to (** {v | <= elt X | v} *)
| `Last_equal_to (** {v | = elt X | v} *)
| `First_equal_to (** {v | X = elt | v} *)
| `First_greater_than_or_equal_to (** {v | X >= elt | v} *)
| `First_strictly_greater_than (** {v | X > elt | v} *)
]
[@@deriving_inline enumerate]
let all =
([ `Last_strictly_less_than
; `Last_less_than_or_equal_to
; `Last_equal_to
; `First_equal_to
; `First_greater_than_or_equal_to
; `First_strictly_greater_than
]
: t list)
;;
[@@@end]
end
module Which_target_by_segment = struct
type t =
[ `Last_on_left
| `First_on_right
]
[@@deriving_inline enumerate]
let all = ([ `Last_on_left; `First_on_right ] : t list)
[@@@end]
end
type ('t, 'elt, 'key) binary_search =
?pos:int
-> ?len:int
-> 't
-> compare:('elt -> 'key -> int)
-> Which_target_by_key.t
-> 'key
-> int option
type ('t, 'elt) binary_search_segmented =
?pos:int
-> ?len:int
-> 't
-> segment_of:('elt -> [ `Left | `Right ])
-> Which_target_by_segment.t
-> int option
module type S = sig
type elt
type t
(** See [Binary_search.binary_search] in binary_search.ml *)
val binary_search : (t, elt, 'key) binary_search
(** See [Binary_search.binary_search_segmented] in binary_search.ml *)
val binary_search_segmented : (t, elt) binary_search_segmented
end
module type S1 = sig
type 'a t
val binary_search : ('a t, 'a, 'key) binary_search
val binary_search_segmented : ('a t, 'a) binary_search_segmented
end
module type Binary_searchable = sig
module type S = S
module type S1 = S1
module type Indexable = Indexable
module type Indexable1 = Indexable1
module Which_target_by_key = Which_target_by_key
module Which_target_by_segment = Which_target_by_segment
type nonrec ('t, 'elt, 'key) binary_search = ('t, 'elt, 'key) binary_search
type nonrec ('t, 'elt) binary_search_segmented = ('t, 'elt) binary_search_segmented
module Make (T : Indexable) : S with type t := T.t with type elt := T.elt
module Make1 (T : Indexable1) : S1 with type 'a t := 'a T.t
end

133
unikernel/duniverse/base/src/blit.ml Normal file
View file

@ -0,0 +1,133 @@
open! Import
include Blit_intf
module type Sequence_gen = sig
type 'a t
val length : _ t -> int
end
module Make_gen
(Src : Sequence_gen) (Dst : sig
include Sequence_gen
val create_like : len:int -> 'a Src.t -> 'a t
val unsafe_blit : ('a Src.t, 'a t) blit
end) =
struct
let unsafe_blit = Dst.unsafe_blit
let blit ~src ~src_pos ~dst ~dst_pos ~len =
Ordered_collection_common.check_pos_len_exn
~pos:src_pos
~len
~total_length:(Src.length src);
Ordered_collection_common.check_pos_len_exn
~pos:dst_pos
~len
~total_length:(Dst.length dst);
if len > 0 then unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len
;;
let blito
~src
?(src_pos = 0)
?(src_len = Src.length src - src_pos)
~dst
?(dst_pos = 0)
()
=
blit ~src ~src_pos ~len:src_len ~dst ~dst_pos
;;
(* [sub] and [subo] ensure that every position of the created sequence is populated by
an element of the source array. Thus every element of [dst] below is well
defined. *)
let sub src ~pos ~len =
Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length:(Src.length src);
let dst = Dst.create_like ~len src in
if len > 0 then unsafe_blit ~src ~src_pos:pos ~dst ~dst_pos:0 ~len;
dst
;;
let subo ?(pos = 0) ?len src =
sub
src
~pos
~len:
(match len with
| Some i -> i
| None -> Src.length src - pos)
;;
end
module Make1 (Sequence : sig
include Sequence_gen
val create_like : len:int -> 'a t -> 'a t
val unsafe_blit : ('a t, 'a t) blit
end) =
Make_gen (Sequence) (Sequence)
module Make1_generic (Sequence : Sequence1) = Make_gen (Sequence) (Sequence)
module Make (Sequence : sig
include Sequence
val create : len:int -> t
val unsafe_blit : (t, t) blit
end) =
struct
module Sequence = struct
type 'a t = Sequence.t
open Sequence
let create_like ~len _ = create ~len
let length = length
let unsafe_blit = unsafe_blit
end
include Make_gen (Sequence) (Sequence)
end
module Make_distinct
(Src : Sequence) (Dst : sig
include Sequence
val create : len:int -> t
val unsafe_blit : (Src.t, t) blit
end) =
Make_gen
(struct
type 'a t = Src.t
open Src
let length = length
end)
(struct
type 'a t = Dst.t
open Dst
let length = length
let create_like ~len _ = create ~len
let unsafe_blit = unsafe_blit
end)
module Make_to_string (T : sig
type t
end)
(To_bytes : S_distinct with type src := T.t with type dst := bytes) =
struct
open To_bytes
let sub src ~pos ~len =
Bytes0.unsafe_to_string ~no_mutation_while_string_reachable:(sub src ~pos ~len)
;;
let subo ?pos ?len src =
Bytes0.unsafe_to_string ~no_mutation_while_string_reachable:(subo ?pos ?len src)
;;
end

1
unikernel/duniverse/base/src/blit.mli Normal file
View file

@ -0,0 +1 @@
include Blit_intf.Blit (** @inline *)

173
unikernel/duniverse/base/src/blit_intf.ml Normal file
View file

@ -0,0 +1,173 @@
(** Standard type for [blit] functions, and reusable code for validating [blit]
arguments. *)
open! Import
(** If [blit : (src, dst) blit], then [blit ~src ~src_pos ~len ~dst ~dst_pos] blits [len]
values from [src] starting at position [src_pos] to [dst] at position [dst_pos].
Furthermore, [blit] raises if [src_pos], [len], and [dst_pos] don't specify valid
slices of [src] and [dst]. *)
type ('src, 'dst) blit =
src:'src -> src_pos:int -> dst:'dst -> dst_pos:int -> len:int -> unit
(** [blito] is like [blit], except that the [src_pos], [src_len], and [dst_pos] are
optional (hence the "o" in "blito"). Also, we use [src_len] rather than [len] as a
reminder that if [src_len] isn't supplied, then the default is to take the slice
running from [src_pos] to the end of [src]. *)
type ('src, 'dst) blito =
src:'src
-> ?src_pos:int (** default is [0] *)
-> ?src_len:int (** default is [length src - src_pos] *)
-> dst:'dst
-> ?dst_pos:int (** default is [0] *)
-> unit
-> unit
(** If [sub : (src, dst) sub], then [sub ~src ~pos ~len] returns a sequence of type [dst]
containing [len] characters of [src] starting at [pos].
[subo] is like [sub], except [pos] and [len] are optional. *)
type ('src, 'dst) sub = 'src -> pos:int -> len:int -> 'dst
type ('src, 'dst) subo =
?pos:int (** default is [0] *)
-> ?len:int (** default is [length src - pos] *)
-> 'src
-> 'dst
(*_ These are not implemented less-general-in-terms-of-more-general because odoc produces
unreadable documentation in that case, with or without [inline] on [include]. *)
module type S = sig
type t
val blit : (t, t) blit
val blito : (t, t) blito
val unsafe_blit : (t, t) blit
val sub : (t, t) sub
val subo : (t, t) subo
end
module type S1 = sig
type 'a t
val blit : ('a t, 'a t) blit
val blito : ('a t, 'a t) blito
val unsafe_blit : ('a t, 'a t) blit
val sub : ('a t, 'a t) sub
val subo : ('a t, 'a t) subo
end
module type S_distinct = sig
type src
type dst
val blit : (src, dst) blit
val blito : (src, dst) blito
val unsafe_blit : (src, dst) blit
val sub : (src, dst) sub
val subo : (src, dst) subo
end
module type S1_distinct = sig
type 'a src
type 'a dst
val blit : (_ src, _ dst) blit
val blito : (_ src, _ dst) blito
val unsafe_blit : (_ src, _ dst) blit
val sub : (_ src, _ dst) sub
val subo : (_ src, _ dst) subo
end
module type S_to_string = sig
type t
val sub : (t, string) sub
val subo : (t, string) subo
end
(** Users of modules matching the blit signatures [S], [S1], and [S1_distinct] only need
to understand the code above. The code below is only for those that need to implement
modules that match those signatures. *)
module type Sequence = sig
type t
val length : t -> int
end
type 'a poly = 'a
module type Sequence1 = sig
type 'a t
(** [Make1*] guarantees to only call [create_like ~len t] with [len > 0] if [length t >
0]. *)
val create_like : len:int -> 'a t -> 'a t
val length : _ t -> int
val unsafe_blit : ('a t, 'a t) blit
end
module type Blit = sig
type nonrec ('src, 'dst) blit = ('src, 'dst) blit
type nonrec ('src, 'dst) blito = ('src, 'dst) blito
type nonrec ('src, 'dst) sub = ('src, 'dst) sub
type nonrec ('src, 'dst) subo = ('src, 'dst) subo
module type S = S
module type S1 = S1
module type S_distinct = S_distinct
module type S1_distinct = S1_distinct
module type S_to_string = S_to_string
module type Sequence = Sequence
module type Sequence1 = Sequence1
(** There are various [Make*] functors that turn an [unsafe_blit] function into a [blit]
function. The functors differ in whether the sequence type is monomorphic or
polymorphic, and whether the src and dst types are distinct or are the same.
The blit functions make sure the slices are valid and then call [unsafe_blit]. They
guarantee at a call [unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len] that:
{[
len > 0
&& src_pos >= 0
&& src_pos + len <= get_src_len src
&& dst_pos >= 0
&& dst_pos + len <= get_dst_len dst
]}
The [Make*] functors also automatically create unit tests. *)
(** [Make] is for blitting between two values of the same monomorphic type. *)
module Make (Sequence : sig
include Sequence
val create : len:int -> t
val unsafe_blit : (t, t) blit
end) : S with type t := Sequence.t
(** [Make_distinct] is for blitting between values of distinct monomorphic types. *)
module Make_distinct
(Src : Sequence) (Dst : sig
include Sequence
val create : len:int -> t
val unsafe_blit : (Src.t, t) blit
end) : S_distinct with type src := Src.t with type dst := Dst.t
module Make_to_string (T : sig
type t
end)
(To_bytes : S_distinct with type src := T.t with type dst := bytes) :
S_to_string with type t := T.t
(** [Make1] is for blitting between two values of the same polymorphic type. *)
module Make1 (Sequence : Sequence1) : S1 with type 'a t := 'a Sequence.t
(** [Make1_generic] is for blitting between two values of the same container type that's
not fully polymorphic (in the sense of Container.Generic). *)
module Make1_generic (Sequence : Sequence1) : S1 with type 'a t := 'a Sequence.t
end

92
unikernel/duniverse/base/src/bool.ml Normal file
View file

@ -0,0 +1,92 @@
open! Import
include Bool0
let invalid_argf = Printf.invalid_argf
module T = struct
type t = bool
[@@deriving_inline compare, enumerate, globalize, hash, sexp, sexp_grammar]
let compare = (compare_bool : t -> t -> int)
let all = ([ false; true ] : t list)
let (globalize : t -> t) = (globalize_bool : t -> t)
let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) =
hash_fold_bool
and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = hash_bool in
fun x -> func x
;;
let t_of_sexp = (bool_of_sexp : Sexplib0.Sexp.t -> t)
let sexp_of_t = (sexp_of_bool : t -> Sexplib0.Sexp.t)
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = bool_sexp_grammar
[@@@end]
let hashable : t Hashable.t = { hash; compare; sexp_of_t }
let of_string = function
| "true" -> true
| "false" -> false
| s -> invalid_argf "Bool.of_string: expected true or false but got %s" s ()
;;
let to_string = Stdlib.string_of_bool
end
include T
include Comparator.Make (T)
include Pretty_printer.Register (struct
type nonrec t = t
let to_string = to_string
let module_name = "Base.Bool"
end)
(* Open replace_polymorphic_compare after including functor instantiations so they do not
shadow its definitions. This is here so that efficient versions of the comparison
functions are available within this module. *)
open! Bool_replace_polymorphic_compare
let invariant (_ : t) = ()
let between t ~low ~high = low <= t && t <= high
let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max
let clamp_exn t ~min ~max =
assert (min <= max);
clamp_unchecked t ~min ~max
;;
let clamp t ~min ~max =
if min > max
then
Or_error.error_s
(Sexp.message
"clamp requires [min <= max]"
[ "min", T.sexp_of_t min; "max", T.sexp_of_t max ])
else Ok (clamp_unchecked t ~min ~max)
;;
let to_int x = bool_to_int x
module Non_short_circuiting = struct
(* We don't expose this, since we don't want to break the invariant mentioned below of
(to_int true = 1) and (to_int false = 0). *)
let unsafe_of_int (x : int) : bool = Stdlib.Obj.magic x
let ( || ) a b = unsafe_of_int (to_int a lor to_int b)
let ( && ) a b = unsafe_of_int (to_int a land to_int b)
end
(* We do this as a direct assert on the theory that it's a cheap thing to test and a
really core invariant that we never expect to break, and we should be happy for a
program to fail immediately if this is violated. *)
let () = assert (Poly.( = ) (to_int true) 1 && Poly.( = ) (to_int false) 0)
(* Include type-specific [Replace_polymorphic_compare] at the end, after
including functor application that could shadow its definitions. This is
here so that efficient versions of the comparison functions are exported by
this module. *)
include Bool_replace_polymorphic_compare

45
unikernel/duniverse/base/src/bool.mli Normal file
View file

@ -0,0 +1,45 @@
(** Boolean type extended to be enumerable, hashable, sexpable, comparable, and
stringable. *)
open! Import
type t = bool [@@deriving_inline enumerate, globalize, sexp, sexp_grammar]
include Ppx_enumerate_lib.Enumerable.S with type t := t
val globalize : t -> t
include Sexplib0.Sexpable.S with type t := t
val t_sexp_grammar : t Sexplib0.Sexp_grammar.t
[@@@end]
include Identifiable.S with type t := t
include Ppx_compare_lib.Comparable.S_local with type t := t
include Ppx_compare_lib.Equal.S_local with type t := t
include Invariant.S with type t := t
(**
- [to_int true = 1]
- [to_int false = 0] *)
val to_int : t -> int
external select
: bool
-> ('a[@local_opt])
-> ('a[@local_opt])
-> ('a[@local_opt])
= "caml_csel_value"
[@@noalloc] [@@no_effects] [@@no_coeffects] [@@builtin]
module Non_short_circuiting : sig
(** Non-short circuiting and branch-free boolean operators.
The default versions of these infix operators are short circuiting, which
requires branching instructions to implement. The operators below are
instead branch-free, and therefore not short-circuiting. *)
val ( && ) : t -> t -> t
val ( || ) : t -> t -> t
end

7
unikernel/duniverse/base/src/bool0.ml Normal file
View file

@ -0,0 +1,7 @@
external select
: bool
-> ('a[@local_opt])
-> ('a[@local_opt])
-> ('a[@local_opt])
= "caml_csel_value"
[@@noalloc] [@@no_effects] [@@no_coeffects] [@@builtin]

7
unikernel/duniverse/base/src/bool0.mli Normal file
View file

@ -0,0 +1,7 @@
external select
: bool
-> ('a[@local_opt])
-> ('a[@local_opt])
-> ('a[@local_opt])
= "caml_csel_value"
[@@noalloc] [@@no_effects] [@@no_coeffects] [@@builtin]

36
unikernel/duniverse/base/src/buffer.ml Normal file
View file

@ -0,0 +1,36 @@
open! Import
include Buffer_intf
include Stdlib.Buffer
let contents_bytes = to_bytes
let add_substring t s ~pos ~len = add_substring t s pos len
let add_subbytes t s ~pos ~len = add_subbytes t s pos len
let sexp_of_t t = sexp_of_string (contents t)
let caml_buffer_length = (Stdlib.Obj.magic (Stdlib.Buffer.length : t -> int) : t -> int)
let caml_buffer_blit =
(Stdlib.Obj.magic
(Stdlib.Buffer.blit : Stdlib.Buffer.t -> int -> Bytes.t -> int -> int -> unit)
: Stdlib.Buffer.t -> int -> Bytes.t -> int -> int -> unit)
;;
module To_bytes =
Blit.Make_distinct
(struct
type nonrec t = t
let length = caml_buffer_length
end)
(struct
type t = Bytes.t
let create ~len = Bytes.create len
let length = Bytes.length
let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len =
caml_buffer_blit src src_pos dst dst_pos len
;;
end)
include To_bytes
module To_string = Blit.Make_to_string (Stdlib.Buffer) (To_bytes)

8
unikernel/duniverse/base/src/buffer.mli Normal file
View file

@ -0,0 +1,8 @@
(** Extensible character buffers.
This module implements character buffers that automatically expand as necessary. It
provides cumulative concatenation of strings in quasi-linear time (instead of
quadratic time when strings are concatenated pairwise).
*)
include Buffer_intf.Buffer (** @inline *)

82
unikernel/duniverse/base/src/buffer_intf.ml Normal file
View file

@ -0,0 +1,82 @@
open! Import
module type S = sig
(** The abstract type of buffers. *)
type t [@@deriving_inline sexp_of]
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
(** [create n] returns a fresh buffer, initially empty. The [n] parameter is the
initial size of the internal storage medium that holds the buffer contents. That
storage is automatically reallocated when more than [n] characters are stored in the
buffer, but shrinks back to [n] characters when [reset] is called.
For best performance, [n] should be of the same order of magnitude as the number of
characters that are expected to be stored in the buffer (for instance, 80 for a
buffer that holds one output line). Nothing bad will happen if the buffer grows
beyond that limit, however. In doubt, take [n = 16] for instance. *)
val create : int -> t
(** Return a copy of the current contents of the buffer. The buffer itself is
unchanged. *)
val contents : t -> string
val contents_bytes : t -> bytes
(** [blit ~src ~src_pos ~dst ~dst_pos ~len] copies [len] characters from the current
contents of the buffer [src], starting at offset [src_pos] to bytes [dst], starting
at character [dst_pos].
Raises [Invalid_argument] if [src_pos] and [len] do not designate a valid substring
of [src], or if [dst_pos] and [len] do not designate a valid substring of [dst]. *)
include Blit.S_distinct with type src := t with type dst := bytes
module To_string : Blit.S_to_string with type t := t
(** Gets the (zero-based) n-th character of the buffer. Raises [Invalid_argument] if
index out of bounds. *)
val nth : t -> int -> char
(** Returns the number of characters currently contained in the buffer. *)
val length : t -> int
(** Empties the buffer. *)
val clear : t -> unit
(** Empties the buffer and deallocates the internal storage holding the buffer contents,
replacing it with the initial internal storage of length [n] that was allocated by
[create n]. For long-lived buffers that may have grown a lot, [reset] allows faster
reclamation of the space used by the buffer. *)
val reset : t -> unit
(** [add_char b c] appends the character [c] at the end of the buffer [b]. *)
val add_char : t -> char -> unit
(** [add_string b s] appends the string [s] at the end of the buffer [b]. *)
val add_string : t -> string -> unit
(** [add_substring b s pos len] takes [len] characters from offset [pos] in string [s]
and appends them at the end of the buffer [b]. *)
val add_substring : t -> string -> pos:int -> len:int -> unit
(** [add_bytes b s] appends the bytes [s] at the end of the buffer [b]. *)
val add_bytes : t -> bytes -> unit
(** [add_subbytes b s pos len] takes [len] characters from offset [pos] in bytes [s]
and appends them at the end of the buffer [b]. *)
val add_subbytes : t -> bytes -> pos:int -> len:int -> unit
(** [add_buffer b1 b2] appends the current contents of buffer [b2] at the end of buffer
[b1]. [b2] is not modified. *)
val add_buffer : t -> t -> unit
end
module type Buffer = sig
module type S = S
(** Buffers using strings as underlying storage medium: *)
include S with type t = Stdlib.Buffer.t (** @open *)
end

180
unikernel/duniverse/base/src/bytes.ml Normal file
View file

@ -0,0 +1,180 @@
open! Import
module Array = Array0
include Bytes_intf
let stage = Staged.stage
module T = struct
type t = bytes [@@deriving_inline globalize, sexp, sexp_grammar]
let (globalize : t -> t) = (globalize_bytes : t -> t)
let t_of_sexp = (bytes_of_sexp : Sexplib0.Sexp.t -> t)
let sexp_of_t = (sexp_of_bytes : t -> Sexplib0.Sexp.t)
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = bytes_sexp_grammar
[@@@end]
include Bytes0
let module_name = "Base.Bytes"
let pp fmt t = Stdlib.Format.fprintf fmt "%S" (to_string t)
end
include T
module To_bytes = Blit.Make (struct
include T
let create ~len = create len
end)
include To_bytes
include Comparator.Make (T)
include Pretty_printer.Register_pp (T)
(* Open replace_polymorphic_compare after including functor instantiations so they do not
shadow its definitions. This is here so that efficient versions of the comparison
functions are available within this module. *)
open! Bytes_replace_polymorphic_compare
module To_string = Blit.Make_to_string (T) (To_bytes)
module From_string =
Blit.Make_distinct
(struct
type t = string
let length = String.length
end)
(struct
type nonrec t = t
let create ~len = create len
let length = length
let unsafe_blit = unsafe_blit_string
end)
let invariant (_ : t) = ()
let init n ~f =
if Int_replace_polymorphic_compare.( < ) n 0
then Printf.invalid_argf "Bytes.init %d" n ();
let t = create n in
for i = 0 to n - 1 do
unsafe_set t i (f i)
done;
t
;;
let of_char_list l =
let t = create (List.length l) in
List.iteri l ~f:(fun i c -> set t i c);
t
;;
let to_list t =
let rec loop t i acc =
if Int_replace_polymorphic_compare.( < ) i 0
then acc
else loop t (i - 1) (unsafe_get t i :: acc)
in
loop t (length t - 1) []
;;
let to_array t = Array.init (length t) ~f:(fun i -> unsafe_get t i)
let map t ~f = map t ~f
let mapi t ~f = mapi t ~f
let fold =
let rec loop t ~f ~len ~pos acc =
if Int_replace_polymorphic_compare.equal pos len
then acc
else loop t ~f ~len ~pos:(pos + 1) (f acc (unsafe_get t pos))
in
fun t ~init ~f -> loop t ~f ~len:(length t) ~pos:0 init
;;
let foldi =
let rec loop t ~f ~len ~pos acc =
if Int_replace_polymorphic_compare.equal pos len
then acc
else loop t ~f ~len ~pos:(pos + 1) (f pos acc (unsafe_get t pos))
in
fun t ~init ~f -> loop t ~f ~len:(length t) ~pos:0 init
;;
let tr ~target ~replacement s =
for i = 0 to length s - 1 do
if Char.equal (unsafe_get s i) target then unsafe_set s i replacement
done
;;
let tr_multi ~target ~replacement =
if Int_replace_polymorphic_compare.( = ) (String.length target) 0
then stage ignore
else if Int_replace_polymorphic_compare.( = ) (String.length replacement) 0
then invalid_arg "tr_multi: replacement is the empty string"
else (
match Bytes_tr.tr_create_map ~target ~replacement with
| None -> stage ignore
| Some tr_map ->
stage (fun s ->
for i = 0 to length s - 1 do
unsafe_set s i (String.unsafe_get tr_map (Char.to_int (unsafe_get s i)))
done))
;;
let between t ~low ~high = low <= t && t <= high
let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max
let clamp_exn t ~min ~max =
assert (min <= max);
clamp_unchecked t ~min ~max
;;
let clamp t ~min ~max =
if min > max
then
Or_error.error_s
(Sexp.message
"clamp requires [min <= max]"
[ "min", T.sexp_of_t min; "max", T.sexp_of_t max ])
else Ok (clamp_unchecked t ~min ~max)
;;
let contains ?pos ?len t char =
let pos, len =
Ordered_collection_common.get_pos_len_exn () ?pos ?len ~total_length:(length t)
in
let last = pos + len in
let rec loop i =
Int_replace_polymorphic_compare.( < ) i last
&& (Char.equal (get t i) char || loop (i + 1))
in
loop pos
;;
module Utf8 = struct
let set = set_uchar_utf_8
end
module Utf16le = struct
let set = set_uchar_utf_16le
end
module Utf16be = struct
let set = set_uchar_utf_16be
end
module Utf32le = struct
let set = set_uchar_utf_32le
end
module Utf32be = struct
let set = set_uchar_utf_32be
end
(* Include type-specific [Replace_polymorphic_compare] at the end, after
including functor application that could shadow its definitions. This is
here so that efficient versions of the comparison functions are exported by
this module. *)
include Bytes_replace_polymorphic_compare

1
unikernel/duniverse/base/src/bytes.mli Normal file
View file

@ -0,0 +1 @@
include Bytes_intf.Bytes (** @inline *)

175
unikernel/duniverse/base/src/bytes0.ml Normal file
View file

@ -0,0 +1,175 @@
(* [Bytes0] defines string functions that are primitives or can be simply
defined in terms of [Stdlib.Bytes]. [Bytes0] is intended to completely express
the part of [Stdlib.Bytes] that [Base] uses -- no other file in Base other
than bytes0.ml should use [Stdlib.Bytes]. [Bytes0] has few dependencies, and
so is available early in Base's build order.
All Base files that need to use strings and come before [Base.Bytes] in
build order should do:
{[
module Bytes = Bytes0
]}
Defining [module Bytes = Bytes0] is also necessary because it prevents
ocamldep from mistakenly causing a file to depend on [Base.Bytes]. *)
open! Import0
module Uchar = Uchar0
module Sys = Sys0
module Primitives = struct
external get : (bytes[@local_opt]) -> (int[@local_opt]) -> char = "%bytes_safe_get"
external length : (bytes[@local_opt]) -> int = "%bytes_length"
external unsafe_get
: (bytes[@local_opt])
-> (int[@local_opt])
-> char
= "%bytes_unsafe_get"
external set
: (bytes[@local_opt])
-> (int[@local_opt])
-> (char[@local_opt])
-> unit
= "%bytes_safe_set"
external unsafe_set
: (bytes[@local_opt])
-> (int[@local_opt])
-> (char[@local_opt])
-> unit
= "%bytes_unsafe_set"
(* [unsafe_blit_string] is not exported in the [stdlib] so we export it here *)
external unsafe_blit_string
: src:(string[@local_opt])
-> src_pos:int
-> dst:(bytes[@local_opt])
-> dst_pos:int
-> len:int
-> unit
= "caml_blit_string"
[@@noalloc]
external unsafe_get_int64
: (bytes[@local_opt])
-> (int[@local_opt])
-> int64
= "%caml_bytes_get64u"
external unsafe_set_int64
: (bytes[@local_opt])
-> (int[@local_opt])
-> (int64[@local_opt])
-> unit
= "%caml_bytes_set64u"
external unsafe_get_int32
: (bytes[@local_opt])
-> (int[@local_opt])
-> int32
= "%caml_bytes_get32u"
external unsafe_set_int32
: (bytes[@local_opt])
-> (int[@local_opt])
-> (int32[@local_opt])
-> unit
= "%caml_bytes_set32u"
external unsafe_get_int16
: (bytes[@local_opt])
-> (int[@local_opt])
-> int
= "%caml_bytes_get16u"
external unsafe_set_int16
: (bytes[@local_opt])
-> (int[@local_opt])
-> (int[@local_opt])
-> unit
= "%caml_bytes_set16u"
end
include Primitives
let max_length = Sys.max_string_length
let blit = Stdlib.Bytes.blit
let blit_string = Stdlib.Bytes.blit_string
let compare = Stdlib.Bytes.compare
let copy = Stdlib.Bytes.copy
let create = Stdlib.Bytes.create
let set_uchar_utf_8 = Stdlib.Bytes.set_utf_8_uchar
let set_uchar_utf_16le = Stdlib.Bytes.set_utf_16le_uchar
let set_uchar_utf_16be = Stdlib.Bytes.set_utf_16be_uchar
let set_utf_32_uchar ~set_int32 bytes idx uchar =
Uchar.to_int uchar
|> Int_conversions.int_to_int32_trunc (* should never have anything to truncate *)
|> set_int32 bytes idx;
4
;;
let set_uchar_utf_32le = set_utf_32_uchar ~set_int32:Stdlib.Bytes.set_int32_le
let set_uchar_utf_32be = set_utf_32_uchar ~set_int32:Stdlib.Bytes.set_int32_be
external unsafe_create_local : int -> bytes = "Base_unsafe_create_local_bytes"
let create_local len =
if len > Sys0.max_string_length then invalid_arg "Bytes.create_local";
unsafe_create_local len
;;
let fill = Stdlib.Bytes.fill
let make = Stdlib.Bytes.make
let map t ~(f : _ -> _) =
let l = length t in
if l = 0
then t
else (
let r = create l in
for i = 0 to l - 1 do
unsafe_set r i (f (unsafe_get t i))
done;
r)
;;
let mapi t ~(f : _ -> _ -> _) =
let l = length t in
if l = 0
then t
else (
let r = create l in
for i = 0 to l - 1 do
unsafe_set r i (f i (unsafe_get t i))
done;
r)
;;
let sub = Stdlib.Bytes.sub
external unsafe_blit
: src:(bytes[@local_opt])
-> src_pos:int
-> dst:(bytes[@local_opt])
-> dst_pos:int
-> len:int
-> unit
= "caml_blit_bytes"
[@@noalloc]
let to_string = Stdlib.Bytes.to_string
let of_string = Stdlib.Bytes.of_string
external unsafe_to_string
: no_mutation_while_string_reachable:(bytes[@local_opt])
-> (string[@local_opt])
= "%bytes_to_string"
external unsafe_of_string_promise_no_mutation
: (string[@local_opt])
-> (bytes[@local_opt])
= "%bytes_of_string"

308
unikernel/duniverse/base/src/bytes_intf.ml Normal file
View file

@ -0,0 +1,308 @@
open! Import
(** Interface for Unicode encodings, such as UTF-8. *)
module type Utf = sig
type t := bytes
(** Writes a Unicode character to a given position using this encoding. *)
val set : t -> int -> Uchar0.t -> int
end
module type Bytes = sig
(** OCaml's byte sequence type, semantically similar to a [char array], but
taking less space in memory.
A byte sequence is a mutable data structure that contains a fixed-length
sequence of bytes (of type [char]). Each byte can be indexed in constant
time for reading or writing. *)
open! Import
type t = bytes [@@deriving_inline globalize, sexp, sexp_grammar]
val globalize : t -> t
include Sexplib0.Sexpable.S with type t := t
val t_sexp_grammar : t Sexplib0.Sexp_grammar.t
[@@@end]
(** {1 Common Interfaces} *)
include Blit.S with type t := t
include Comparable.S with type t := t
include Ppx_compare_lib.Comparable.S_local with type t := t
include Ppx_compare_lib.Equal.S_local with type t := t
include Stringable.S with type t := t
(** Note that [pp] allocates in order to preserve the state of the byte
sequence it was initially called with. *)
include Pretty_printer.S with type t := t
include Invariant.S with type t := t
module To_string : sig
val sub : (t, string) Blit.sub
val subo : (t, string) Blit.subo
end
module From_string : Blit.S_distinct with type src := string and type dst := t
(** [create len] returns a newly-allocated and uninitialized byte sequence of
length [len]. No guarantees are made about the contents of the return
value. *)
val create : int -> t
(** [create_local] is like [create], but returns a stack-allocated [Bytes.t]. *)
val create_local : int -> t
(** [make len c] returns a newly-allocated byte sequence of length [len] filled
with the byte [c]. *)
val make : int -> char -> t
(** [map f t] applies function [f] to every byte, in order, and builds the byte
sequence with the results returned by [f]. *)
val map : t -> f:(char -> char) -> t
(** Like [map], but passes each character's index to [f] along with the char. *)
val mapi : t -> f:(int -> char -> char) -> t
(** [copy t] returns a newly-allocated byte sequence that contains the same
bytes as [t]. *)
val copy : t -> t
(** [init len ~f] returns a newly-allocated byte sequence of length [len] with
index [i] in the sequence being initialized with the result of [f i]. *)
val init : int -> f:(int -> char) -> t
(** [of_char_list l] returns a newly-allocated byte sequence where each byte in
the sequence corresponds to the byte in [l] at the same index. *)
val of_char_list : char list -> t
(** [length t] returns the number of bytes in [t]. *)
external length : (t[@local_opt]) -> int = "%bytes_length"
(** [get t i] returns the [i]th byte of [t]. *)
val get : t -> int -> char
external unsafe_get : (t[@local_opt]) -> (int[@local_opt]) -> char = "%bytes_unsafe_get"
(** [set t i c] sets the [i]th byte of [t] to [c]. *)
external set
: (t[@local_opt])
-> (int[@local_opt])
-> (char[@local_opt])
-> unit
= "%bytes_safe_set"
external unsafe_set
: (t[@local_opt])
-> (int[@local_opt])
-> (char[@local_opt])
-> unit
= "%bytes_unsafe_set"
external unsafe_get_int64
: (t[@local_opt])
-> (int[@local_opt])
-> int64
= "%caml_bytes_get64u"
external unsafe_set_int64
: (t[@local_opt])
-> (int[@local_opt])
-> (int64[@local_opt])
-> unit
= "%caml_bytes_set64u"
external unsafe_get_int32
: (t[@local_opt])
-> (int[@local_opt])
-> int32
= "%caml_bytes_get32u"
external unsafe_set_int32
: (t[@local_opt])
-> (int[@local_opt])
-> (int32[@local_opt])
-> unit
= "%caml_bytes_set32u"
external unsafe_get_int16
: (t[@local_opt])
-> (int[@local_opt])
-> int
= "%caml_bytes_get16u"
external unsafe_set_int16
: (t[@local_opt])
-> (int[@local_opt])
-> (int[@local_opt])
-> unit
= "%caml_bytes_set16u"
(** [fill t ~pos ~len c] modifies [t] in place, replacing all the bytes from
[pos] to [pos + len] with [c]. *)
val fill : t -> pos:int -> len:int -> char -> unit
(** [tr ~target ~replacement t] modifies [t] in place, replacing every instance
of [target] in [s] with [replacement]. *)
val tr : target:char -> replacement:char -> t -> unit
(** [tr_multi ~target ~replacement] returns an in-place function that replaces
every instance of a character in [target] with the corresponding character
in [replacement].
If [replacement] is shorter than [target], it is lengthened by repeating
its last character. Empty [replacement] is illegal unless [target] also is.
If [target] contains multiple copies of the same character, the last
corresponding [replacement] character is used. Note that character ranges
are {b not} supported, so [~target:"a-z"] means the literal characters ['a'],
['-'], and ['z']. *)
val tr_multi : target:string -> replacement:string -> (t -> unit) Staged.t
(** [to_list t] returns the bytes in [t] as a list of chars. *)
val to_list : t -> char list
(** [to_array t] returns the bytes in [t] as an array of chars. *)
val to_array : t -> char array
(** [fold a ~f ~init:b] is [f a1 (f a2 (...))] *)
val fold : t -> init:'acc -> f:('acc -> char -> 'acc) -> 'acc
(** [foldi] works similarly to [fold], but also passes the index of each character to
[f]. *)
val foldi : t -> init:'acc -> f:(int -> 'acc -> char -> 'acc) -> 'acc
(** [contains ?pos ?len t c] returns [true] iff [c] appears in [t] between [pos]
and [pos + len]. *)
val contains : ?pos:int -> ?len:int -> t -> char -> bool
(** Maximum length of a byte sequence, which is architecture-dependent. Attempting to
create a [Bytes] larger than this will raise an exception. *)
val max_length : int
(** {2:unsafe Unsafe conversions (for advanced users)}
This section describes unsafe, low-level conversion functions between
[bytes] and [string]. They might not copy the internal data; used
improperly, they can break the immutability invariant on strings provided
by the [-safe-string] option. They are available for expert library
authors, but for most purposes you should use the always-correct
{!Bytes.to_string} and {!Bytes.of_string} instead.
*)
(** Unsafely convert a byte sequence into a string.
To reason about the use of [unsafe_to_string], it is convenient to
consider an "ownership" discipline. A piece of code that
manipulates some data "owns" it; there are several disjoint ownership
modes, including:
{ul
{- Unique ownership: the data may be accessed and mutated}
{- Shared ownership: the data has several owners, that may only
access it, not mutate it.}}
Unique ownership is linear: passing the data to another piece of
code means giving up ownership (we cannot access the
data again). A unique owner may decide to make the data shared
(giving up mutation rights on it), but shared data may not become
uniquely-owned again.
[unsafe_to_string s] can only be used when the caller owns the byte
sequence [s] -- either uniquely or as shared immutable data. The
caller gives up ownership of [s], and gains (the same mode of) ownership
of the returned string.
There are two valid use-cases that respect this ownership
discipline:
{ol
{- The first is creating a string by initializing and mutating a byte
sequence that is never changed after initialization is performed.
{[
let string_init len f : string =
let s = Bytes.create len in
for i = 0 to len - 1 do Bytes.set s i (f i) done;
Bytes.unsafe_to_string ~no_mutation_while_string_reachable:s
]}
This function is safe because the byte sequence [s] will never be
accessed or mutated after [unsafe_to_string] is called. The
[string_init] code gives up ownership of [s], and returns the
ownership of the resulting string to its caller.
Note that it would be unsafe if [s] was passed as an additional
parameter to the function [f] as it could escape this way and be
mutated in the future -- [string_init] would give up ownership of
[s] to pass it to [f], and could not call [unsafe_to_string]
safely.
We have provided the {!String.init}, {!String.map} and
{!String.mapi} functions to cover most cases of building
new strings. You should prefer those over [to_string] or
[unsafe_to_string] whenever applicable.}
{- The second is temporarily giving ownership of a byte sequence to
a function that expects a uniquely owned string and returns ownership
back, so that we can mutate the sequence again after the call ended.
{[
let bytes_length (s : bytes) =
String.length
(Bytes.unsafe_to_string ~no_mutation_while_string_reachable:s)
]}
In this use-case, we do not promise that [s] will never be mutated
after the call to [bytes_length s]. The {!String.length} function
temporarily borrows unique ownership of the byte sequence
(and sees it as a [string]), but returns this ownership back to
the caller, which may assume that [s] is still a valid byte
sequence after the call. Note that this is only correct because we
know that {!String.length} does not capture its argument -- it could
escape by a side-channel such as a memoization combinator.
The caller may not mutate [s] while the string is borrowed (it has
temporarily given up ownership). This affects concurrent programs,
but also higher-order functions: if {!String.length} returned
a closure to be called later, [s] should not be mutated until this
closure is fully applied and returns ownership.}}
*)
external unsafe_to_string
: no_mutation_while_string_reachable:(t[@local_opt])
-> (string[@local_opt])
= "%bytes_to_string"
(** Unsafely convert a shared string to a byte sequence that should
not be mutated.
The same ownership discipline that makes [unsafe_to_string]
correct applies to [unsafe_of_string_promise_no_mutation],
however unique ownership of string values is extremely difficult
to reason about correctly in practice. As such, one should always
assume strings are shared, never uniquely owned (For example,
string literals are implicitly shared by the compiler, so you
never uniquely own them)
The only case we have reasonable confidence is safe is if the
produced [bytes] is shared -- used as an immutable byte
sequence. This is possibly useful for incremental migration of
low-level programs that manipulate immutable sequences of bytes
(for example {!Marshal.from_bytes}) and previously used the
[string] type for this purpose.
*)
external unsafe_of_string_promise_no_mutation
: (string[@local_opt])
-> (t[@local_opt])
= "%bytes_of_string"
(** UTF-8 encoding. See [Utf] interface. *)
module Utf8 : Utf
(** UTF-16 little-endian encoding. See [Utf] interface. *)
module Utf16le : Utf
(** UTF-16 big-endian encoding. See [Utf] interface. *)
module Utf16be : Utf
(** UTF-32 little-endian encoding. See [Utf] interface. *)
module Utf32le : Utf
(** UTF-32 big-endian encoding. See [Utf] interface. *)
module Utf32be : Utf
module type Utf = Utf
end

9
unikernel/duniverse/base/src/bytes_stubs.c Normal file
View file

@ -0,0 +1,9 @@
#include <caml/alloc.h>
/* This is the same as caml_create_local_bytes, except that we skip the
bounds-check and instead do it on the ocaml side, so that we can mark the C
call noalloc. */
CAMLprim value Base_unsafe_create_local_bytes(value len) {
mlsize_t size = Long_val(len);
return caml_alloc_string(size);
}

41
unikernel/duniverse/base/src/bytes_tr.ml Normal file
View file

@ -0,0 +1,41 @@
open! Import0.Int_replace_polymorphic_compare
module Bytes = Bytes0
module String = String0
(* Construct a byte string of length 256, mapping every input character code to
its corresponding output character.
Benchmarks indicate that this is faster than the lambda (including cost of
this function), even if target/replacement are just 2 characters each.
Return None if the translation map is equivalent to just the identity. *)
let tr_create_map ~target ~replacement =
let tr_map = Bytes.create 256 in
for i = 0 to 255 do
Bytes.unsafe_set tr_map i (Char.of_int_exn i)
done;
for i = 0 to min (String.length target) (String.length replacement) - 1 do
let index = Char.to_int (String.unsafe_get target i) in
Bytes.unsafe_set tr_map index (String.unsafe_get replacement i)
done;
let last_replacement = String.unsafe_get replacement (String.length replacement - 1) in
for
i = min (String.length target) (String.length replacement) to String.length target - 1
do
let index = Char.to_int (String.unsafe_get target i) in
Bytes.unsafe_set tr_map index last_replacement
done;
let rec have_any_different tr_map i =
if i = 256
then false
else if Char.( <> ) (Bytes0.unsafe_get tr_map i) (Char.of_int_exn i)
then true
else have_any_different tr_map (i + 1)
in
(* quick check on the first target character which will 99% be true *)
let first_target = target.[0] in
if Char.( <> ) (Bytes0.unsafe_get tr_map (Char.to_int first_target)) first_target
|| have_any_different tr_map 0
then Some (Bytes0.unsafe_to_string ~no_mutation_while_string_reachable:tr_map)
else None
;;

163
unikernel/duniverse/base/src/char.ml Normal file
View file

@ -0,0 +1,163 @@
open! Import
module Array = Array0
module String = String0
include Char0
module T = struct
type t = char [@@deriving_inline compare, hash, globalize, sexp, sexp_grammar]
let compare = (compare_char : t -> t -> int)
let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) =
hash_fold_char
and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) =
let func = hash_char in
fun x -> func x
;;
let (globalize : t -> t) = (globalize_char : t -> t)
let t_of_sexp = (char_of_sexp : Sexplib0.Sexp.t -> t)
let sexp_of_t = (sexp_of_char : t -> Sexplib0.Sexp.t)
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = char_sexp_grammar
[@@@end]
let to_string t = String.make 1 t
let of_string s =
match String.length s with
| 1 -> s.[0]
| _ -> failwithf "Char.of_string: %S" s ()
;;
end
include T
include Identifiable.Make (struct
include T
let module_name = "Base.Char"
end)
let pp fmt c = Stdlib.Format.fprintf fmt "%C" c
(* Open replace_polymorphic_compare after including functor instantiations so they do not
shadow its definitions. This is here so that efficient versions of the comparison
functions are available within this module. *)
open! Char_replace_polymorphic_compare
let invariant (_ : t) = ()
let all = Array.init 256 ~f:unsafe_of_int |> Array.to_list
let is_lowercase = function
| 'a' .. 'z' -> true
| _ -> false
;;
let is_uppercase = function
| 'A' .. 'Z' -> true
| _ -> false
;;
let is_print = function
| ' ' .. '~' -> true
| _ -> false
;;
let is_whitespace = function
| '\t' | '\n' | '\011' (* vertical tab *) | '\012' (* form feed *) | '\r' | ' ' -> true
| _ -> false
;;
let is_digit = function
| '0' .. '9' -> true
| _ -> false
;;
let is_alpha = function
| 'a' .. 'z' | 'A' .. 'Z' -> true
| _ -> false
;;
(* Writing these out, instead of calling [is_alpha] and [is_digit], reduces
runtime by approx. 30% *)
let is_alphanum = function
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true
| _ -> false
;;
let get_digit_unsafe t = to_int t - to_int '0'
let get_digit_exn t =
if is_digit t
then get_digit_unsafe t
else failwithf "Char.get_digit_exn %C: not a digit" t ()
;;
let get_digit t = if is_digit t then Some (get_digit_unsafe t) else None
let is_hex_digit = function
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
| _ -> false
;;
let is_hex_digit_lower = function
| '0' .. '9' | 'a' .. 'f' -> true
| _ -> false
;;
let is_hex_digit_upper = function
| '0' .. '9' | 'A' .. 'F' -> true
| _ -> false
;;
let get_hex_digit_exn = function
| '0' .. '9' as t -> to_int t - to_int '0'
| 'a' .. 'f' as t -> to_int t - to_int 'a' + 10
| 'A' .. 'F' as t -> to_int t - to_int 'A' + 10
| t ->
Error.raise_s
(Sexp.message
"Char.get_hex_digit_exn: not a hexadecimal digit"
[ "char", sexp_of_t t ])
;;
let get_hex_digit t = if is_hex_digit t then Some (get_hex_digit_exn t) else None
module O = struct
let ( >= ) = ( >= )
let ( <= ) = ( <= )
let ( = ) = ( = )
let ( > ) = ( > )
let ( < ) = ( < )
let ( <> ) = ( <> )
end
module Caseless = struct
module T = struct
type t = char [@@deriving_inline sexp, sexp_grammar]
let t_of_sexp = (char_of_sexp : Sexplib0.Sexp.t -> t)
let sexp_of_t = (sexp_of_char : t -> Sexplib0.Sexp.t)
let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = char_sexp_grammar
[@@@end]
let compare c1 c2 = compare (lowercase c1) (lowercase c2)
let compare__local c1 c2 = compare c1 c2
let hash_fold_t state t = hash_fold_char state (lowercase t)
let hash t = Hash.run hash_fold_t t
end
include T
include Comparable.Make (T)
let equal__local t1 t2 = equal_int (compare__local t1 t2) 0
end
(* Include type-specific [Replace_polymorphic_compare] at the end, after
including functor application that could shadow its definitions. This is
here so that efficient versions of the comparison functions are exported by
this module. *)
include Char_replace_polymorphic_compare

107
unikernel/duniverse/base/src/char.mli Normal file
View file

@ -0,0 +1,107 @@
(** A type for 8-bit characters. *)
open! Import
(** An alias for the type of characters. *)
type t = char [@@deriving_inline enumerate, globalize, sexp, sexp_grammar]
include Ppx_enumerate_lib.Enumerable.S with type t := t
val globalize : t -> t
include Sexplib0.Sexpable.S with type t := t
val t_sexp_grammar : t Sexplib0.Sexp_grammar.t
[@@@end]
include Identifiable.S with type t := t
include Ppx_compare_lib.Equal.S_local with type t := t
include Ppx_compare_lib.Comparable.S_local with type t := t
include Invariant.S with type t := t
module O : Comparisons.Infix with type t := t
(** Returns the ASCII code of the argument. *)
val to_int : t -> int
(** Returns the character with the given ASCII code or [None] is the argument is outside
the range 0 to 255. *)
val of_int : int -> t option
(** Returns the character with the given ASCII code. Raises [Failure] if the argument is
outside the range 0 to 255. *)
val of_int_exn : int -> t
val unsafe_of_int : int -> t
(** Returns a string representing the given character, with special characters escaped
following the lexical conventions of OCaml. *)
val escaped : t -> string
(** Converts the given character to its equivalent lowercase character. *)
val lowercase : t -> t
(** Converts the given character to its equivalent uppercase character. *)
val uppercase : t -> t
(** '0' - '9' *)
val is_digit : t -> bool
(** 'a' - 'z' *)
val is_lowercase : t -> bool
(** 'A' - 'Z' *)
val is_uppercase : t -> bool
(** 'a' - 'z' or 'A' - 'Z' *)
val is_alpha : t -> bool
(** 'a' - 'z' or 'A' - 'Z' or '0' - '9' *)
val is_alphanum : t -> bool
(** ' ' - '~' *)
val is_print : t -> bool
(** ' ' or '\t' or '\r' or '\n' *)
val is_whitespace : t -> bool
(** Returns [Some i] if [is_digit c] and [None] otherwise. *)
val get_digit : t -> int option
(** Returns [i] if [is_digit c] and raises [Failure] otherwise. *)
val get_digit_exn : t -> int
(** '0' - '9' or 'a' - 'f' or 'A' - 'F' *)
val is_hex_digit : t -> bool
(** '0' - '9' or 'a' - 'f' *)
val is_hex_digit_lower : t -> bool
(** '0' - '9' or 'A' - 'F' *)
val is_hex_digit_upper : t -> bool
(** Returns [Some i] where [0 <= i && i < 16] if [is_hex_digit c] and [None] otherwise. *)
val get_hex_digit : t -> int option
(** Same as [get_hex_digit] but raises instead of returning None. *)
val get_hex_digit_exn : t -> int
val min_value : t
val max_value : t
(** [Caseless] compares and hashes characters ignoring case, so that for example
[Caseless.equal 'A' 'a'] and [Caseless.('a' < 'B')] are [true]. *)
module Caseless : sig
type nonrec t = t [@@deriving_inline hash, sexp, sexp_grammar]
include Ppx_hash_lib.Hashable.S with type t := t
include Sexplib0.Sexpable.S with type t := t
val t_sexp_grammar : t Sexplib0.Sexp_grammar.t
[@@@end]
include Comparable.S with type t := t
include Ppx_compare_lib.Equal.S_local with type t := t
include Ppx_compare_lib.Comparable.S_local with type t := t
end

32
unikernel/duniverse/base/src/char0.ml Normal file
View file

@ -0,0 +1,32 @@
(* [Char0] defines char functions that are primitives or can be simply defined in terms of
[Stdlib.Char]. [Char0] is intended to completely express the part of [Stdlib.Char] that
[Base] uses -- no other file in Base other than char0.ml should use [Stdlib.Char].
[Char0] has few dependencies, and so is available early in Base's build order. All
Base files that need to use chars and come before [Base.Char] in build order should do
[module Char = Char0]. Defining [module Char = Char0] is also necessary because it
prevents ocamldep from mistakenly causing a file to depend on [Base.Char]. *)
open! Import0
let failwithf = Printf.failwithf
let escaped = Stdlib.Char.escaped
let lowercase = Stdlib.Char.lowercase_ascii
let to_int = Stdlib.Char.code
let unsafe_of_int = Stdlib.Char.unsafe_chr
let uppercase = Stdlib.Char.uppercase_ascii
(* We use our own range test when converting integers to chars rather than
calling [Stdlib.Char.chr] because it's simple and it saves us a function call
and the try-with (exceptions cost, especially in the world with backtraces). *)
let int_is_ok i = 0 <= i && i <= 255
let min_value = unsafe_of_int 0
let max_value = unsafe_of_int 255
let of_int i = if int_is_ok i then Some (unsafe_of_int i) else None
let of_int_exn i =
if int_is_ok i
then unsafe_of_int i
else failwithf "Char.of_int_exn got integer out of range: %d" i ()
;;
let equal (t1 : char) t2 = Poly.equal t1 t2

205
unikernel/duniverse/base/src/comparable.ml Normal file
View file

@ -0,0 +1,205 @@
open! Import
include Comparable_intf
module With_zero (T : sig
type t [@@deriving_inline compare]
include Ppx_compare_lib.Comparable.S with type t := t
[@@@end]
val zero : t
end) =
struct
open T
let is_positive t = compare t zero > 0
let is_non_negative t = compare t zero >= 0
let is_negative t = compare t zero < 0
let is_non_positive t = compare t zero <= 0
let sign t = Sign0.of_int (compare t zero)
end
module Poly (T : sig
type t [@@deriving_inline sexp_of]
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
end) =
struct
module Replace_polymorphic_compare = struct
type t = T.t [@@deriving_inline sexp_of]
let sexp_of_t = (T.sexp_of_t : t -> Sexplib0.Sexp.t)
[@@@end]
include Poly
end
include Poly
let between t ~low ~high = low <= t && t <= high
let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max
let clamp_exn t ~min ~max =
assert (min <= max);
clamp_unchecked t ~min ~max
;;
let clamp t ~min ~max =
if min > max
then
Or_error.error_s
(Sexp.message
"clamp requires [min <= max]"
[ "min", T.sexp_of_t min; "max", T.sexp_of_t max ])
else Ok (clamp_unchecked t ~min ~max)
;;
module C = struct
include T
include Comparator.Make (Replace_polymorphic_compare)
end
include C
end
let gt cmp a b = cmp a b > 0
let lt cmp a b = cmp a b < 0
let geq cmp a b = cmp a b >= 0
let leq cmp a b = cmp a b <= 0
let equal cmp a b = cmp a b = 0
let not_equal cmp a b = cmp a b <> 0
let min cmp t t' = if leq cmp t t' then t else t'
let max cmp t t' = if geq cmp t t' then t else t'
module Infix (T : sig
type t [@@deriving_inline compare]
include Ppx_compare_lib.Comparable.S with type t := t
[@@@end]
end) : Infix with type t := T.t = struct
let ( > ) a b = gt T.compare a b
let ( < ) a b = lt T.compare a b
let ( >= ) a b = geq T.compare a b
let ( <= ) a b = leq T.compare a b
let ( = ) a b = equal T.compare a b
let ( <> ) a b = not_equal T.compare a b
end
[@@inline always]
module Comparisons (T : sig
type t [@@deriving_inline compare]
include Ppx_compare_lib.Comparable.S with type t := t
[@@@end]
end) : Comparisons with type t := T.t = struct
include Infix (T)
let compare = T.compare
let equal = ( = )
let min t t' = min compare t t'
let max t t' = max compare t t'
end
[@@inline always]
module Make_using_comparator (T : sig
type t [@@deriving_inline sexp_of]
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
include Comparator.S with type t := t
end) : S with type t := T.t and type comparator_witness = T.comparator_witness = struct
module T = struct
include T
let compare = comparator.compare
end
include T
module Replace_polymorphic_compare = Comparisons (T)
include Replace_polymorphic_compare
let ascending = compare
let descending t t' = compare t' t
let between t ~low ~high = low <= t && t <= high
let clamp_unchecked t ~min ~max = if t < min then min else if t <= max then t else max
let clamp_exn t ~min ~max =
assert (min <= max);
clamp_unchecked t ~min ~max
;;
let clamp t ~min ~max =
if min > max
then
Or_error.error_s
(Sexp.message
"clamp requires [min <= max]"
[ "min", T.sexp_of_t min; "max", T.sexp_of_t max ])
else Ok (clamp_unchecked t ~min ~max)
;;
end
module Make (T : sig
type t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S with type t := t
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
end) =
Make_using_comparator [@inlined hint] (struct
include T
include Comparator.Make (T)
end)
module Inherit (C : sig
type t [@@deriving_inline compare]
include Ppx_compare_lib.Comparable.S with type t := t
[@@@end]
end) (T : sig
type t [@@deriving_inline sexp_of]
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
val component : t -> C.t
end) =
Make (struct
type t = T.t [@@deriving_inline sexp_of]
let sexp_of_t = (T.sexp_of_t : t -> Sexplib0.Sexp.t)
[@@@end]
let compare t t' = C.compare (T.component t) (T.component t')
end)
(* compare [x] and [y] lexicographically using functions in the list [cmps] *)
let lexicographic cmps x y =
let rec loop = function
| cmp :: cmps ->
let res = cmp x y in
if res = 0 then loop cmps else res
| [] -> 0
in
loop cmps
;;
let lift cmp ~f x y = cmp (f x) (f y)
let reverse cmp x y = cmp y x
type 'a reversed = 'a
let compare_reversed cmp x y = cmp y x

1
unikernel/duniverse/base/src/comparable.mli Normal file
View file

@ -0,0 +1 @@
include Comparable_intf.Comparable (** @inline *)

229
unikernel/duniverse/base/src/comparable_intf.ml Normal file
View file

@ -0,0 +1,229 @@
open! Import
module type Infix = Comparisons.Infix
module type Comparisons = Comparisons.S
module Sign = Sign0 (** @canonical Base.Sign *)
module type With_compare = sig
(** Various combinators for [compare] and [equal] functions. *)
(** [lexicographic cmps x y] compares [x] and [y] lexicographically using functions in the
list [cmps]. *)
val lexicographic : ('a -> 'a -> int) list -> 'a -> 'a -> int
(** [lift cmp ~f x y] compares [x] and [y] by comparing [f x] and [f y] via [cmp]. *)
val lift : ('a -> 'a -> 'result) -> f:('b -> 'a) -> 'b -> 'b -> 'result
(** [reverse cmp x y = cmp y x]
Reverses the direction of asymmetric relations by swapping their arguments. Useful,
e.g., for relations implementing "is a subset of" or "is a descendant of".
Where reversed relations are already provided, use them directly. For example,
[Comparable.S] provides [ascending] and [descending], which are more readable as a
pair than [compare] and [reverse compare]. Similarly, [<=] is more idiomatic than
[reverse (>=)]. *)
val reverse : ('a -> 'a -> 'result) -> 'a -> 'a -> 'result
(** {!reversed} is the identity type but its associated compare function is the same as
the {!reverse} function above. It allows you to get reversed comparisons with
[ppx_compare], writing, for example, [[%compare: string Comparable.reversed]] to
have strings ordered in the reverse order. *)
type 'a reversed = 'a
val compare_reversed : ('a -> 'a -> int) -> 'a reversed -> 'a reversed -> int
(** The functions below are analogues of the type-specific functions exported by the
[Comparable.S] interface. *)
val equal : ('a -> 'a -> int) -> 'a -> 'a -> bool
val max : ('a -> 'a -> int) -> 'a -> 'a -> 'a
val min : ('a -> 'a -> int) -> 'a -> 'a -> 'a
end
module type With_zero = sig
type t
val is_positive : t -> bool
val is_non_negative : t -> bool
val is_negative : t -> bool
val is_non_positive : t -> bool
(** Returns [Neg], [Zero], or [Pos] in a way consistent with the above functions. *)
val sign : t -> Sign.t
end
module type S = sig
include Comparisons
(** [ascending] is identical to [compare]. [descending x y = ascending y x]. These are
intended to be mnemonic when used like [List.sort ~compare:ascending] and [List.sort
~cmp:descending], since they cause the list to be sorted in ascending or descending
order, respectively. *)
val ascending : t -> t -> int
val descending : t -> t -> int
(** [between t ~low ~high] means [low <= t <= high] *)
val between : t -> low:t -> high:t -> bool
(** [clamp_exn t ~min ~max] returns [t'], the closest value to [t] such that
[between t' ~low:min ~high:max] is true.
Raises if [not (min <= max)]. *)
val clamp_exn : t -> min:t -> max:t -> t
val clamp : t -> min:t -> max:t -> t Or_error.t
include Comparator.S with type t := t
end
(** Usage example:
{[
module Foo : sig
type t = ...
include Comparable.S with type t := t
end
]}
Then use [Comparable.Make] in the struct (see comparable.mli for an example). *)
module type Comparable = sig
(** Defines functors for making modules comparable. *)
(** Usage example:
{[
module Foo = struct
module T = struct
type t = ... [@@deriving compare, sexp]
end
include T
include Comparable.Make (T)
end
]}
Then include [Comparable.S] in the signature
{[
module Foo : sig
type t = ...
include Comparable.S with type t := t
end
]}
To add an [Infix] submodule:
{[
module C = Comparable.Make (T)
include C
module Infix = (C : Comparable.Infix with type t := t)
]}
A common pattern is to define a module [O] with a restricted signature. It aims to be
(locally) opened to bring useful operators into scope without shadowing unexpected
variable names. E.g., in the [Date] module:
{[
module O = struct
include (C : Comparable.Infix with type t := t)
let to_string t = ..
end
]}
Opening [Date] would shadow [now], but opening [Date.O] doesn't:
{[
let now = .. in
let someday = .. in
Date.O.(now > someday)
]} *)
module type Infix = Infix
module type S = S
module type Comparisons = Comparisons
module type With_compare = With_compare
module type With_zero = With_zero
include With_compare
(** Derive [Infix] or [Comparisons] functions from just [[@@deriving compare]],
without need for the [sexp_of_t] required by [Make*] (see below). *)
module Infix (T : sig
type t [@@deriving_inline compare]
include Ppx_compare_lib.Comparable.S with type t := t
[@@@end]
end) : Infix with type t := T.t
module Comparisons (T : sig
type t [@@deriving_inline compare]
include Ppx_compare_lib.Comparable.S with type t := t
[@@@end]
end) : Comparisons with type t := T.t
(** Inherit comparability from a component. *)
module Inherit (C : sig
type t [@@deriving_inline compare]
include Ppx_compare_lib.Comparable.S with type t := t
[@@@end]
end) (T : sig
type t [@@deriving_inline sexp_of]
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
val component : t -> C.t
end) : S with type t := T.t
module Make (T : sig
type t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S with type t := t
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
end) : S with type t := T.t
module Make_using_comparator (T : sig
type t [@@deriving_inline sexp_of]
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
include Comparator.S with type t := t
end) : S with type t := T.t with type comparator_witness := T.comparator_witness
module Poly (T : sig
type t [@@deriving_inline sexp_of]
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
end) : S with type t := T.t
module With_zero (T : sig
type t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S with type t := t
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
val zero : t
end) : sig
include With_zero with type t := T.t
end
end

214
unikernel/duniverse/base/src/comparator.ml Normal file
View file

@ -0,0 +1,214 @@
open! Import
type ('a, 'witness) t =
{ compare : 'a -> 'a -> int
; sexp_of_t : 'a -> Sexp.t
}
type ('a, 'b) comparator = ('a, 'b) t
module type S = sig
type t
type comparator_witness
val comparator : (t, comparator_witness) comparator
end
module type S1 = sig
type 'a t
type comparator_witness
val comparator : ('a t, comparator_witness) comparator
end
module type S_fc = sig
type comparable_t
include S with type t := comparable_t
end
module Module = struct
type ('a, 'b) t = (module S with type t = 'a and type comparator_witness = 'b)
end
let of_module (type a b) ((module M) : (a, b) Module.t) = M.comparator
let to_module (type a b) t : (a, b) Module.t =
(module struct
type t = a
type comparator_witness = b
let comparator = t
end)
;;
let make (type t) ~compare ~sexp_of_t =
(module struct
type comparable_t = t
type comparator_witness
let comparator = { compare; sexp_of_t }
end : S_fc
with type comparable_t = t)
;;
module S_to_S1 (S : S) = struct
type 'a t = S.t
type comparator_witness = S.comparator_witness
open S
let comparator = comparator
end
module Make (M : sig
type t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S with type t := t
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
end) =
struct
include M
type comparator_witness
let comparator = M.{ compare; sexp_of_t }
end
module Make1 (M : sig
type 'a t
val compare : 'a t -> 'a t -> int
val sexp_of_t : 'a t -> Sexp.t
end) =
struct
type comparator_witness
let comparator = M.{ compare; sexp_of_t }
end
module Poly = struct
type 'a t = 'a
include Make1 (struct
type 'a t = 'a
let compare = Poly.compare
let sexp_of_t _ = Sexp.Atom "_"
end)
end
module type Derived = sig
type 'a t
type !'cmp comparator_witness
val comparator : ('a, 'cmp) comparator -> ('a t, 'cmp comparator_witness) comparator
end
module Derived (M : sig
type 'a t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t
val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t
[@@@end]
end) =
struct
type !'cmp comparator_witness
let comparator a =
{ compare = M.compare a.compare; sexp_of_t = M.sexp_of_t a.sexp_of_t }
;;
end
module type Derived2 = sig
type ('a, 'b) t
type (!'cmp_a, !'cmp_b) comparator_witness
val comparator
: ('a, 'cmp_a) comparator
-> ('b, 'cmp_b) comparator
-> (('a, 'b) t, ('cmp_a, 'cmp_b) comparator_witness) comparator
end
module Derived2 (M : sig
type ('a, 'b) t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t
val sexp_of_t
: ('a -> Sexplib0.Sexp.t)
-> ('b -> Sexplib0.Sexp.t)
-> ('a, 'b) t
-> Sexplib0.Sexp.t
[@@@end]
end) =
struct
type (!'cmp_a, !'cmp_b) comparator_witness
let comparator a b =
{ compare = M.compare a.compare b.compare
; sexp_of_t = M.sexp_of_t a.sexp_of_t b.sexp_of_t
}
;;
end
module type Derived_phantom = sig
type ('a, 'b) t
type 'cmp comparator_witness
val comparator
: ('a, 'cmp) comparator
-> (('a, _) t, 'cmp comparator_witness) comparator
end
module Derived_phantom (M : sig
type ('a, 'b) t
val compare : ('a -> 'a -> int) -> ('a, 'b) t -> ('a, 'b) t -> int
val sexp_of_t : ('a -> Sexp.t) -> ('a, _) t -> Sexp.t
end) =
struct
type 'cmp_a comparator_witness
let comparator a =
{ compare = M.compare a.compare; sexp_of_t = M.sexp_of_t a.sexp_of_t }
;;
end
module type Derived2_phantom = sig
type ('a, 'b, 'c) t
type (!'cmp_a, !'cmp_b) comparator_witness
val comparator
: ('a, 'cmp_a) comparator
-> ('b, 'cmp_b) comparator
-> (('a, 'b, _) t, ('cmp_a, 'cmp_b) comparator_witness) comparator
end
module Derived2_phantom (M : sig
type ('a, 'b, 'c) t
val compare
: ('a -> 'a -> int)
-> ('b -> 'b -> int)
-> ('a, 'b, 'c) t
-> ('a, 'b, 'c) t
-> int
val sexp_of_t : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b, _) t -> Sexp.t
end) =
struct
type (!'cmp_a, !'cmp_b) comparator_witness
let comparator a b =
{ compare = M.compare a.compare b.compare
; sexp_of_t = M.sexp_of_t a.sexp_of_t b.sexp_of_t
}
;;
end

170
unikernel/duniverse/base/src/comparator.mli Normal file
View file

@ -0,0 +1,170 @@
(** Comparison and serialization for a type, using a witness type to distinguish between
comparison functions with different behavior. *)
open! Import
(** [('a, 'witness) t] contains a comparison function for values of type ['a]. Two values
of type [t] with the same ['witness] are guaranteed to have the same comparison
function. *)
type ('a, 'witness) t = private
{ compare : 'a -> 'a -> int
; sexp_of_t : 'a -> Sexp.t
}
type ('a, 'b) comparator = ('a, 'b) t
module type S = sig
type t
type comparator_witness
val comparator : (t, comparator_witness) comparator
end
module type S1 = sig
type 'a t
type comparator_witness
val comparator : ('a t, comparator_witness) comparator
end
module type S_fc = sig
type comparable_t
include S with type t := comparable_t
end
(** [make] creates a comparator witness for the given comparison. It is intended as a
lightweight alternative to the functors below, to be used like so:
{[
include (val Comparator.make ~compare ~sexp_of_t)
]}
*)
val make
: compare:('a -> 'a -> int)
-> sexp_of_t:('a -> Sexp.t)
-> (module S_fc with type comparable_t = 'a)
module Poly : S1 with type 'a t = 'a
module Module : sig
(** First-class module providing a comparator and witness type. *)
type ('a, 'b) t = (module S with type t = 'a and type comparator_witness = 'b)
end
val of_module : ('a, 'b) Module.t -> ('a, 'b) t
val to_module : ('a, 'b) t -> ('a, 'b) Module.t
module S_to_S1 (S : S) :
S1 with type 'a t = S.t with type comparator_witness = S.comparator_witness
(** [Make] creates a [comparator] value and its phantom [comparator_witness] type for a
nullary type. *)
module Make (M : sig
type t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S with type t := t
val sexp_of_t : t -> Sexplib0.Sexp.t
[@@@end]
end) : S with type t := M.t
(** [Make1] creates a [comparator] value and its phantom [comparator_witness] type for a
unary type. It takes a [compare] and [sexp_of_t] that have
non-standard types because the [Comparator.t] type doesn't allow passing in
additional values for the type argument. *)
module Make1 (M : sig
type 'a t
val compare : 'a t -> 'a t -> int
val sexp_of_t : _ t -> Sexp.t
end) : S1 with type 'a t := 'a M.t
module type Derived = sig
type 'a t
type !'cmp comparator_witness
val comparator : ('a, 'cmp) comparator -> ('a t, 'cmp comparator_witness) comparator
end
(** [Derived] creates a [comparator] function that constructs a comparator for the type
['a t] given a comparator for the type ['a]. *)
module Derived (M : sig
type 'a t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S1 with type 'a t := 'a t
val sexp_of_t : ('a -> Sexplib0.Sexp.t) -> 'a t -> Sexplib0.Sexp.t
[@@@end]
end) : Derived with type 'a t := 'a M.t
module type Derived2 = sig
type ('a, 'b) t
type (!'cmp_a, !'cmp_b) comparator_witness
val comparator
: ('a, 'cmp_a) comparator
-> ('b, 'cmp_b) comparator
-> (('a, 'b) t, ('cmp_a, 'cmp_b) comparator_witness) comparator
end
(** [Derived2] creates a [comparator] function that constructs a comparator for the type
[('a, 'b) t] given comparators for the type ['a] and ['b]. *)
module Derived2 (M : sig
type ('a, 'b) t [@@deriving_inline compare, sexp_of]
include Ppx_compare_lib.Comparable.S2 with type ('a, 'b) t := ('a, 'b) t
val sexp_of_t
: ('a -> Sexplib0.Sexp.t)
-> ('b -> Sexplib0.Sexp.t)
-> ('a, 'b) t
-> Sexplib0.Sexp.t
[@@@end]
end) : Derived2 with type ('a, 'b) t := ('a, 'b) M.t
module type Derived_phantom = sig
type ('a, 'b) t
type 'cmp comparator_witness
val comparator
: ('a, 'cmp) comparator
-> (('a, _) t, 'cmp comparator_witness) comparator
end
(** [Derived_phantom] creates a [comparator] function that constructs a comparator for the
type [('a, 'b) t] given a comparator for the type ['a]. *)
module Derived_phantom (M : sig
type ('a, 'b) t
val compare : ('a -> 'a -> int) -> ('a, 'b) t -> ('a, 'b) t -> int
val sexp_of_t : ('a -> Sexp.t) -> ('a, _) t -> Sexp.t
end) : Derived_phantom with type ('a, 'b) t := ('a, 'b) M.t
module type Derived2_phantom = sig
type ('a, 'b, 'c) t
type (!'cmp_a, !'cmp_b) comparator_witness
val comparator
: ('a, 'cmp_a) comparator
-> ('b, 'cmp_b) comparator
-> (('a, 'b, _) t, ('cmp_a, 'cmp_b) comparator_witness) comparator
end
(** [Derived2_phantom] creates a [comparator] function that constructs a comparator for the
type [('a, 'b, 'c) t] given a comparator for the types ['a] and ['b]. *)
module Derived2_phantom (M : sig
type ('a, 'b, 'c) t
val compare
: ('a -> 'a -> int)
-> ('b -> 'b -> int)
-> ('a, 'b, 'c) t
-> ('a, 'b, 'c) t
-> int
val sexp_of_t : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b, _) t -> Sexp.t
end) : Derived2_phantom with type ('a, 'b, 'c) t := ('a, 'b, 'c) M.t

45
unikernel/duniverse/base/src/comparisons.ml Normal file
View file

@ -0,0 +1,45 @@
(** Interfaces for infix comparison operators and comparison functions. *)
open! Import
(** [Infix] lists the typical infix comparison operators. These functions are provided by
[<M>.O] modules, i.e., modules that expose monomorphic infix comparisons over some
[<M>.t]. *)
module type Infix = sig
type t
val ( >= ) : t -> t -> bool
val ( <= ) : t -> t -> bool
val ( = ) : t -> t -> bool
val ( > ) : t -> t -> bool
val ( < ) : t -> t -> bool
val ( <> ) : t -> t -> bool
end
module type S = sig
include Infix
val equal : t -> t -> bool
(** [compare t1 t2] returns 0 if [t1] is equal to [t2], a negative integer if [t1] is
less than [t2], and a positive integer if [t1] is greater than [t2]. *)
val compare : t -> t -> int
val min : t -> t -> t
val max : t -> t -> t
end
module type S_with_local_opt = sig
type t
external ( < ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessthan"
external ( <= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%lessequal"
external ( <> ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%notequal"
external ( = ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"
external ( > ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterthan"
external ( >= ) : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%greaterequal"
external equal : (t[@local_opt]) -> (t[@local_opt]) -> bool = "%equal"
external compare : (t[@local_opt]) -> (t[@local_opt]) -> int = "%compare"
val min : t -> t -> t
val max : t -> t -> t
end

230
unikernel/duniverse/base/src/container.ml Normal file
View file

@ -0,0 +1,230 @@
open! Import
module Array = Array0
module Either = Either0
module List = List0
include Container_intf
let with_return = With_return.with_return
type ('t, 'a, 'accum) fold = 't -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum
type ('t, 'a) iter = 't -> f:('a -> unit) -> unit
type 't length = 't -> int
let iter ~(fold : (_, _, _) fold) t ~f = fold t ~init:() ~f:(fun () a -> f a) [@nontail]
let count ~fold t ~f = fold t ~init:0 ~f:(fun n a -> if f a then n + 1 else n) [@nontail]
let sum (type a) ~fold (module M : Summable with type t = a) t ~f =
fold t ~init:M.zero ~f:(fun n a -> M.( + ) n (f a)) [@nontail]
;;
let fold_result ~fold ~init ~f t =
with_return (fun { return } ->
Result.Ok
(fold t ~init ~f:(fun acc item ->
match f acc item with
| Result.Ok x -> x
| Error _ as e -> return e))) [@nontail]
;;
let fold_until ~fold ~init ~f ~finish t =
with_return (fun { return } ->
finish
(fold t ~init ~f:(fun acc item ->
match f acc item with
| Continue_or_stop.Continue x -> x
| Stop x -> return x))) [@nontail]
;;
let min_elt ~fold t ~compare =
fold t ~init:None ~f:(fun acc elt ->
match acc with
| None -> Some elt
| Some min -> if compare min elt > 0 then Some elt else acc) [@nontail]
;;
let max_elt ~fold t ~compare =
fold t ~init:None ~f:(fun acc elt ->
match acc with
| None -> Some elt
| Some max -> if compare max elt < 0 then Some elt else acc) [@nontail]
;;
let length ~fold c = fold c ~init:0 ~f:(fun acc _ -> acc + 1)
let is_empty ~iter c =
with_return (fun r ->
iter c ~f:(fun _ -> r.return false);
true)
;;
let mem ~iter c x ~equal =
with_return (fun r ->
iter c ~f:(fun y -> if equal x y then r.return true);
false) [@nontail]
;;
let exists ~iter c ~f =
with_return (fun r ->
iter c ~f:(fun x -> if f x then r.return true);
false) [@nontail]
;;
let for_all ~iter c ~f =
with_return (fun r ->
iter c ~f:(fun x -> if not (f x) then r.return false);
true) [@nontail]
;;
let find_map ~iter t ~f =
with_return (fun r ->
iter t ~f:(fun x ->
match f x with
| None -> ()
| Some _ as res -> r.return res);
None) [@nontail]
;;
let find ~iter c ~f =
with_return (fun r ->
iter c ~f:(fun x -> if f x then r.return (Some x));
None) [@nontail]
;;
let to_list ~fold c = List.rev (fold c ~init:[] ~f:(fun acc x -> x :: acc))
let to_array ~length ~iter c =
let array = ref [||] in
let i = ref 0 in
iter c ~f:(fun x ->
if !i = 0 then array := Array.create ~len:(length c) x;
!array.(!i) <- x;
incr i);
!array
;;
module Make_gen (T : Make_gen_arg) :
Generic
with type ('a, 'phantom1, 'phantom2) t := ('a, 'phantom1, 'phantom2) T.t
and type 'a elt := 'a T.elt = struct
let fold = T.fold
let iter =
match T.iter with
| `Custom iter -> iter
| `Define_using_fold -> fun t ~f -> iter ~fold t ~f
;;
let length =
match T.length with
| `Custom length -> length
| `Define_using_fold -> fun t -> length ~fold t
;;
let is_empty t = is_empty ~iter t
let mem t x ~equal = mem ~iter t x ~equal
let sum m t = sum ~fold m t
let count t ~f = count ~fold t ~f
let exists t ~f = exists ~iter t ~f
let for_all t ~f = for_all ~iter t ~f
let find_map t ~f = find_map ~iter t ~f
let find t ~f = find ~iter t ~f
let to_list t = to_list ~fold t
let to_array t = to_array ~length ~iter t
let min_elt t ~compare = min_elt ~fold t ~compare
let max_elt t ~compare = max_elt ~fold t ~compare
let fold_result t ~init ~f = fold_result t ~fold ~init ~f
let fold_until t ~init ~f ~finish = fold_until t ~fold ~init ~f ~finish
end
module Make (T : Make_arg) = struct
include Make_gen (struct
include T
type ('a, _, _) t = 'a T.t
type 'a elt = 'a
end)
end
module Make0 (T : Make0_arg) = struct
include Make_gen (struct
include T
type ('a, _, _) t = T.t
type 'a elt = T.Elt.t
end)
let mem t x = mem t x ~equal:T.Elt.equal
end
module Make_gen_with_creators (T : Make_gen_with_creators_arg) :
Generic_with_creators
with type ('a, 'phantom1, 'phantom2) t := ('a, 'phantom1, 'phantom2) T.t
and type 'a elt := 'a T.elt
and type ('a, 'phantom1, 'phantom2) concat := ('a, 'phantom1, 'phantom2) T.concat =
struct
include Make_gen (T)
let of_list = T.of_list
let of_array = T.of_array
let concat = T.concat
let concat_of_array = T.concat_of_array
let append a b = concat (concat_of_array [| a; b |])
let concat_map t ~f = concat (concat_of_array (Array.map (to_array t) ~f))
let filter_map t ~f =
concat_map t ~f:(fun x ->
match f x with
| None -> of_array [||]
| Some y -> of_array [| y |]) [@nontail]
;;
let map t ~f = filter_map t ~f:(fun x -> Some (f x)) [@nontail]
let filter t ~f = filter_map t ~f:(fun x -> if f x then Some x else None) [@nontail]
let partition_map t ~f =
let array = Array.map (to_array t) ~f in
let xs =
Array.fold_right array ~init:[] ~f:(fun either acc ->
match (either : _ Either.t) with
| First x -> x :: acc
| Second _ -> acc)
in
let ys =
Array.fold_right array ~init:[] ~f:(fun either acc ->
match (either : _ Either.t) with
| First _ -> acc
| Second x -> x :: acc)
in
of_list xs, of_list ys
;;
let partition_tf t ~f =
partition_map t ~f:(fun x -> if f x then First x else Second x) [@nontail]
;;
end
module Make_with_creators (T : Make_with_creators_arg) = struct
include Make_gen_with_creators (struct
include T
type ('a, _, _) t = 'a T.t
type 'a elt = 'a
type ('a, _, _) concat = 'a T.t
let concat_of_array = of_array
end)
end
module Make0_with_creators (T : Make0_with_creators_arg) = struct
include Make_gen_with_creators (struct
include T
type ('a, _, _) t = T.t
type 'a elt = T.Elt.t
type ('a, _, _) concat = 'a list
let concat_of_array = Array.to_list
end)
let mem t x = mem t x ~equal:T.Elt.equal
end

1
unikernel/duniverse/base/src/container.mli Normal file
View file

@ -0,0 +1 @@
include Container_intf.Container (** @inline *)

775
unikernel/duniverse/base/src/container_intf.ml Normal file
View file

@ -0,0 +1,775 @@
(** Provides generic signatures for container data structures.
These signatures include functions ([iter], [fold], [exists], [for_all], ...) that
you would expect to find in any container. Used by including [Container.S0] or
[Container.S1] in the signature for every container-like data structure ([Array],
[List], [String], ...) to ensure a consistent interface. *)
open! Import
module Export = struct
(** [Continue_or_stop.t] is used by the [f] argument to [fold_until] in order to
indicate whether folding should continue, or stop early.
@canonical Base.Container.Continue_or_stop
*)
module Continue_or_stop = struct
type ('a, 'b) t =
| Continue of 'a
| Stop of 'b
end
end
include Export
(** @canonical Base.Container.Summable *)
module type Summable = sig
type t
(** The result of summing no values. *)
val zero : t
(** An operation that combines two [t]'s and handles [zero + x] by just returning [x],
as well as in the symmetric case. *)
val ( + ) : t -> t -> t
end
(** Signature for monomorphic container - a container for a specific element type, e.g.,
string, which is a container of characters ([type elt = char]) and never of anything
else. *)
module type S0 = sig
type t
type elt
(** Checks whether the provided element is there, using equality on [elt]s. *)
val mem : t -> elt -> bool
val length : t -> int
val is_empty : t -> bool
(** [iter] must allow exceptions raised in [f] to escape, terminating the iteration
cleanly. The same holds for all functions below taking an [f]. *)
val iter : t -> f:(elt -> unit) -> unit
(** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en]
are the elements of [t]. *)
val fold : t -> init:'acc -> f:('acc -> elt -> 'acc) -> 'acc
(** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the
[Result] monad. If [f] returns an [Error _], that value is returned without any
additional invocations of [f]. *)
val fold_result
: t
-> init:'acc
-> f:('acc -> elt -> ('acc, 'e) Result.t)
-> ('acc, 'e) Result.t
(** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f]
returns [Stop _] the computation ceases and results in that value. If [f] returns
[Continue _], the fold will proceed. If [f] never returns [Stop _], the final result
is computed by [finish].
Example:
{[
type maybe_negative =
| Found_negative of int
| All_nonnegative of { sum : int }
(** [first_neg_or_sum list] returns the first negative number in [list], if any,
otherwise returns the sum of the list. *)
let first_neg_or_sum =
List.fold_until ~init:0
~f:(fun sum x ->
if x < 0
then Stop (Found_negative x)
else Continue (sum + x))
~finish:(fun sum -> All_nonnegative { sum })
;;
let x = first_neg_or_sum [1; 2; 3; 4; 5]
val x : maybe_negative = All_nonnegative {sum = 15}
let y = first_neg_or_sum [1; 2; -3; 4; 5]
val y : maybe_negative = Found_negative -3
]} *)
val fold_until
: t
-> init:'acc
-> f:('acc -> elt -> ('acc, 'final) Continue_or_stop.t)
-> finish:('acc -> 'final)
-> 'final
(** Returns [true] if and only if there exists an element for which the provided
function evaluates to [true]. This is a short-circuiting operation. *)
val exists : t -> f:(elt -> bool) -> bool
(** Returns [true] if and only if the provided function evaluates to [true] for all
elements. This is a short-circuiting operation. *)
val for_all : t -> f:(elt -> bool) -> bool
(** Returns the number of elements for which the provided function evaluates to true. *)
val count : t -> f:(elt -> bool) -> int
(** Returns the sum of [f i] for all [i] in the container. *)
val sum : (module Summable with type t = 'sum) -> t -> f:(elt -> 'sum) -> 'sum
(** Returns as an [option] the first element for which [f] evaluates to true. *)
val find : t -> f:(elt -> bool) -> elt option
(** Returns the first evaluation of [f] that returns [Some], and returns [None] if there
is no such element. *)
val find_map : t -> f:(elt -> 'a option) -> 'a option
val to_list : t -> elt list
val to_array : t -> elt array
(** Returns a min (resp. max) element from the collection using the provided [compare]
function. In case of a tie, the first element encountered while traversing the
collection is returned. The implementation uses [fold] so it has the same
complexity as [fold]. Returns [None] iff the collection is empty. *)
val min_elt : t -> compare:(elt -> elt -> int) -> elt option
val max_elt : t -> compare:(elt -> elt -> int) -> elt option
end
module type S0_phantom = sig
type elt
type 'a t
(** Checks whether the provided element is there, using equality on [elt]s. *)
val mem : _ t -> elt -> bool
val length : _ t -> int
val is_empty : _ t -> bool
val iter : _ t -> f:(elt -> unit) -> unit
(** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en]
are the elements of [t]. *)
val fold : _ t -> init:'acc -> f:('acc -> elt -> 'acc) -> 'acc
(** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the
[Result] monad. If [f] returns an [Error _], that value is returned without any
additional invocations of [f]. *)
val fold_result
: _ t
-> init:'acc
-> f:('acc -> elt -> ('acc, 'e) Result.t)
-> ('acc, 'e) Result.t
(** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f]
returns [Stop _] the computation ceases and results in that value. If [f] returns
[Continue _], the fold will proceed. If [f] never returns [Stop _], the final result
is computed by [finish].
Example:
{[
type maybe_negative =
| Found_negative of int
| All_nonnegative of { sum : int }
(** [first_neg_or_sum list] returns the first negative number in [list], if any,
otherwise returns the sum of the list. *)
let first_neg_or_sum =
List.fold_until ~init:0
~f:(fun sum x ->
if x < 0
then Stop (Found_negative x)
else Continue (sum + x))
~finish:(fun sum -> All_nonnegative { sum })
;;
let x = first_neg_or_sum [1; 2; 3; 4; 5]
val x : maybe_negative = All_nonnegative {sum = 15}
let y = first_neg_or_sum [1; 2; -3; 4; 5]
val y : maybe_negative = Found_negative -3
]} *)
val fold_until
: _ t
-> init:'acc
-> f:('acc -> elt -> ('acc, 'final) Continue_or_stop.t)
-> finish:('acc -> 'final)
-> 'final
(** Returns [true] if and only if there exists an element for which the provided
function evaluates to [true]. This is a short-circuiting operation. *)
val exists : _ t -> f:(elt -> bool) -> bool
(** Returns [true] if and only if the provided function evaluates to [true] for all
elements. This is a short-circuiting operation. *)
val for_all : _ t -> f:(elt -> bool) -> bool
(** Returns the number of elements for which the provided function evaluates to true. *)
val count : _ t -> f:(elt -> bool) -> int
(** Returns the sum of [f i] for all [i] in the container. The order in which the
elements will be summed is unspecified. *)
val sum : (module Summable with type t = 'sum) -> _ t -> f:(elt -> 'sum) -> 'sum
(** Returns as an [option] the first element for which [f] evaluates to true. *)
val find : _ t -> f:(elt -> bool) -> elt option
(** Returns the first evaluation of [f] that returns [Some], and returns [None] if there
is no such element. *)
val find_map : _ t -> f:(elt -> 'a option) -> 'a option
val to_list : _ t -> elt list
val to_array : _ t -> elt array
(** Returns a min (resp max) element from the collection using the provided [compare]
function, or [None] if the collection is empty. In case of a tie, the first element
encountered while traversing the collection is returned. *)
val min_elt : _ t -> compare:(elt -> elt -> int) -> elt option
val max_elt : _ t -> compare:(elt -> elt -> int) -> elt option
end
(** Signature for polymorphic container, e.g., ['a list] or ['a array]. *)
module type S1 = sig
type 'a t
(** Checks whether the provided element is there, using [equal]. *)
val mem : 'a t -> 'a -> equal:('a -> 'a -> bool) -> bool
val length : 'a t -> int
val is_empty : 'a t -> bool
val iter : 'a t -> f:('a -> unit) -> unit
(** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en]
are the elements of [t] *)
val fold : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc) -> 'acc
(** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the
[Result] monad. If [f] returns an [Error _], that value is returned without any
additional invocations of [f]. *)
val fold_result
: 'a t
-> init:'acc
-> f:('acc -> 'a -> ('acc, 'e) Result.t)
-> ('acc, 'e) Result.t
(** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f]
returns [Stop _] the computation ceases and results in that value. If [f] returns
[Continue _], the fold will proceed. If [f] never returns [Stop _], the final result
is computed by [finish].
Example:
{[
type maybe_negative =
| Found_negative of int
| All_nonnegative of { sum : int }
(** [first_neg_or_sum list] returns the first negative number in [list], if any,
otherwise returns the sum of the list. *)
let first_neg_or_sum =
List.fold_until ~init:0
~f:(fun sum x ->
if x < 0
then Stop (Found_negative x)
else Continue (sum + x))
~finish:(fun sum -> All_nonnegative { sum })
;;
let x = first_neg_or_sum [1; 2; 3; 4; 5]
val x : maybe_negative = All_nonnegative {sum = 15}
let y = first_neg_or_sum [1; 2; -3; 4; 5]
val y : maybe_negative = Found_negative -3
]} *)
val fold_until
: 'a t
-> init:'acc
-> f:('acc -> 'a -> ('acc, 'final) Continue_or_stop.t)
-> finish:('acc -> 'final)
-> 'final
(** Returns [true] if and only if there exists an element for which the provided
function evaluates to [true]. This is a short-circuiting operation. *)
val exists : 'a t -> f:('a -> bool) -> bool
(** Returns [true] if and only if the provided function evaluates to [true] for all
elements. This is a short-circuiting operation. *)
val for_all : 'a t -> f:('a -> bool) -> bool
(** Returns the number of elements for which the provided function evaluates to true. *)
val count : 'a t -> f:('a -> bool) -> int
(** Returns the sum of [f i] for all [i] in the container. *)
val sum : (module Summable with type t = 'sum) -> 'a t -> f:('a -> 'sum) -> 'sum
(** Returns as an [option] the first element for which [f] evaluates to true. *)
val find : 'a t -> f:('a -> bool) -> 'a option
(** Returns the first evaluation of [f] that returns [Some], and returns [None] if there
is no such element. *)
val find_map : 'a t -> f:('a -> 'b option) -> 'b option
val to_list : 'a t -> 'a list
val to_array : 'a t -> 'a array
(** Returns a minimum (resp maximum) element from the collection using the provided
[compare] function, or [None] if the collection is empty. In case of a tie, the first
element encountered while traversing the collection is returned. The implementation
uses [fold] so it has the same complexity as [fold]. *)
val min_elt : 'a t -> compare:('a -> 'a -> int) -> 'a option
val max_elt : 'a t -> compare:('a -> 'a -> int) -> 'a option
end
module type S1_phantom = sig
type ('a, 'phantom) t
(** Checks whether the provided element is there, using [equal]. *)
val mem : ('a, _) t -> 'a -> equal:('a -> 'a -> bool) -> bool
val length : (_, _) t -> int
val is_empty : (_, _) t -> bool
val iter : ('a, _) t -> f:('a -> unit) -> unit
(** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en]
are the elements of [t]. *)
val fold : ('a, _) t -> init:'acc -> f:('acc -> 'a -> 'acc) -> 'acc
(** [fold_result t ~init ~f] is a short-circuiting version of [fold] that runs in the
[Result] monad. If [f] returns an [Error _], that value is returned without any
additional invocations of [f]. *)
val fold_result
: ('a, _) t
-> init:'acc
-> f:('acc -> 'a -> ('acc, 'e) Result.t)
-> ('acc, 'e) Result.t
(** [fold_until t ~init ~f ~finish] is a short-circuiting version of [fold]. If [f]
returns [Stop _] the computation ceases and results in that value. If [f] returns
[Continue _], the fold will proceed. If [f] never returns [Stop _], the final result
is computed by [finish].
Example:
{[
type maybe_negative =
| Found_negative of int
| All_nonnegative of { sum : int }
(** [first_neg_or_sum list] returns the first negative number in [list], if any,
otherwise returns the sum of the list. *)
let first_neg_or_sum =
List.fold_until ~init:0
~f:(fun sum x ->
if x < 0
then Stop (Found_negative x)
else Continue (sum + x))
~finish:(fun sum -> All_nonnegative { sum })
;;
let x = first_neg_or_sum [1; 2; 3; 4; 5]
val x : maybe_negative = All_nonnegative {sum = 15}
let y = first_neg_or_sum [1; 2; -3; 4; 5]
val y : maybe_negative = Found_negative -3
]} *)
val fold_until
: ('a, _) t
-> init:'acc
-> f:('acc -> 'a -> ('acc, 'final) Continue_or_stop.t)
-> finish:('acc -> 'final)
-> 'final
(** Returns [true] if and only if there exists an element for which the provided
function evaluates to [true]. This is a short-circuiting operation. *)
val exists : ('a, _) t -> f:('a -> bool) -> bool
(** Returns [true] if and only if the provided function evaluates to [true] for all
elements. This is a short-circuiting operation. *)
val for_all : ('a, _) t -> f:('a -> bool) -> bool
(** Returns the number of elements for which the provided function evaluates to true. *)
val count : ('a, _) t -> f:('a -> bool) -> int
(** Returns the sum of [f i] for all [i] in the container. *)
val sum : (module Summable with type t = 'sum) -> ('a, _) t -> f:('a -> 'sum) -> 'sum
(** Returns as an [option] the first element for which [f] evaluates to true. *)
val find : ('a, _) t -> f:('a -> bool) -> 'a option
(** Returns the first evaluation of [f] that returns [Some], and returns [None] if there
is no such element. *)
val find_map : ('a, _) t -> f:('a -> 'b option) -> 'b option
val to_list : ('a, _) t -> 'a list
val to_array : ('a, _) t -> 'a array
(** Returns a min (resp max) element from the collection using the provided [compare]
function. In case of a tie, the first element encountered while traversing the
collection is returned. The implementation uses [fold] so it has the same complexity
as [fold]. Returns [None] iff the collection is empty. *)
val min_elt : ('a, _) t -> compare:('a -> 'a -> int) -> 'a option
val max_elt : ('a, _) t -> compare:('a -> 'a -> int) -> 'a option
end
module type Generic = sig
type ('a, 'phantom1, 'phantom2) t
type 'a elt
val length : (_, _, _) t -> int
val is_empty : (_, _, _) t -> bool
val mem : ('a, _, _) t -> 'a elt -> equal:('a elt -> 'a elt -> bool) -> bool
val iter : ('a, _, _) t -> f:('a elt -> unit) -> unit
val fold : ('a, _, _) t -> init:'acc -> f:('acc -> 'a elt -> 'acc) -> 'acc
val fold_result
: ('a, _, _) t
-> init:'acc
-> f:('acc -> 'a elt -> ('acc, 'e) Result.t)
-> ('acc, 'e) Result.t
val fold_until
: ('a, _, _) t
-> init:'acc
-> f:('acc -> 'a elt -> ('acc, 'final) Continue_or_stop.t)
-> finish:('acc -> 'final)
-> 'final
val exists : ('a, _, _) t -> f:('a elt -> bool) -> bool
val for_all : ('a, _, _) t -> f:('a elt -> bool) -> bool
val count : ('a, _, _) t -> f:('a elt -> bool) -> int
val sum
: (module Summable with type t = 'sum)
-> ('a, _, _) t
-> f:('a elt -> 'sum)
-> 'sum
val find : ('a, _, _) t -> f:('a elt -> bool) -> 'a elt option
val find_map : ('a, _, _) t -> f:('a elt -> 'b option) -> 'b option
val to_list : ('a, _, _) t -> 'a elt list
val to_array : ('a, _, _) t -> 'a elt array
val min_elt : ('a, _, _) t -> compare:('a elt -> 'a elt -> int) -> 'a elt option
val max_elt : ('a, _, _) t -> compare:('a elt -> 'a elt -> int) -> 'a elt option
end
module type S0_with_creators = sig
include S0
val of_list : elt list -> t
val of_array : elt array -> t
(** E.g., [append (of_list [a; b]) (of_list [c; d; e])] is [of_list [a; b; c; d; e]] *)
val append : t -> t -> t
(** Concatenates a nested container. The elements of the inner containers are
concatenated together in order to give the result. *)
val concat : t list -> t
(** [map f (of_list [a1; ...; an])] applies [f] to [a1], [a2], ..., [an], in order, and
builds a result equivalent to [of_list [f a1; ...; f an]]. *)
val map : t -> f:(elt -> elt) -> t
(** [filter t ~f] returns all the elements of [t] that satisfy the predicate [f]. *)
val filter : t -> f:(elt -> bool) -> t
(** [filter_map t ~f] applies [f] to every [x] in [t]. The result contains every [y] for
which [f x] returns [Some y]. *)
val filter_map : t -> f:(elt -> elt option) -> t
(** [concat_map t ~f] is equivalent to [concat (map t ~f)]. *)
val concat_map : t -> f:(elt -> t) -> t
(** [partition_tf t ~f] returns a pair [t1, t2], where [t1] is all elements of [t] that
satisfy [f], and [t2] is all elements of [t] that do not satisfy [f]. The "tf"
suffix is mnemonic to remind readers that the result is (trues, falses). *)
val partition_tf : t -> f:(elt -> bool) -> t * t
(** [partition_map t ~f] partitions [t] according to [f]. *)
val partition_map : t -> f:(elt -> (elt, elt) Either0.t) -> t * t
end
module type S1_with_creators = sig
include S1
val of_list : 'a list -> 'a t
val of_array : 'a array -> 'a t
(** E.g., [append (of_list [1; 2]) (of_list [3; 4; 5])] is [of_list [1; 2; 3; 4; 5]] *)
val append : 'a t -> 'a t -> 'a t
(** Concatenates a nested container. The elements of the inner containers are
concatenated together in order to give the result. *)
val concat : 'a t t -> 'a t
(** [map f (of_list [a1; ...; an])] applies [f] to [a1], [a2], ..., [an], in order, and
builds a result equivalent to [of_list [f a1; ...; f an]]. *)
val map : 'a t -> f:('a -> 'b) -> 'b t
(** [filter t ~f] returns all the elements of [t] that satisfy the predicate [f]. *)
val filter : 'a t -> f:('a -> bool) -> 'a t
(** [filter_map t ~f] applies [f] to every [x] in [t]. The result contains every [y] for
which [f x] returns [Some y]. *)
val filter_map : 'a t -> f:('a -> 'b option) -> 'b t
(** [concat_map t ~f] is equivalent to [concat (map t ~f)]. *)
val concat_map : 'a t -> f:('a -> 'b t) -> 'b t
(** [partition_tf t ~f] returns a pair [t1, t2], where [t1] is all elements of [t] that
satisfy [f], and [t2] is all elements of [t] that do not satisfy [f]. The "tf"
suffix is mnemonic to remind readers that the result is (trues, falses). *)
val partition_tf : 'a t -> f:('a -> bool) -> 'a t * 'a t
(** [partition_map t ~f] partitions [t] according to [f]. *)
val partition_map : 'a t -> f:('a -> ('b, 'c) Either0.t) -> 'b t * 'c t
end
module type Generic_with_creators = sig
type (_, _, _) concat
include Generic
val of_list : 'a elt list -> ('a, _, _) t
val of_array : 'a elt array -> ('a, _, _) t
val append : ('a, 'p1, 'p2) t -> ('a, 'p1, 'p2) t -> ('a, 'p1, 'p2) t
val concat : (('a, 'p1, 'p2) t, 'p1, 'p2) concat -> ('a, 'p1, 'p2) t
val map : ('a, 'p1, 'p2) t -> f:('a elt -> 'b elt) -> ('b, 'p1, 'p2) t
val filter : ('a, 'p1, 'p2) t -> f:('a elt -> bool) -> ('a, 'p1, 'p2) t
val filter_map : ('a, 'p1, 'p2) t -> f:('a elt -> 'b elt option) -> ('b, 'p1, 'p2) t
val concat_map : ('a, 'p1, 'p2) t -> f:('a elt -> ('b, 'p1, 'p2) t) -> ('b, 'p1, 'p2) t
val partition_tf
: ('a, 'p1, 'p2) t
-> f:('a elt -> bool)
-> ('a, 'p1, 'p2) t * ('a, 'p1, 'p2) t
val partition_map
: ('a, 'p1, 'p2) t
-> f:('a elt -> ('b elt, 'c elt) Either0.t)
-> ('b, 'p1, 'p2) t * ('c, 'p1, 'p2) t
end
module type Make_gen_arg = sig
type ('a, 'phantom1, 'phantom2) t
type 'a elt
val fold
: ('a, 'phantom1, 'phantom2) t
-> init:'acc
-> f:('acc -> 'a elt -> 'acc)
-> 'acc
(** The [iter] argument to [Container.Make] specifies how to implement the
container's [iter] function. [`Define_using_fold] means to define [iter]
via:
{[
iter t ~f = Container.iter ~fold t ~f
]}
[`Custom] overrides the default implementation, presumably with something more
efficient. Several other functions returned by [Container.Make] are defined in
terms of [iter], so passing in a more efficient [iter] will improve their efficiency
as well. *)
val iter
: [ `Define_using_fold
| `Custom of ('a, 'phantom1, 'phantom2) t -> f:('a elt -> unit) -> unit
]
(** The [length] argument to [Container.Make] specifies how to implement the
container's [length] function. [`Define_using_fold] means to define
[length] via:
{[
length t ~f = Container.length ~fold t ~f
]}
[`Custom] overrides the default implementation, presumably with something more
efficient. Several other functions returned by [Container.Make] are defined in
terms of [length], so passing in a more efficient [length] will improve their
efficiency as well. *)
val length : [ `Define_using_fold | `Custom of ('a, 'phantom1, 'phantom2) t -> int ]
end
module type Make_arg = sig
type 'a t
include Make_gen_arg with type ('a, _, _) t := 'a t and type 'a elt := 'a
end
module type Make0_arg = sig
module Elt : sig
type t
val equal : t -> t -> bool
end
type t
include Make_gen_arg with type ('a, _, _) t := t and type 'a elt := Elt.t
end
module type Make_common_with_creators_arg = sig
include Make_gen_arg
type (_, _, _) concat
val of_list : 'a elt list -> ('a, _, _) t
val of_array : 'a elt array -> ('a, _, _) t
val concat : (('a, _, _) t, _, _) concat -> ('a, _, _) t
end
module type Make_gen_with_creators_arg = sig
include Make_common_with_creators_arg
val concat_of_array : 'a array -> ('a, _, _) concat
end
module type Make_with_creators_arg = sig
type 'a t
include
Make_common_with_creators_arg
with type ('a, _, _) t := 'a t
and type 'a elt := 'a
and type ('a, _, _) concat := 'a t
end
module type Make0_with_creators_arg = sig
module Elt : sig
type t
val equal : t -> t -> bool
end
type t
include
Make_common_with_creators_arg
with type ('a, _, _) t := t
and type 'a elt := Elt.t
and type ('a, _, _) concat := 'a list
end
module type Derived = sig
(** Generic definitions of container operations in terms of [fold].
E.g.: [iter ~fold t ~f = fold t ~init:() ~f:(fun () a -> f a)]. *)
type ('t, 'a, 'acc) fold = 't -> init:'acc -> f:('acc -> 'a -> 'acc) -> 'acc
type ('t, 'a) iter = 't -> f:('a -> unit) -> unit
type 't length = 't -> int
val iter : fold:('t, 'a, unit) fold -> ('t, 'a) iter
val count : fold:('t, 'a, int) fold -> 't -> f:('a -> bool) -> int
val min_elt
: fold:('t, 'a, 'a option) fold
-> 't
-> compare:('a -> 'a -> int)
-> 'a option
val max_elt
: fold:('t, 'a, 'a option) fold
-> 't
-> compare:('a -> 'a -> int)
-> 'a option
val length : fold:('t, _, int) fold -> 't -> int
val to_list : fold:('t, 'a, 'a list) fold -> 't -> 'a list
val sum
: fold:('t, 'a, 'sum) fold
-> (module Summable with type t = 'sum)
-> 't
-> f:('a -> 'sum)
-> 'sum
val fold_result
: fold:('t, 'a, 'acc) fold
-> init:'acc
-> f:('acc -> 'a -> ('acc, 'e) Result.t)
-> 't
-> ('acc, 'e) Result.t
val fold_until
: fold:('t, 'a, 'acc) fold
-> init:'acc
-> f:('acc -> 'a -> ('acc, 'final) Continue_or_stop.t)
-> finish:('acc -> 'final)
-> 't
-> 'final
(** Generic definitions of container operations in terms of [iter] and [length]. *)
val is_empty : iter:('t, 'a) iter -> 't -> bool
val mem : iter:('t, 'a) iter -> 't -> 'a -> equal:('a -> 'a -> bool) -> bool
val exists : iter:('t, 'a) iter -> 't -> f:('a -> bool) -> bool
val for_all : iter:('t, 'a) iter -> 't -> f:('a -> bool) -> bool
val find : iter:('t, 'a) iter -> 't -> f:('a -> bool) -> 'a option
val find_map : iter:('t, 'a) iter -> 't -> f:('a -> 'b option) -> 'b option
val to_array : length:'t length -> iter:('t, 'a) iter -> 't -> 'a array
end
module type Container = sig
include module type of struct
include Export
end
module type S0 = S0
module type S0_phantom = S0_phantom
module type S0_with_creators = S0_with_creators
module type S1 = S1
module type S1_phantom = S1_phantom
module type S1_with_creators = S1_with_creators
module type Derived = Derived
module type Generic = Generic
module type Generic_with_creators = Generic_with_creators
module type Summable = Summable
include Derived
(** The idiom for using [Container.Make] is to bind the resulting module and to
explicitly import each of the functions that one wants:
{[
module C = Container.Make (struct ... end)
let count = C.count
let exists = C.exists
let find = C.find
(* ... *)
]}
This is preferable to:
{[
include Container.Make (struct ... end)
]}
because the [include] makes it too easy to shadow specialized implementations of
container functions ([length] being a common one).
[Container.Make0] is like [Container.Make], but for monomorphic containers like
[string]. *)
module Make (T : Make_arg) : S1 with type 'a t := 'a T.t
module Make0 (T : Make0_arg) : S0 with type t := T.t and type elt := T.Elt.t
module Make_gen (T : Make_gen_arg) :
Generic
with type ('a, 'phantom1, 'phantom2) t := ('a, 'phantom1, 'phantom2) T.t
and type 'a elt := 'a T.elt
module Make_with_creators (T : Make_with_creators_arg) :
S1_with_creators with type 'a t := 'a T.t
module Make0_with_creators (T : Make0_with_creators_arg) :
S0_with_creators with type t := T.t and type elt := T.Elt.t
module Make_gen_with_creators (T : Make_gen_with_creators_arg) :
Generic_with_creators
with type ('a, 'phantom1, 'phantom2) t := ('a, 'phantom1, 'phantom2) T.t
and type 'a elt := 'a T.elt
and type ('a, 'phantom1, 'phantom2) concat := ('a, 'phantom1, 'phantom2) T.concat
end

1
unikernel/duniverse/base/src/dictionary_immutable.ml Normal file
View file

@ -0,0 +1 @@
include Dictionary_immutable_intf.Definitions

1
unikernel/duniverse/base/src/dictionary_immutable.mli Normal file
View file

@ -0,0 +1 @@
include Dictionary_immutable_intf.Dictionary_immutable (** @inline *)

711
unikernel/duniverse/base/src/dictionary_immutable_intf.ml Normal file
View file

@ -0,0 +1,711 @@
(** Interfaces for immutable dictionary types, such as [Map.t].
We define separate interfaces for [Accessors] and [Creators], along with [S] combining
both. These interfaces are written once in their most general form, which involves
extra type definitions and type parameters that most instances do not need.
We then provide instantiations of these interfaces with 1, 2, and 3 type parameters
for [t]. These cover more common usage patterns for the interfaces. *)
open! Import
(** These definitions are re-exported by [Dictionary_immutable]. *)
module Definitions = struct
module type Accessors = sig
(** The type of keys. This will be ['key] for polymorphic dictionaries, or some fixed
type for dictionaries with monomorphic keys. *)
type 'key key
(** Dictionaries. Their keys have type ['key key]. Each key's associated value has
type ['data]. The dictionary may be distinguished by a ['phantom] type. *)
type ('key, 'data, 'phantom) t
(** The type of accessor functions ['fn] that operate on [('key, 'data, 'phantom) t].
May take extra arguments before ['fn], such as a comparison function. *)
type ('fn, 'key, 'data, 'phantom) accessor
(** Whether the dictionary is empty. *)
val is_empty : (_, _, _) t -> bool
(** How many key/value pairs the dictionary contains. *)
val length : (_, _, _) t -> int
(** All key/value pairs. *)
val to_alist : ('key, 'data, _) t -> ('key key * 'data) list
(** All keys in the dictionary, in the same order as [to_alist]. *)
val keys : ('key, _, _) t -> 'key key list
(** All values in the dictionary, in the same order as [to_alist]. *)
val data : (_, 'data, _) t -> 'data list
(** Like [to_alist]. Produces a sequence. *)
val to_sequence : ('key, 'data, 'phantom) t -> ('key key * 'data) Sequence.t
(** Whether [key] has a value. *)
val mem : (('key, _, 'phantom) t -> 'key key -> bool, 'key, 'data, 'phantom) accessor
(** Produces the current value, or absence thereof, for a given key. *)
val find
: ( ('key, 'data, 'phantom) t -> 'key key -> 'data option
, 'key
, 'data
, 'phantom )
accessor
(** Like [find]. Raises if there is no value for the given key. *)
val find_exn
: (('key, 'data, 'phantom) t -> 'key key -> 'data, 'key, 'data, 'phantom) accessor
(** Adds a key/value pair for a key the dictionary does not contain, or reports a
duplicate. *)
val add
: ( ('key, 'data, 'phantom) t
-> key:'key key
-> data:'data
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate ]
, 'key
, 'data
, 'phantom )
accessor
(** Like [add]. Raises on duplicates. *)
val add_exn
: ( ('key, 'data, 'phantom) t
-> key:'key key
-> data:'data
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Adds or replaces a key/value pair in the dictionary. *)
val set
: ( ('key, 'data, 'phantom) t
-> key:'key key
-> data:'data
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Removes any value for the given key. *)
val remove
: ( ('key, 'data, 'phantom) t -> 'key key -> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Adds, replaces, or removes the value for a given key, depending on its current
value or lack thereof. *)
val change
: ( ('key, 'data, 'phantom) t
-> 'key key
-> f:('data option -> 'data option)
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Adds or replaces the value for a given key, depending on its current value or
lack thereof. *)
val update
: ( ('key, 'data, 'phantom) t
-> 'key key
-> f:('data option -> 'data)
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Adds [data] to the existing key/value pair for [key]. Interprets a missing key as
having an empty list. *)
val add_multi
: ( ('key, 'data list, 'phantom) t
-> key:'key key
-> data:'data
-> ('key, 'data list, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Removes one element from the existing key/value pair for [key]. Removes the key
entirely if the new list is empty. *)
val remove_multi
: ( ('key, 'data list, 'phantom) t -> 'key key -> ('key, 'data list, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Produces the list associated with the corresponding key. Interprets a missing
key as having an empty list. *)
val find_multi
: ( ('key, 'data list, 'phantom) t -> 'key key -> 'data list
, 'key
, 'data
, 'phantom )
accessor
(** Combines every value in the dictionary. *)
val fold
: ('key, 'data, _) t
-> init:'acc
-> f:(key:'key key -> data:'data -> 'acc -> 'acc)
-> 'acc
(** Like [fold]. May stop before completing the iteration. *)
val fold_until
: ('key, 'data, _) t
-> init:'acc
-> f:
(key:'key key
-> data:'data
-> 'acc
-> ('acc, 'final) Container.Continue_or_stop.t)
-> finish:('acc -> 'final)
-> 'final
(** Whether every value satisfies [f]. *)
val for_all : ('key, 'data, _) t -> f:('data -> bool) -> bool
(** Like [for_all]. The predicate may also depend on the associated key. *)
val for_alli : ('key, 'data, _) t -> f:(key:'key key -> data:'data -> bool) -> bool
(** Whether at least one value satisfies [f]. *)
val exists : ('key, 'data, _) t -> f:('data -> bool) -> bool
(** Like [exists]. The predicate may also depend on the associated key. *)
val existsi : ('key, 'data, _) t -> f:(key:'key key -> data:'data -> bool) -> bool
(** How many values satisfy [f]. *)
val count : ('key, 'data, _) t -> f:('data -> bool) -> int
(** Like [count]. The predicate may also depend on the associated key. *)
val counti : ('key, 'data, _) t -> f:(key:'key key -> data:'data -> bool) -> int
(** Sum up [f data] for all data in the dictionary. *)
val sum
: (module Container.Summable with type t = 'a)
-> ('key, 'data, _) t
-> f:('data -> 'a)
-> 'a
(** Like [sum]. The function may also depend on the associated key. *)
val sumi
: (module Container.Summable with type t = 'a)
-> ('key, 'data, _) t
-> f:(key:'key -> data:'data -> 'a)
-> 'a
(** Produces the key/value pair with the smallest key if non-empty. *)
val min_elt : ('key, 'data, _) t -> ('key key * 'data) option
(** Like [min_elt]. Raises if empty. *)
val min_elt_exn : ('key, 'data, _) t -> 'key key * 'data
(** Produces the key/value pair with the largest key if non-empty. *)
val max_elt : ('key, 'data, _) t -> ('key key * 'data) option
(** Like [max_elt]. Raises if empty. *)
val max_elt_exn : ('key, 'data, _) t -> 'key key * 'data
(** Calls [f] for every key. *)
val iter_keys : ('key, _, _) t -> f:('key key -> unit) -> unit
(** Calls [f] for every value. *)
val iter : (_, 'data, _) t -> f:('data -> unit) -> unit
(** Calls [f] for every key/value pair. *)
val iteri : ('key, 'data, _) t -> f:(key:'key key -> data:'data -> unit) -> unit
(** Transforms every value. *)
val map
: ('key, 'data1, 'phantom) t
-> f:('data1 -> 'data2)
-> ('key, 'data2, 'phantom) t
(** Like [map]. The transformation may also depend on the associated key. *)
val mapi
: ('key, 'data1, 'phantom) t
-> f:(key:'key key -> data:'data1 -> 'data2)
-> ('key, 'data2, 'phantom) t
(** Produces only those key/value pairs whose key satisfies [f]. *)
val filter_keys
: ('key, 'data, 'phantom) t
-> f:('key key -> bool)
-> ('key, 'data, 'phantom) t
(** Produces only those key/value pairs whose value satisfies [f]. *)
val filter
: ('key, 'data, 'phantom) t
-> f:('data -> bool)
-> ('key, 'data, 'phantom) t
(** Produces only those key/value pairs which satisfy [f]. *)
val filteri
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> bool)
-> ('key, 'data, 'phantom) t
(** Produces key/value pairs for which [f] produces [Some]. *)
val filter_map
: ('key, 'data1, 'phantom) t
-> f:('data1 -> 'data2 option)
-> ('key, 'data2, 'phantom) t
(** Like [filter_map]. The new value may also depend on the associated key. *)
val filter_mapi
: ('key, 'data1, 'phantom) t
-> f:(key:'key key -> data:'data1 -> 'data2 option)
-> ('key, 'data2, 'phantom) t
(** Splits one dictionary into two. The first contains key/value pairs for which the
value satisfies [f]. The second contains the remainder. *)
val partition_tf
: ('key, 'data, 'phantom) t
-> f:('data -> bool)
-> ('key, 'data, 'phantom) t * ('key, 'data, 'phantom) t
(** Like [partition_tf]. The predicate may also depend on the associated key. *)
val partitioni_tf
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> bool)
-> ('key, 'data, 'phantom) t * ('key, 'data, 'phantom) t
(** Splits one dictionary into two, corresponding respectively to [First _] and
[Second _] results from [f]. *)
val partition_map
: ('key, 'data1, 'phantom) t
-> f:('data1 -> ('data2, 'data3) Either.t)
-> ('key, 'data2, 'phantom) t * ('key, 'data3, 'phantom) t
(** Like [partition_map]. The split may also depend on the associated key. *)
val partition_mapi
: ('key, 'data1, 'phantom) t
-> f:(key:'key key -> data:'data1 -> ('data2, 'data3) Either.t)
-> ('key, 'data2, 'phantom) t * ('key, 'data3, 'phantom) t
(** Produces an error combining all error messages from key/value pairs, or a
dictionary of all [Ok] values if none are [Error]. *)
val combine_errors
: ( ('key, 'data Or_error.t, 'phantom) t -> ('key, 'data, 'phantom) t Or_error.t
, 'key
, 'data
, 'phantom )
accessor
(** Splits the [fst] and [snd] components of values associated with keys into separate
dictionaries. *)
val unzip
: ('key, 'data1 * 'data2, 'phantom) t
-> ('key, 'data1, 'phantom) t * ('key, 'data2, 'phantom) t
(** Merges two dictionaries by fully traversing both. Not suitable for efficiently
merging lists of dictionaries. See [merge_disjoint_exn] and [merge_skewed]
instead. *)
val merge
: ( ('key, 'data1, 'phantom) t
-> ('key, 'data2, 'phantom) t
-> f:
(key:'key key
-> [ `Left of 'data1 | `Right of 'data2 | `Both of 'data1 * 'data2 ]
-> 'data3 option)
-> ('key, 'data3, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Merges two dictionaries with the same type of data and disjoint sets of keys.
Raises if any keys overlap. *)
val merge_disjoint_exn
: ( ('key, 'data, 'phantom) t
-> ('key, 'data, 'phantom) t
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Merges two dictionaries by traversing only the smaller of the two. Adds key/value
pairs missing from the larger dictionary, and [combine]s duplicate values. *)
val merge_skewed
: ( ('key, 'data, 'phantom) t
-> ('key, 'data, 'phantom) t
-> combine:(key:'key key -> 'data -> 'data -> 'data)
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
accessor
(** Computes a sequence of differences between two dictionaries. *)
val symmetric_diff
: ( ('key, 'data, 'phantom) t
-> ('key, 'data, 'phantom) t
-> data_equal:('data -> 'data -> bool)
-> ('key key * [ `Left of 'data | `Right of 'data | `Unequal of 'data * 'data ])
Sequence.t
, 'key
, 'data
, 'phantom )
accessor
(** Folds over the result of [symmetric_diff]. May be more performant. *)
val fold_symmetric_diff
: ( ('key, 'data, 'phantom) t
-> ('key, 'data, 'phantom) t
-> data_equal:('data -> 'data -> bool)
-> init:'acc
-> f:
('acc
-> 'key key
* [ `Left of 'data | `Right of 'data | `Unequal of 'data * 'data ]
-> 'acc)
-> 'acc
, 'key
, 'data
, 'phantom )
accessor
end
module type Accessors1 = sig
type key
type 'data t
(** @inline *)
include
Accessors
with type (_, 'data, _) t := 'data t
and type _ key := key
and type ('fn, _, _, _) accessor := 'fn
end
module type Accessors2 = sig
type ('key, 'data) t
type ('fn, 'key, 'data) accessor
(** @inline *)
include
Accessors
with type ('key, 'data, _) t := ('key, 'data) t
and type 'key key := 'key
and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor
end
module type Accessors3 = sig
type ('key, 'data, 'phantom) t
type ('fn, 'key, 'data, 'phantom) accessor
(** @inline *)
include
Accessors
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key
and type ('fn, 'key, 'data, 'phantom) accessor :=
('fn, 'key, 'data, 'phantom) accessor
end
module type Creators = sig
(** The type of keys. This will be ['key] for polymorphic dictionaries, or some fixed
type for dictionaries with monomorphic keys. *)
type 'key key
(** Dictionaries. Their keys have type ['key key]. Each key's associated value has
type ['data]. The dictionary may be distinguished by a ['phantom] type. *)
type ('key, 'data, 'phantom) t
(** The type of creator functions ['fn] that operate on [('key, 'data, 'phantom) t].
May take extra arguments before ['fn], such as a comparison function. *)
type ('fn, 'key, 'data, 'phantom) creator
(** The empty dictionary. *)
val empty : (('key, 'data, 'phantom) t, 'key, 'data, 'phantom) creator
(** Dictionary with a single key/value pair. *)
val singleton
: ('key key -> 'data -> ('key, 'data, 'phantom) t, 'key, 'data, 'phantom) creator
(** Dictionary containing the given key/value pairs. Fails if there are duplicate
keys. *)
val of_alist
: ( ('key key * 'data) list
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ]
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist]. Returns a [Result.t]. *)
val of_alist_or_error
: ( ('key key * 'data) list -> ('key, 'data, 'phantom) t Or_error.t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist]. Raises on duplicates. *)
val of_alist_exn
: ( ('key key * 'data) list -> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Produces a dictionary mapping each key to a list of associated values. *)
val of_alist_multi
: ( ('key key * 'data) list -> ('key, 'data list, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Produces a dictionary using each key/value pair. Combines all values for a given
key with [init] using [f]. *)
val of_alist_fold
: ( ('key key * 'data) list
-> init:'acc
-> f:('acc -> 'data -> 'acc)
-> ('key, 'acc, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Produces a dictionary using each key/value pair. Combines multiple values for a
given key using [f]. *)
val of_alist_reduce
: ( ('key key * 'data) list
-> f:('data -> 'data -> 'data)
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist]. Consumes a sequence. *)
val of_sequence
: ( ('key key * 'data) Sequence.t
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ]
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_or_error]. Consumes a sequence. *)
val of_sequence_or_error
: ( ('key key * 'data) Sequence.t -> ('key, 'data, 'phantom) t Or_error.t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_exn]. Consumes a sequence. *)
val of_sequence_exn
: ( ('key key * 'data) Sequence.t -> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_multi]. Consumes a sequence. *)
val of_sequence_multi
: ( ('key key * 'data) Sequence.t -> ('key, 'data list, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_fold]. Consumes a sequence. *)
val of_sequence_fold
: ( ('key key * 'data) Sequence.t
-> init:'c
-> f:('c -> 'data -> 'c)
-> ('key, 'c, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_reduce]. Consumes a sequence. *)
val of_sequence_reduce
: ( ('key key * 'data) Sequence.t
-> f:('data -> 'data -> 'data)
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist]. Consume values for which keys can be computed. *)
val of_list_with_key
: ( 'data list
-> get_key:('data -> 'key key)
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ]
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_or_error]. Consume values for which keys can be computed. *)
val of_list_with_key_or_error
: ( 'data list -> get_key:('data -> 'key key) -> ('key, 'data, 'phantom) t Or_error.t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_exn]. Consume values for which keys can be computed. *)
val of_list_with_key_exn
: ( 'data list -> get_key:('data -> 'key key) -> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_multi]. Consume values for which keys can be computed. *)
val of_list_with_key_multi
: ( 'data list -> get_key:('data -> 'key key) -> ('key, 'data list, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Produces a dictionary of all key/value pairs that [iteri] passes to [~f]. Fails if
a duplicate key is found. *)
val of_iteri
: ( iteri:(f:(key:'key key -> data:'data -> unit) -> unit)
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ]
, 'key
, 'data
, 'phantom )
creator
(** Like [of_iteri]. Raises on duplicate key. *)
val of_iteri_exn
: ( iteri:(f:(key:'key key -> data:'data -> unit) -> unit)
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
end
module type Creators1 = sig
type key
type 'data t
(** @inline *)
include
Creators
with type (_, 'data, _) t := 'data t
and type _ key := key
and type ('fn, _, _, _) creator := 'fn
end
module type Creators2 = sig
type ('key, 'data) t
type ('fn, 'key, 'data) creator
(** @inline *)
include
Creators
with type ('key, 'data, _) t := ('key, 'data) t
and type 'key key := 'key
and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator
end
module type Creators3 = sig
type ('key, 'data, 'phantom) t
type ('fn, 'key, 'data, 'phantom) creator
(** @inline *)
include
Creators
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key
and type ('fn, 'key, 'data, 'phantom) creator :=
('fn, 'key, 'data, 'phantom) creator
end
module type S = sig
type 'key key
type ('key, 'data, 'phantom) t
type ('fn, 'key, 'data, 'phantom) accessor
type ('fn, 'key, 'data, 'phantom) creator
(** @inline *)
include
Accessors
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key key
and type ('fn, 'key, 'data, 'phantom) accessor :=
('fn, 'key, 'data, 'phantom) accessor
(** @inline *)
include
Creators
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key key
and type ('fn, 'key, 'data, 'phantom) creator :=
('fn, 'key, 'data, 'phantom) creator
end
module type S1 = sig
type key
type 'data t
(** @inline *)
include
S
with type (_, 'data, _) t := 'data t
and type _ key := key
and type ('fn, _, _, _) accessor := 'fn
and type ('fn, _, _, _) creator := 'fn
end
module type S2 = sig
type ('key, 'data) t
type ('fn, 'key, 'data) accessor
type ('fn, 'key, 'data) creator
(** @inline *)
include
S
with type ('key, 'data, _) t := ('key, 'data) t
and type 'key key := 'key
and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor
and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator
end
module type S3 = sig
type ('key, 'data, 'phantom) t
type ('fn, 'key, 'data, 'phantom) accessor
type ('fn, 'key, 'data, 'phantom) creator
(** @inline *)
include
S
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key
and type ('fn, 'key, 'data, 'phantom) accessor :=
('fn, 'key, 'data, 'phantom) accessor
and type ('fn, 'key, 'data, 'phantom) creator :=
('fn, 'key, 'data, 'phantom) creator
end
end
module type Dictionary_immutable = sig
(** @inline *)
include module type of struct
include Definitions (** @inline *)
end
end

1
unikernel/duniverse/base/src/dictionary_mutable.ml Normal file
View file

@ -0,0 +1 @@
include Dictionary_mutable_intf.Definitions

1
unikernel/duniverse/base/src/dictionary_mutable.mli Normal file
View file

@ -0,0 +1 @@
include Dictionary_mutable_intf.Dictionary_mutable

666
unikernel/duniverse/base/src/dictionary_mutable_intf.ml Normal file
View file

@ -0,0 +1,666 @@
(** Interfaces for mutable dictionary types, such as [Hashtbl.t].
We define separate interfaces for [Accessors] and [Creators], along with [S] combining
both. These interfaces are written once in their most general form, which involves
extra type definitions and type parameters that most instances do not need.
We then provide instantiations of these interfaces with 1, 2, and 3 type parameters
for [t]. These cover more common usage patterns for the interfaces. *)
open! Import
(** These definitions are re-exported by [Dictionary_mutable]. *)
module Definitions = struct
(** @canonical Base.Dictionary_mutable.Merge_into_action *)
module Merge_into_action = struct
type 'data t =
| Remove
| Set_to of 'data
end
module type Accessors = sig
(** The type of keys. This will be ['key] for polymorphic dictionaries, or some fixed
type for dictionaries with monomorphic keys. *)
type 'key key
(** Dictionaries. Their keys have type ['key key]. Each key's associated value has
type ['data]. The dictionary may be distinguished by a ['phantom] type. *)
type ('key, 'data, 'phantom) t
(** The type of accessor functions ['fn] that operate on [('key, 'data, 'phantom) t].
May take extra arguments before ['fn], such as a comparison function. *)
type ('fn, 'key, 'data, 'phantom) accessor
(** Whether the dictionary is empty. *)
val is_empty : (_, _, 'phantom) t -> bool
(** How many key/value pairs the dictionary contains. *)
val length : (_, _, 'phantom) t -> int
(** All key/value pairs. *)
val to_alist : ('key, 'data, 'phantom) t -> ('key key * 'data) list
(** All keys in the dictionary, in the same order as [to_alist]. *)
val keys : ('key, _, 'phantom) t -> 'key key list
(** All values in the dictionary, in the same order as [to_alist]. *)
val data : (_, 'data, 'phantom) t -> 'data list
(** Removes all key/value pairs from the dictionary. *)
val clear : (_, _, 'phantom) t -> unit
(** A new dictionary containing the same key/value pairs. *)
val copy : ('key, 'data, 'phantom) t -> ('key, 'data, 'phantom) t
(** Whether [key] has a value. *)
val mem
: (('key, 'data, 'phantom) t -> 'key key -> bool, 'key, 'data, 'phantom) accessor
(** Produces the current value, or absence thereof, for a given key. *)
val find
: ( ('key, 'data, 'phantom) t -> 'key key -> 'data option
, 'key
, 'data
, 'phantom )
accessor
(** Like [find]. Raises if there is no value for the given key. *)
val find_exn
: (('key, 'data, 'phantom) t -> 'key key -> 'data, 'key, 'data, 'phantom) accessor
(** Like [find]. Adds the value [default ()] if none exists, then returns it. *)
val find_or_add
: ( ('key, 'data, 'phantom) t -> 'key key -> default:(unit -> 'data) -> 'data
, 'key
, 'data
, 'phantom )
accessor
(** Like [find]. Adds [default key] if no value exists. *)
val findi_or_add
: ( ('key, 'data, 'phantom) t -> 'key key -> default:('key key -> 'data) -> 'data
, 'key
, 'data
, 'phantom )
accessor
(** Like [find]. Calls [if_found data] if a value exists, or [if_not_found key]
otherwise. Avoids allocation [Some]. *)
val find_and_call
: ( ('key, 'data, 'phantom) t
-> 'key key
-> if_found:('data -> 'c)
-> if_not_found:('key key -> 'c)
-> 'c
, 'key
, 'data
, 'phantom )
accessor
(** Like [findi]. Calls [if_found ~key ~data] if a value exists. *)
val findi_and_call
: ( ('key, 'data, 'phantom) t
-> 'key key
-> if_found:(key:'key key -> data:'data -> 'c)
-> if_not_found:('key key -> 'c)
-> 'c
, 'key
, 'data
, 'phantom )
accessor
(** Like [find]. Removes the value for [key], if any, from the dictionary before
returning it. *)
val find_and_remove
: ( ('key, 'data, 'phantom) t -> 'key key -> 'data option
, 'key
, 'data
, 'phantom )
accessor
(** Adds a key/value pair for a key the dictionary does not contain, or reports a
duplicate. *)
val add
: ( ('key, 'data, 'phantom) t -> key:'key key -> data:'data -> [ `Ok | `Duplicate ]
, 'key
, 'data
, 'phantom )
accessor
(** Like [add]. Raises on duplicates. *)
val add_exn
: ( ('key, 'data, 'phantom) t -> key:'key key -> data:'data -> unit
, 'key
, 'data
, 'phantom )
accessor
(** Adds or replaces a key/value pair in the dictionary. *)
val set
: ( ('key, 'data, 'phantom) t -> key:'key key -> data:'data -> unit
, 'key
, 'data
, 'phantom )
accessor
(** Removes any value for the given key. *)
val remove
: (('key, 'data, 'phantom) t -> 'key key -> unit, 'key, 'data, 'phantom) accessor
(** Adds, replaces, or removes the value for a given key, depending on its current
value or lack thereof. *)
val change
: ( ('key, 'data, 'phantom) t -> 'key key -> f:('data option -> 'data option) -> unit
, 'key
, 'data
, 'phantom )
accessor
(** Adds or replaces the value for a given key, depending on its current value or
lack thereof. *)
val update
: ( ('key, 'data, 'phantom) t -> 'key key -> f:('data option -> 'data) -> unit
, 'key
, 'data
, 'phantom )
accessor
(** Like [update]. Returns the new value. *)
val update_and_return
: ('key, 'data, 'phantom) t
-> 'key key
-> f:('data option -> 'data)
-> 'data
(** Adds [by] to the value for [key], default 0 if [key] is absent. May remove [key]
if the result is [0], depending on [remove_if_zero]. *)
val incr
: ( ?by:int (** default: 1 *)
-> ?remove_if_zero:bool (** default: false *)
-> ('key, int, 'phantom) t
-> 'key key
-> unit
, 'key
, 'data
, 'phantom )
accessor
(** Subtracts [by] from the value for [key], default 0 if [key] is absent. May remove
[key] if the result is [0], depending on [remove_if_zero]. *)
val decr
: ( ?by:int (** default: 1 *)
-> ?remove_if_zero:bool (** default: false *)
-> ('key, int, 'phantom) t
-> 'key key
-> unit
, 'key
, 'data
, 'phantom )
accessor
(** Adds [data] to the existing key/value pair for [key]. Interprets a missing key as
having an empty list. *)
val add_multi
: ( ('key, 'data list, 'phantom) t -> key:'key key -> data:'data -> unit
, 'key
, 'data
, 'phantom )
accessor
(** Removes one element from the existing key/value pair for [key]. Removes the key
entirely if the new list is empty. *)
val remove_multi
: (('key, _ list, 'phantom) t -> 'key key -> unit, 'key, 'data, 'phantom) accessor
(** Produces the list associated with the corresponding key. Interprets a missing
key as having an empty list. *)
val find_multi
: ( ('key, 'data list, 'phantom) t -> 'key key -> 'data list
, 'key
, 'data
, 'phantom )
accessor
(** Combines every value in the dictionary. *)
val fold
: ('key, 'data, 'phantom) t
-> init:'acc
-> f:(key:'key key -> data:'data -> 'acc -> 'acc)
-> 'acc
(** Whether every value satisfies [f]. *)
val for_all : (_, 'data, 'phantom) t -> f:('data -> bool) -> bool
(** Like [for_all]. The predicate may also depend on the associated key. *)
val for_alli
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> bool)
-> bool
(** Whether at least one value satisfies [f]. *)
val exists : (_, 'data, 'phantom) t -> f:('data -> bool) -> bool
(** Like [exists]. The predicate may also depend on the associated key. *)
val existsi
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> bool)
-> bool
(** How many values satisfy [f]. *)
val count : (_, 'data, 'phantom) t -> f:('data -> bool) -> int
(** Like [count]. The predicate may also depend on the associated key. *)
val counti
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> bool)
-> int
(** Arbitrary, deterministic key/value pair if non-empty. *)
val choose : ('key, 'data, 'phantom) t -> ('key key * 'data) option
(** Like [choose]. Raises if empty. *)
val choose_exn : ('key, 'data, 'phantom) t -> 'key key * 'data
(** Arbitrary, pseudo-random key/value pair if non-empty. *)
val choose_randomly
: ?random_state:Random.State.t
-> ('key, 'data, 'phantom) t
-> ('key key * 'data) option
(** Like [choose_randomly]. Raises if empty. *)
val choose_randomly_exn
: ?random_state:Random.State.t
-> ('key, 'data, 'phantom) t
-> 'key key * 'data
(** Calls [f] for every key. *)
val iter_keys : ('key, _, 'phantom) t -> f:('key key -> unit) -> unit
(** Calls [f] for every value. *)
val iter : (_, 'data, 'phantom) t -> f:('data -> unit) -> unit
(** Calls [f] for every key/value pair. *)
val iteri
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> unit)
-> unit
(** Transforms every value. *)
val map : ('key, 'data, 'phantom) t -> f:('data -> 'c) -> ('key, 'c, 'phantom) t
(** Like [map]. The transformation may also depend on the associated key. *)
val mapi
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> 'c)
-> ('key, 'c, 'phantom) t
(** Like [map]. Modifies the input. *)
val map_inplace : (_, 'data, 'phantom) t -> f:('data -> 'data) -> unit
(** Like [mapi]. Modifies the input. *)
val mapi_inplace
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> 'data)
-> unit
(** Produces only those key/value pairs whose key satisfies [f]. *)
val filter_keys
: ('key, 'data, 'phantom) t
-> f:('key key -> bool)
-> ('key, 'data, 'phantom) t
(** Produces only those key/value pairs whose value satisfies [f]. *)
val filter
: ('key, 'data, 'phantom) t
-> f:('data -> bool)
-> ('key, 'data, 'phantom) t
(** Produces only those key/value pairs which satisfy [f]. *)
val filteri
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> bool)
-> ('key, 'data, 'phantom) t
(** Like [filter_keys]. Modifies the input. *)
val filter_keys_inplace : ('key, _, 'phantom) t -> f:('key key -> bool) -> unit
(** Like [filter]. Modifies the input. *)
val filter_inplace : (_, 'data, 'phantom) t -> f:('data -> bool) -> unit
(** Like [filteri]. Modifies the input. *)
val filteri_inplace
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> bool)
-> unit
(** Produces key/value pairs for which [f] produces [Some]. *)
val filter_map
: ('key, 'data, 'phantom) t
-> f:('data -> 'c option)
-> ('key, 'c, 'phantom) t
(** Like [filter_map]. The new value may also depend on the associated key. *)
val filter_mapi
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> 'c option)
-> ('key, 'c, 'phantom) t
(** Like [filter_map]. Modifies the input. *)
val filter_map_inplace : (_, 'data, 'phantom) t -> f:('data -> 'data option) -> unit
(** Like [filter_mapi]. Modifies the input. *)
val filter_mapi_inplace
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> 'data option)
-> unit
(** Splits one dictionary into two. The first contains key/value pairs for which the
value satisfies [f]. The second contains the remainder. *)
val partition_tf
: ('key, 'data, 'phantom) t
-> f:('data -> bool)
-> ('key, 'data, 'phantom) t * ('key, 'data, 'phantom) t
(** Like [partition_tf]. The predicate may also depend on the associated key. *)
val partitioni_tf
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> bool)
-> ('key, 'data, 'phantom) t * ('key, 'data, 'phantom) t
(** Splits one dictionary into two, corresponding respectively to [First _] and
[Second _] results from [f]. *)
val partition_map
: ('key, 'data, 'phantom) t
-> f:('data -> ('c, 'd) Either.t)
-> ('key, 'c, 'phantom) t * ('key, 'd, 'phantom) t
(** Like [partition_map]. The split may also depend on the associated key. *)
val partition_mapi
: ('key, 'data, 'phantom) t
-> f:(key:'key key -> data:'data -> ('c, 'd) Either.t)
-> ('key, 'c, 'phantom) t * ('key, 'd, 'phantom) t
(** Merges two dictionaries by fully traversing both. Not suitable for efficiently
merging lists of dictionaries. See [merge_into] instead. *)
val merge
: ( ('key, 'data1, 'phantom) t
-> ('key, 'data2, 'phantom) t
-> f:
(key:'key key
-> [ `Left of 'data1 | `Right of 'data2 | `Both of 'data1 * 'data2 ]
-> 'data3 option)
-> ('key, 'data3, 'phantom) t
, 'key
, 'data3
, 'phantom )
accessor
(** Merges two dictionaries by traversing [src] and adding to [dst]. Computes the
effect on [dst] of each key/value pair in [src] using [f]. *)
val merge_into
: ( src:('key, 'data1, 'phantom) t
-> dst:('key, 'data2, 'phantom) t
-> f:(key:'key key -> 'data1 -> 'data2 option -> 'data2 Merge_into_action.t)
-> unit
, 'key
, 'data
, 'phantom )
accessor
end
module type Accessors1 = sig
type key
type 'data t
include
Accessors
with type (_, 'data, _) t := 'data t
and type _ key := key
and type ('fn, _, _, _) accessor := 'fn
end
module type Accessors2 = sig
type ('key, 'data) t
type ('fn, 'key, 'data) accessor
include
Accessors
with type ('key, 'data, _) t := ('key, 'data) t
and type 'key key := 'key
and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor
end
module type Accessors3 = sig
type ('key, 'data, 'phantom) t
type ('fn, 'key, 'data, 'phantom) accessor
include
Accessors
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key
and type ('fn, 'key, 'data, 'phantom) accessor :=
('fn, 'key, 'data, 'phantom) accessor
end
module type Creators = sig
(** The type of keys. This will be ['key] for polymorphic dictionaries, or some fixed
type for dictionaries with monomorphic keys. *)
type 'key key
(** Dictionaries. Their keys have type ['key key]. Each key's associated value has
type ['data]. The dictionary may be distinguished by a ['phantom] type. *)
type ('key, 'data, 'phantom) t
(** The type of creator functions ['fn] that operate on [('key, 'data, 'phantom) t].
May take extra arguments before ['fn], such as a comparison function. *)
type ('fn, 'key, 'data, 'phantom) creator
(** Creates a new empty dictionary. *)
val create : (unit -> ('key, 'data, 'phantom) t, 'key, 'data, 'phantom) creator
(** Dictionary containing the given key/value pairs. Fails if there are duplicate
keys. *)
val of_alist
: ( ('key key * 'data) list
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_key of 'key key ]
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist]. On failure, provides all duplicate keys instead of a single
representative. *)
val of_alist_report_all_dups
: ( ('key key * 'data) list
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_keys of 'key key list ]
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist]. Returns a [Result.t]. *)
val of_alist_or_error
: ( ('key key * 'data) list -> ('key, 'data, 'phantom) t Or_error.t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist]. Raises on duplicates. *)
val of_alist_exn
: ( ('key key * 'data) list -> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Produces a dictionary mapping each key to a list of associated values. *)
val of_alist_multi
: ( ('key key * 'data) list -> ('key, 'data list, 'phantom) t
, 'key
, 'data list
, 'phantom )
creator
(** Like [of_alist]. Consume a list of elements for which key/value pairs can be
computed. *)
val create_mapped
: ( get_key:('a -> 'key key)
-> get_data:('a -> 'data)
-> 'a list
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_keys of 'key key list ]
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist]. Consume values for which keys can be computed. *)
val create_with_key
: ( get_key:('data -> 'key key)
-> 'data list
-> [ `Ok of ('key, 'data, 'phantom) t | `Duplicate_keys of 'key key list ]
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_or_error]. Consume values for which keys can be computed. *)
val create_with_key_or_error
: ( get_key:('data -> 'key key) -> 'data list -> ('key, 'data, 'phantom) t Or_error.t
, 'key
, 'data
, 'phantom )
creator
(** Like [of_alist_exn]. Consume values for which keys can be computed. *)
val create_with_key_exn
: ( get_key:('data -> 'key key) -> 'data list -> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
(** Like [create_mapped]. Multiple values for a key are [combine]d rather than
producing an error. *)
val group
: ( get_key:('a -> 'key key)
-> get_data:('a -> 'data)
-> combine:('data -> 'data -> 'data)
-> 'a list
-> ('key, 'data, 'phantom) t
, 'key
, 'data
, 'phantom )
creator
end
module type Creators1 = sig
type key
type 'data t
(** @inline *)
include
Creators
with type (_, 'data, _) t := 'data t
and type _ key := key
and type ('fn, _, _, _) creator := 'fn
end
module type Creators2 = sig
type ('key, 'data) t
type ('fn, 'key, 'data) creator
(** @inline *)
include
Creators
with type ('key, 'data, _) t := ('key, 'data) t
and type 'key key := 'key
and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator
end
module type Creators3 = sig
type ('key, 'data, 'phantom) t
type ('fn, 'key, 'data, 'phantom) creator
(** @inline *)
include
Creators
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key
and type ('fn, 'key, 'data, 'phantom) creator :=
('fn, 'key, 'data, 'phantom) creator
end
module type S = sig
type 'key key
type ('key, 'data, 'phantom) t
type ('fn, 'key, 'data, 'phantom) accessor
type ('fn, 'key, 'data, 'phantom) creator
(** @inline *)
include
Accessors
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key key
and type ('fn, 'key, 'data, 'phantom) accessor :=
('fn, 'key, 'data, 'phantom) accessor
(** @inline *)
include
Creators
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key key
and type ('fn, 'key, 'data, 'phantom) creator :=
('fn, 'key, 'data, 'phantom) creator
end
module type S1 = sig
type key
type 'data t
(** @inline *)
include
S
with type (_, 'data, _) t := 'data t
and type _ key := key
and type ('fn, _, _, _) accessor := 'fn
and type ('fn, _, _, _) creator := 'fn
end
module type S2 = sig
type ('key, 'data) t
type ('fn, 'key, 'data) accessor
type ('fn, 'key, 'data) creator
(** @inline *)
include
S
with type ('key, 'data, _) t := ('key, 'data) t
and type 'key key := 'key
and type ('fn, 'key, 'data, _) accessor := ('fn, 'key, 'data) accessor
and type ('fn, 'key, 'data, _) creator := ('fn, 'key, 'data) creator
end
module type S3 = sig
type ('key, 'data, 'phantom) t
type ('fn, 'key, 'data, 'phantom) accessor
type ('fn, 'key, 'data, 'phantom) creator
(** @inline *)
include
S
with type ('key, 'data, 'phantom) t := ('key, 'data, 'phantom) t
and type 'key key := 'key
and type ('fn, 'key, 'data, 'phantom) accessor :=
('fn, 'key, 'data, 'phantom) accessor
and type ('fn, 'key, 'data, 'phantom) creator :=
('fn, 'key, 'data, 'phantom) creator
end
end
module type Dictionary_mutable = sig
(** @inline *)
include module type of struct
include Definitions (** @inline *)
end
end

24
unikernel/duniverse/base/src/discover/discover.ml Normal file
View file

@ -0,0 +1,24 @@
open Configurator.V1
let program =
{|
int main(int argc, char ** argv)
{
return __builtin_popcount(argc);
}
|}
;;
let () =
let output = ref "" in
main
~name:"discover"
~args:[ "-o", Set_string output, "FILENAME output file" ]
(fun c ->
let has_popcnt =
match ocaml_config_var_exn c "system" with
| "macosx" -> false
| _ -> c_test c ~c_flags:[ "-mpopcnt" ] program
in
Flags.write_sexp !output (if has_popcnt then [ "-mpopcnt" ] else []))
;;

1
unikernel/duniverse/base/src/discover/discover.mli Normal file
View file

@ -0,0 +1 @@
(* empty *)

5
unikernel/duniverse/base/src/discover/dune Normal file
View file

@ -0,0 +1,5 @@
(executables
(modes byte exe)
(names discover)
(libraries dune-configurator)
(preprocess no_preprocessing))

51
unikernel/duniverse/base/src/dune Normal file
View file

@ -0,0 +1,51 @@
(rule
(targets random_repr.ml)
(deps
(:first_dep select-random-repr/select.ml))
(action
(run %{ocaml} %{first_dep} -ocaml-version %{ocaml_version} -o %{targets})))
(rule
(targets pow_overflow_bounds.ml)
(deps
(:first_dep ../generate/generate_pow_overflow_bounds.exe))
(action
(run %{first_dep} -atomic -o %{targets}))
(mode fallback))
(library
(foreign_stubs
(language c)
(names bytes_stubs exn_stubs int_math_stubs hash_stubs obj_stubs am_testing)
(flags
:standard
-D_LARGEFILE64_SOURCE
(:include mpopcnt.sexp)))
(name base)
(public_name base)
(ocamlopt_flags
:standard
(:include ocamlopt-flags))
(libraries base_internalhash_types sexplib0 shadow_stdlib
ocaml_intrinsics_kernel)
(preprocess no_preprocessing)
(lint
(pps ppx_base ppx_base_lint -check-doc-comments -type-conv-keep-w32=both
-apply=js_style,base_lint,type_conv,cold))
(js_of_ocaml
(javascript_files runtime.js)))
(rule
(targets mpopcnt.sexp)
(action
(run ./discover/discover.exe -o %{targets})))
(ocamllex hex_lexer)
(documentation)
(rule
(targets ocamlopt-flags)
(deps)
(action
(bash "echo '()' > ocamlopt-flags")))

223
unikernel/duniverse/base/src/either.ml Normal file
View file

@ -0,0 +1,223 @@
open! Import
include Either_intf
module List = List0
include Either0
let swap = function
| First x -> Second x
| Second x -> First x
;;
let is_first = function
| First _ -> true
| Second _ -> false
;;
let is_second = function
| First _ -> false
| Second _ -> true
;;
let value (First x | Second x) = x
let value_map t ~first ~second =
match t with
| First x -> first x
| Second x -> second x
;;
let iter = value_map
let map t ~first ~second =
match t with
| First x -> First (first x)
| Second x -> Second (second x)
;;
let first x = First x
let second x = Second x
let equal eq1 eq2 t1 t2 =
match t1, t2 with
| First x, First y -> eq1 x y
| Second x, Second y -> eq2 x y
| First _, Second _ | Second _, First _ -> false
;;
let local_equal eq1 eq2 t1 t2 =
match t1, t2 with
| First x, First y -> eq1 x y
| Second x, Second y -> eq2 x y
| First _, Second _ | Second _, First _ -> false
;;
let invariant f s = function
| First x -> f x
| Second y -> s y
;;
module Focus = struct
type ('a, 'b) t =
| Focus of { value : 'a }
| Other of { value : 'b }
end
module Make_focused (M : sig
type (+'a, +'b) t
val return : 'a -> ('a, _) t
val other : 'b -> (_, 'b) t
val focus : ('a, 'b) t -> ('a, 'b) Focus.t
val combine
: ('a, 'd) t
-> ('b, 'd) t
-> f:('a -> 'b -> 'c)
-> other:('d -> 'd -> 'd)
-> ('c, 'd) t
val bind : ('a, 'b) t -> f:('a -> ('c, 'b) t) -> ('c, 'b) t
end) =
struct
include M
open With_return
let map t ~f =
let res = bind t ~f:(fun x -> return (f x)) in
res
;;
include Monad.Make2_local (struct
type nonrec ('a, 'b) t = ('a, 'b) t
let return = return
let bind = bind
let map = `Custom map
end)
module App = Applicative.Make2_using_map2_local (struct
type nonrec ('a, 'b) t = ('a, 'b) t
let return = return
let map = `Custom map
let map2 : ('a, 'x) t -> ('b, 'x) t -> f:('a -> 'b -> 'c) -> ('c, 'x) t =
fun t1 t2 ~f ->
bind t1 ~f:(fun x -> bind t2 ~f:(fun y -> return (f x y)) [@nontail]) [@nontail]
;;
end)
include App
let combine_all =
let rec other_loop f acc = function
| [] -> other acc
| t :: ts ->
(match focus t with
| Focus _ -> other_loop f acc ts
| Other o -> other_loop f (f acc o.value) ts)
in
let rec return_loop f acc = function
| [] -> return (List.rev acc)
| t :: ts ->
(match focus t with
| Focus x -> return_loop f (x.value :: acc) ts
| Other o -> other_loop f o.value ts)
in
fun ts ~f -> return_loop f [] ts
;;
let combine_all_unit =
let rec other_loop f acc = function
| [] -> other acc
| t :: ts ->
(match focus t with
| Focus _ -> other_loop f acc ts
| Other o -> other_loop f (f acc o.value) ts)
in
let rec return_loop f = function
| [] -> return ()
| t :: ts ->
(match focus t with
| Focus { value = () } -> return_loop f ts
| Other { value = o } -> other_loop f o ts)
in
fun ts ~f -> return_loop f ts
;;
let to_option t =
match focus t with
| Focus x -> Some x.value
| Other _ -> None
;;
let value t ~default =
match focus t with
| Focus x -> x.value
| Other _ -> default
;;
let with_return f =
with_return (fun ret -> other (f (With_return.prepend ret ~f:return))) [@nontail]
;;
end
module First = Make_focused (struct
type nonrec ('a, 'b) t = ('a, 'b) t
let return = first
let other = second
let focus t : _ Focus.t =
match t with
| First x -> Focus { value = x }
| Second y -> Other { value = y }
;;
let combine t1 t2 ~f ~other =
match t1, t2 with
| First x, First y -> First (f x y)
| Second x, Second y -> Second (other x y)
| Second x, _ | _, Second x -> Second x
;;
let bind t ~f =
match t with
| First x -> f x
(* Reuse the value in order to avoid allocation. *)
| Second _ as y -> y
;;
end)
module Second = Make_focused (struct
type nonrec ('a, 'b) t = ('b, 'a) t
let return = second
let other = first
let focus t : _ Focus.t =
match t with
| Second x -> Focus { value = x }
| First y -> Other { value = y }
;;
let combine t1 t2 ~f ~other =
match t1, t2 with
| Second x, Second y -> Second (f x y)
| First x, First y -> First (other x y)
| First x, _ | _, First x -> First x
;;
let bind t ~f =
match t with
| Second x -> f x
(* Reuse the value in order to avoid allocation, like [First.bind] above. *)
| First _ as y -> y
;;
end)
module Export = struct
type ('f, 's) _either = ('f, 's) t =
| First of 'f
| Second of 's
end

1
unikernel/duniverse/base/src/either.mli Normal file
View file

@ -0,0 +1 @@
include Either_intf.Either (** @inline *)

142
unikernel/duniverse/base/src/either0.ml Normal file
View file

@ -0,0 +1,142 @@
open! Import
type ('f, 's) t =
| First of 'f
| Second of 's
[@@deriving_inline compare ~localize, hash, sexp, sexp_grammar]
let compare__local :
'f 's. ('f -> 'f -> int) -> ('s -> 's -> int) -> ('f, 's) t -> ('f, 's) t -> int
=
fun _cmp__f _cmp__s a__007_ b__008_ ->
if Stdlib.( == ) a__007_ b__008_
then 0
else (
match a__007_, b__008_ with
| First _a__009_, First _b__010_ -> _cmp__f _a__009_ _b__010_
| First _, _ -> -1
| _, First _ -> 1
| Second _a__011_, Second _b__012_ -> _cmp__s _a__011_ _b__012_)
;;
let compare :
'f 's. ('f -> 'f -> int) -> ('s -> 's -> int) -> ('f, 's) t -> ('f, 's) t -> int
=
fun _cmp__f _cmp__s a__001_ b__002_ ->
if Stdlib.( == ) a__001_ b__002_
then 0
else (
match a__001_, b__002_ with
| First _a__003_, First _b__004_ -> _cmp__f _a__003_ _b__004_
| First _, _ -> -1
| _, First _ -> 1
| Second _a__005_, Second _b__006_ -> _cmp__s _a__005_ _b__006_)
;;
let hash_fold_t
: type f s.
(Ppx_hash_lib.Std.Hash.state -> f -> Ppx_hash_lib.Std.Hash.state)
-> (Ppx_hash_lib.Std.Hash.state -> s -> Ppx_hash_lib.Std.Hash.state)
-> Ppx_hash_lib.Std.Hash.state
-> (f, s) t
-> Ppx_hash_lib.Std.Hash.state
=
fun _hash_fold_f _hash_fold_s hsv arg ->
match arg with
| First _a0 ->
let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 0 in
let hsv = hsv in
_hash_fold_f hsv _a0
| Second _a0 ->
let hsv = Ppx_hash_lib.Std.Hash.fold_int hsv 1 in
let hsv = hsv in
_hash_fold_s hsv _a0
;;
let t_of_sexp :
'f 's.
(Sexplib0.Sexp.t -> 'f) -> (Sexplib0.Sexp.t -> 's) -> Sexplib0.Sexp.t -> ('f, 's) t
=
fun (type f__029_ s__030_)
: ((Sexplib0.Sexp.t -> f__029_) -> (Sexplib0.Sexp.t -> s__030_) -> Sexplib0.Sexp.t
-> (f__029_, s__030_) t) ->
let error_source__017_ = "either0.ml.t" in
fun _of_f__013_ _of_s__014_ -> function
| Sexplib0.Sexp.List
(Sexplib0.Sexp.Atom (("first" | "First") as _tag__020_) :: sexp_args__021_) as
_sexp__019_ ->
(match sexp_args__021_ with
| arg0__022_ :: [] ->
let res0__023_ = _of_f__013_ arg0__022_ in
First res0__023_
| _ ->
Sexplib0.Sexp_conv_error.stag_incorrect_n_args
error_source__017_
_tag__020_
_sexp__019_)
| Sexplib0.Sexp.List
(Sexplib0.Sexp.Atom (("second" | "Second") as _tag__025_) :: sexp_args__026_) as
_sexp__024_ ->
(match sexp_args__026_ with
| arg0__027_ :: [] ->
let res0__028_ = _of_s__014_ arg0__027_ in
Second res0__028_
| _ ->
Sexplib0.Sexp_conv_error.stag_incorrect_n_args
error_source__017_
_tag__025_
_sexp__024_)
| Sexplib0.Sexp.Atom ("first" | "First") as sexp__018_ ->
Sexplib0.Sexp_conv_error.stag_takes_args error_source__017_ sexp__018_
| Sexplib0.Sexp.Atom ("second" | "Second") as sexp__018_ ->
Sexplib0.Sexp_conv_error.stag_takes_args error_source__017_ sexp__018_
| Sexplib0.Sexp.List (Sexplib0.Sexp.List _ :: _) as sexp__016_ ->
Sexplib0.Sexp_conv_error.nested_list_invalid_sum error_source__017_ sexp__016_
| Sexplib0.Sexp.List [] as sexp__016_ ->
Sexplib0.Sexp_conv_error.empty_list_invalid_sum error_source__017_ sexp__016_
| sexp__016_ -> Sexplib0.Sexp_conv_error.unexpected_stag error_source__017_ sexp__016_
;;
let sexp_of_t :
'f 's.
('f -> Sexplib0.Sexp.t) -> ('s -> Sexplib0.Sexp.t) -> ('f, 's) t -> Sexplib0.Sexp.t
=
fun (type f__037_ s__038_)
: ((f__037_ -> Sexplib0.Sexp.t) -> (s__038_ -> Sexplib0.Sexp.t)
-> (f__037_, s__038_) t -> Sexplib0.Sexp.t) ->
fun _of_f__031_ _of_s__032_ -> function
| First arg0__033_ ->
let res0__034_ = _of_f__031_ arg0__033_ in
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "First"; res0__034_ ]
| Second arg0__035_ ->
let res0__036_ = _of_s__032_ arg0__035_ in
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "Second"; res0__036_ ]
;;
let t_sexp_grammar :
'f 's.
'f Sexplib0.Sexp_grammar.t
-> 's Sexplib0.Sexp_grammar.t
-> ('f, 's) t Sexplib0.Sexp_grammar.t
=
fun _'f_sexp_grammar _'s_sexp_grammar ->
{ untyped =
Variant
{ case_sensitivity = Case_sensitive_except_first_character
; clauses =
[ No_tag
{ name = "First"
; clause_kind =
List_clause { args = Cons (_'f_sexp_grammar.untyped, Empty) }
}
; No_tag
{ name = "Second"
; clause_kind =
List_clause { args = Cons (_'s_sexp_grammar.untyped, Empty) }
}
]
}
}
;;
[@@@end]

87
unikernel/duniverse/base/src/either_intf.ml Normal file
View file

@ -0,0 +1,87 @@
(** A type that represents values with two possibilities.
[Either] can be seen as a generic sum type, the dual of [Tuple]. [First] is neither
more important nor less important than [Second].
Many functions in [Either] focus on just one constructor. The [Focused] signature
abstracts over which constructor is the focus. To use these functions, use the
[First] or [Second] modules in [S]. *)
open! Import
module type Focused = sig
type (+'focus, +'other) t
include Monad.S2_local with type ('a, 'b) t := ('a, 'b) t
include Applicative.S2_local with type ('a, 'b) t := ('a, 'b) t
val value : ('a, _) t -> default:'a -> 'a
val to_option : ('a, _) t -> 'a option
val with_return : ('a With_return.return -> 'b) -> ('a, 'b) t
val combine
: ('a, 'd) t
-> ('b, 'd) t
-> f:('a -> 'b -> 'c)
-> other:('d -> 'd -> 'd)
-> ('c, 'd) t
val combine_all : ('a, 'b) t list -> f:('b -> 'b -> 'b) -> ('a list, 'b) t
val combine_all_unit : (unit, 'b) t list -> f:('b -> 'b -> 'b) -> (unit, 'b) t
end
module type Either = sig
type ('f, 's) t = ('f, 's) Either0.t =
| First of 'f
| Second of 's
[@@deriving_inline compare ~localize, hash, sexp, sexp_grammar]
include Ppx_compare_lib.Comparable.S2 with type ('f, 's) t := ('f, 's) t
include Ppx_compare_lib.Comparable.S_local2 with type ('f, 's) t := ('f, 's) t
include Ppx_hash_lib.Hashable.S2 with type ('f, 's) t := ('f, 's) t
include Sexplib0.Sexpable.S2 with type ('f, 's) t := ('f, 's) t
val t_sexp_grammar
: 'f Sexplib0.Sexp_grammar.t
-> 's Sexplib0.Sexp_grammar.t
-> ('f, 's) t Sexplib0.Sexp_grammar.t
[@@@end]
include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t
val swap : ('f, 's) t -> ('s, 'f) t
val value : ('a, 'a) t -> 'a
val iter : ('a, 'b) t -> first:('a -> unit) -> second:('b -> unit) -> unit
val value_map : ('a, 'b) t -> first:('a -> 'c) -> second:('b -> 'c) -> 'c
val map : ('a, 'b) t -> first:('a -> 'c) -> second:('b -> 'd) -> ('c, 'd) t
val equal : ('f -> 'f -> bool) -> ('s -> 's -> bool) -> ('f, 's) t -> ('f, 's) t -> bool
val local_equal
: ('f -> 'f -> bool)
-> ('s -> 's -> bool)
-> ('f, 's) t
-> ('f, 's) t
-> bool
module type Focused = Focused
module First : Focused with type ('a, 'b) t = ('a, 'b) t
module Second : Focused with type ('a, 'b) t = ('b, 'a) t
val is_first : (_, _) t -> bool
val is_second : (_, _) t -> bool
(** [first] and [second] are [First.return] and [Second.return]. *)
val first : 'f -> ('f, _) t
val second : 's -> (_, 's) t
(**/**)
module Export : sig
type ('f, 's) _either = ('f, 's) t =
| First of 'f
| Second of 's
end
end

44
unikernel/duniverse/base/src/equal.ml Normal file
View file

@ -0,0 +1,44 @@
(** This module defines signatures that are to be included in other signatures to ensure a
consistent interface to [equal] functions. There is a signature ([S], [S1], [S2],
[S3]) for each arity of type. Usage looks like:
{[
type t
include Equal.S with type t := t
]}
or
{[
type 'a t
include Equal.S1 with type 'a t := 'a t
]} *)
open! Import
type 'a t = 'a -> 'a -> bool
type 'a equal = 'a t
module type S = sig
type t
val equal : t equal
end
module type S1 = sig
type 'a t
val equal : 'a equal -> 'a t equal
end
module type S2 = sig
type ('a, 'b) t
val equal : 'a equal -> 'b equal -> ('a, 'b) t equal
end
module type S3 = sig
type ('a, 'b, 'c) t
val equal : 'a equal -> 'b equal -> 'c equal -> ('a, 'b, 'c) t equal
end

19
unikernel/duniverse/base/src/error.ml Normal file
View file

@ -0,0 +1,19 @@
(* This module is trying to minimize dependencies on modules in Core, so as to allow
[Error] and [Or_error] to be used in various places. Please avoid adding new
dependencies. *)
open! Import
include Info
let t_sexp_grammar : t Sexplib0.Sexp_grammar.t = { untyped = Any "Error.t" }
let[@cold] raise t = raise (to_exn t)
let[@cold] raise_s sexp = raise (create_s sexp)
let to_info t = t
let of_info t = t
include Pretty_printer.Register_pp (struct
type nonrec t = t
let module_name = "Base.Error"
let pp = pp
end)

14
unikernel/duniverse/base/src/error.mli Normal file
View file

@ -0,0 +1,14 @@
(** A lazy string, implemented with [Info], but intended specifically for error
messages. *)
open! Import
include Info_intf.S with type t = private Info.t (** @open *)
(** Note that the exception raised by this function maintains a reference to the [t]
passed in. *)
val raise : t -> _
val raise_s : Sexp.t -> _
val to_info : t -> Info.t
val of_info : Info.t -> t

172
unikernel/duniverse/base/src/exn.ml Normal file
View file

@ -0,0 +1,172 @@
open! Import
type t = exn [@@deriving_inline sexp_of]
let sexp_of_t = (sexp_of_exn : t -> Sexplib0.Sexp.t)
[@@@end]
let exit = Stdlib.exit
exception Finally of t * t [@@deriving_inline sexp]
let () =
Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Finally] (function
| Finally (arg0__001_, arg1__002_) ->
let res0__003_ = sexp_of_t arg0__001_
and res1__004_ = sexp_of_t arg1__002_ in
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "exn.ml.Finally"; res0__003_; res1__004_ ]
| _ -> assert false)
;;
[@@@end]
exception Reraised of string * t [@@deriving_inline sexp]
let () =
Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Reraised] (function
| Reraised (arg0__005_, arg1__006_) ->
let res0__007_ = sexp_of_string arg0__005_
and res1__008_ = sexp_of_t arg1__006_ in
Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom "exn.ml.Reraised"; res0__007_; res1__008_ ]
| _ -> assert false)
;;
[@@@end]
exception Sexp of Sexp.t
(* We install a custom exn-converter rather than use:
{[
exception Sexp of Sexp.t [@@deriving_inline sexp]
(* ... *)
[@@@end]
]}
to eliminate the extra wrapping of [(Sexp ...)]. *)
let () =
Sexplib0.Sexp_conv.Exn_converter.add [%extension_constructor Sexp] (function
| Sexp t -> t
| _ ->
(* Reaching this branch indicates a bug in sexplib. *)
assert false)
;;
let create_s sexp = Sexp sexp
let raise_with_original_backtrace t backtrace =
Stdlib.Printexc.raise_with_backtrace t backtrace
;;
external is_phys_equal_most_recent : t -> bool = "Base_caml_exn_is_most_recent_exn"
let reraise exn str =
let exn' = Reraised (str, exn) in
if is_phys_equal_most_recent exn
then (
let bt = Stdlib.Printexc.get_raw_backtrace () in
raise_with_original_backtrace exn' bt)
else raise exn'
;;
let reraisef exc format = Printf.ksprintf (fun str () -> reraise exc str) format
let to_string exc = Sexp.to_string_hum ~indent:2 (sexp_of_exn exc)
let to_string_mach exc = Sexp.to_string_mach (sexp_of_exn exc)
let sexp_of_t = sexp_of_exn
let protectx ~f x ~(finally : _ -> unit) =
match f x with
| res ->
finally x;
res
| exception exn ->
let bt = Stdlib.Printexc.get_raw_backtrace () in
(match finally x with
| () -> raise_with_original_backtrace exn bt
| exception final_exn ->
(* Unfortunately, the backtrace of the [final_exn] is discarded here. *)
raise_with_original_backtrace (Finally (exn, final_exn)) bt)
;;
let protect ~f ~finally = protectx ~f () ~finally
let does_raise (type a) (f : unit -> a) =
try
ignore (f () : a);
false
with
| _ -> true
;;
include Pretty_printer.Register_pp (struct
type t = exn
let pp ppf t =
match sexp_of_exn_opt t with
| Some sexp -> Sexp.pp_hum ppf sexp
| None -> Stdlib.Format.pp_print_string ppf (Stdlib.Printexc.to_string t)
;;
let module_name = "Base.Exn"
end)
let print_with_backtrace exc raw_backtrace =
Stdlib.Format.eprintf "@[<2>Uncaught exception:@\n@\n@[%a@]@]@\n@." pp exc;
if Stdlib.Printexc.backtrace_status ()
then Stdlib.Printexc.print_raw_backtrace Stdlib.stderr raw_backtrace;
Stdlib.flush Stdlib.stderr
;;
let set_uncaught_exception_handler () =
Stdlib.Printexc.set_uncaught_exception_handler print_with_backtrace
;;
let handle_uncaught_aux ~do_at_exit ~exit f =
try f () with
| exc ->
let raw_backtrace = Stdlib.Printexc.get_raw_backtrace () in
(* One reason to run [do_at_exit] handlers before printing out the error message is
that it helps curses applications bring the terminal in a good state, otherwise the
error message might get corrupted. Also, the OCaml top-level uncaught exception
handler does the same. *)
if do_at_exit
then (
try Stdlib.do_at_exit () with
| _ -> ());
(try print_with_backtrace exc raw_backtrace with
| _ ->
(try
Stdlib.Printf.eprintf "Exn.handle_uncaught could not print; exiting anyway\n%!"
with
| _ -> ()));
exit 1
;;
let handle_uncaught_and_exit f = handle_uncaught_aux f ~exit ~do_at_exit:true
let handle_uncaught ~exit:must_exit f =
handle_uncaught_aux f ~exit:(if must_exit then exit else ignore) ~do_at_exit:must_exit
;;
let reraise_uncaught str func =
try func () with
| exn ->
let bt = Stdlib.Printexc.get_raw_backtrace () in
raise_with_original_backtrace (Reraised (str, exn)) bt
;;
external clear_backtrace : unit -> unit = "Base_clear_caml_backtrace_pos" [@@noalloc]
let raise_without_backtrace e =
(* We clear the backtrace to reduce confusion, so that people don't think whatever
is stored corresponds to this raise. *)
clear_backtrace ();
Stdlib.raise_notrace e
;;
let initialize_module () = set_uncaught_exception_handler ()
module Private = struct
let clear_backtrace = clear_backtrace
end

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