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

8
unikernel/duniverse/dune_/.devcontainer/devcontainer.json Normal file
View file

@ -0,0 +1,8 @@
{
"name": "OCaml",
"image": "mcr.microsoft.com/devcontainers/base:bullseye",
"features": { "ghcr.io/avsm/ocaml-devcontainers-feature/ocaml:latest": {} },
"postCreateCommand": "opam init -ay --disable-sandboxing && sudo chown vscode _build && sudo apt-get update && make dev-switch && sudo apt install -y file npm",
"mounts": ["source=${localWorkspaceFolderBasename}-ocaml-build,target=${containerWorkspaceFolder}/_build,type=volume"],
"remoteUser": "vscode"
}

5
unikernel/duniverse/dune_/.dockerignore Normal file
View file

@ -0,0 +1,5 @@
_build
_boot
_opam
dune.exe
result

12
unikernel/duniverse/dune_/.git-blame-ignore-revs Normal file
View file

@ -0,0 +1,12 @@
# ocamlformat 0.20.1
065466c955ca14d512ae50e844acfab1370f566e
# ocamlformat 0.25.1
3f01f6f3694e48cb1868018121f3959f8d23baca
# ocamlformat 0.26.0
14d199fa57d05692385342685f431cd3a6a8205c
# switch to janestreet profile
cb8f84e01a2eb4a2a2cf8d5bcfe5b2fc23e93d96
# ocamlformat 0.26.1
f739a11a7d407db219446757093c4bc913989378
# ocamlformat 0.27.0
197b0c84d2e51647892fe6c9a6842265b4866255

11
unikernel/duniverse/dune_/.gitattributes vendored Executable file
View file

@ -0,0 +1,11 @@
*.ml* text eol=lf linguist-language=OCaml
*.rst text eol=lf
*.c text eol=lf
*.t text eol=lf -linguist-detectable
*.sh text eol=lf
*.ps1 text working-tree-encoding=UTF-16 eol=crlf
dune text eol=lf
dune.inc text eol=lf
.gitignore text eol=lf
.gitattributes text eol=lf
.ocamlformat text eol=lf

39
unikernel/duniverse/dune_/.github/ISSUE_TEMPLATE/bug_report.md vendored Normal file
View file

@ -0,0 +1,39 @@
---
name: Bug report
about: File an issue to help us improve
title: ''
labels: ''
assignees: ''
---
<!-- Thank you for filing an issue to help us improve Dune! -->
## Expected Behavior
## Actual Behavior
## Reproduction
<!-- If possible, please open a PR with a test that reproduces the problem.
Adding tests is easy, see https://github.com/ocaml/dune/blob/master/doc/hacking.rst -->
- PR with a reproducing test:
<!-- Otherwise, please detail how the behavior can be reproduced -->
1.
1.
1.
## Specifications
- Version of `dune` (output of `dune --version`):
- Version of `ocaml` (output of `ocamlc --version`):
- Operating system (distribution and version):
<!-- remove the following if not used -->
## Additional information
- Link to gist with verbose output (run `dune` with the `--verbose` flag):

20
unikernel/duniverse/dune_/.github/ISSUE_TEMPLATE/feature_request.md vendored Normal file
View file

@ -0,0 +1,20 @@
---
name: Feature request
about: Suggest an idea to improve dune
title: ''
labels: ''
assignees: ''
---
<!-- Thank you for filing an issue to help us improve Dune! -->
## Desired Behavior
<!-- Please describe the desired behavior in as much detail as you can. This
should include the context in which you think this would be useful. -->
## Example
<!-- Please provide a concrete example of the proposed functionality. This would
include a minimal working example of the files you're trying to build with.
-->

45
unikernel/duniverse/dune_/.github/ISSUE_TEMPLATE/release.md vendored Normal file
View file

@ -0,0 +1,45 @@
---
name: Release
about: Open a release tracker issue
title: "X.Y.Z release tracker"
labels: ["release"]
assignees: ''
---
<!-- If release is Patch release use section { -->
## Preparation
- Need backport:
- [link to PR to backport]
- Backports:
- [link to backport PR]
<!-- } else if release is Minor release use section { -->
## Known blockers
- [ ] Something is blocking the PR because of ...
<!-- } -->
## Release
<!-- Replace X.Y.Z with the correct Dune version -->
- [ ] Update dune changelog to `X.Y.Z` on `X.Y` branch [link to dune PR]
- [ ] Open then pull request on `opam-repository` [link to OPAM PR]
- [ ] Triage (ensure it does not break anything)
- [ ] Update nix-overlays with the new version [link to nix-overlays PRs]
## Post-release
- [ ] Merge dune changelog in `main` [link to dune PR]
- [ ] Update ocaml.org changelog [link to ocaml.org PR]
- [ ] Write a post about the release on Discuss [link to post]
- [ ] Store the revdeps error file in the [logs](https://github.com/ocaml/dune/wiki/Reverse-dependencies-CI-logs)
- [ ] Create a next release milestone
<!-- If minor release uncomment this -->
<!-- - [ ] Increase `lang dune` number -->
## Last stage
- [ ] Close tracking issue

171
unikernel/duniverse/dune_/.github/workflows/bench.yml vendored Normal file
View file

@ -0,0 +1,171 @@
name: Build time benchmarks
# Do not run this workflow on pull request since this workflow has permission to modify contents.
on:
push:
branches:
- main
permissions:
# deployments permission to deploy GitHub pages website
deployments: write
# contents permission to update benchmark contents in gh-pages branch
contents: write
jobs:
build:
name: Build
strategy:
fail-fast: false
matrix:
os:
- ubuntu-latest
ocaml-compiler:
- 5.1.x
runs-on: ${{ matrix.os }}
steps:
- name: Checkout code
uses: actions/checkout@v4
- name: Use OCaml ${{ matrix.ocaml-compiler }}
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: ${{ matrix.ocaml-compiler }}
opam-depext: false
# dune doesn't have any additional dependencies so we can build it right
# away this makes it possible to see build errors as soon as possible
- run: opam exec -- make _boot/dune.exe
- name: Install deps on Unix
run: |
opam install . --deps-only --with-test
opam exec -- make dev-deps
# Install hyperfine
wget https://github.com/sharkdp/hyperfine/releases/download/v1.14.0/hyperfine_1.14.0_amd64.deb
sudo dpkg -i hyperfine_1.14.0_amd64.deb
- name: Create watch synthetic benchmark
working-directory: bench
run: opam exec -- ../_boot/dune.exe exec ./gen_synthetic_dune_watch.exe -- synthetic-watch
- name: Run synthetic watch benchmark
working-directory: bench/synthetic-watch
run: ../gen-benchmark.sh 'opam exec -- ../run-synthetic-dune-watch.sh ../../_boot/dune.exe' 'opam exec -- ../../_boot/dune.exe build @all' 'synthetic watch build time (warm, ${{ runner.os }})' > synthetic-benchmark-result.json
- name: Print synthetic watch benchmark results
working-directory: bench/synthetic-watch
run: |
cat bench.json
cat synthetic-benchmark-result.json
- name: Store synthetic watch benchmark result
uses: benchmark-action/github-action-benchmark@v1
with:
name: Synthetic Watch Benchmark
tool: "customSmallerIsBetter"
output-file-path: bench/synthetic-watch/synthetic-benchmark-result.json
github-token: ${{ secrets.GITHUB_TOKEN }}
auto-push: true
# Ratio indicating how worse the current benchmark result is.
# 175% means if last build took 40s and current takes >70s, it will trigger an alert
alert-threshold: "225%"
fail-on-alert: true
# Enable alert commit comment
comment-on-alert: true
# Mention @jchavarri in the commit comment
alert-comment-cc-users: '@jchavarri'
- name: Clone pupilfirst fork
run: git clone --depth 1 https://github.com/jchavarri/pupilfirst.git
- name: Install all deps
working-directory: pupilfirst
run: opam install -y . --deps-only
- name: Run pupilfirst benchmark
working-directory: pupilfirst
run: ../bench/gen-benchmark.sh 'opam exec -- ../_boot/dune.exe build --root=. @main' 'opam exec -- ../_boot/dune.exe clean --root=.' 'pupilfirst build time (${{ runner.os }})' > melange-benchmark-result.json
- name: Print pupilfirst benchmark results
working-directory: pupilfirst
run: |
cat bench.json
cat melange-benchmark-result.json
- name: Store melange benchmark result
uses: benchmark-action/github-action-benchmark@v1
with:
name: Melange Benchmark
tool: "customSmallerIsBetter"
output-file-path: pupilfirst/melange-benchmark-result.json
github-token: ${{ secrets.GITHUB_TOKEN }}
auto-push: true
# Ratio indicating how worse the current benchmark result is.
# 150% means if last build took 40s and current takes >60s, it will trigger an alert
alert-threshold: "225%"
fail-on-alert: true
# Enable alert commit comment
comment-on-alert: true
# Mention @jchavarri in the commit comment
alert-comment-cc-users: '@jchavarri'
- name: Create synthetic benchmark
working-directory: bench
run: opam exec -- ../_boot/dune.exe exec ./gen_synthetic.exe -- -n 2000 synthetic
- name: Run cold synthetic benchmark
working-directory: bench/synthetic
run: ../gen-benchmark.sh 'opam exec -- ../../_boot/dune.exe build @all' 'opam exec -- ../../_boot/dune.exe clean' 'synthetic build time (cold, ${{ runner.os }})' > synthetic-benchmark-result.json
- name: Print cold synthetic benchmark results
working-directory: bench/synthetic
run: |
cat bench.json
cat synthetic-benchmark-result.json
- name: Store cold synthetic benchmark result
uses: benchmark-action/github-action-benchmark@v1
with:
name: Synthetic Benchmark
tool: "customSmallerIsBetter"
output-file-path: bench/synthetic/synthetic-benchmark-result.json
github-token: ${{ secrets.GITHUB_TOKEN }}
auto-push: true
# Ratio indicating how worse the current benchmark result is.
# 150% means if last build took 40s and current takes >60s, it will trigger an alert
alert-threshold: "225%"
fail-on-alert: true
# Enable alert commit comment
comment-on-alert: true
# Mention @jchavarri in the commit comment
alert-comment-cc-users: '@jchavarri'
- name: Run warm synthetic benchmark
working-directory: bench/synthetic
run: ../gen-benchmark.sh 'opam exec -- ../../_boot/dune.exe build @all' 'true' 'synthetic build time (warm, ${{ runner.os }})' > synthetic-benchmark-result.json
- name: Print warm synthetic benchmark results
working-directory: bench/synthetic
run: |
cat bench.json
cat synthetic-benchmark-result.json
- name: Store warm synthetic benchmark result
uses: benchmark-action/github-action-benchmark@v1
with:
name: Synthetic Benchmark
tool: "customSmallerIsBetter"
output-file-path: bench/synthetic/synthetic-benchmark-result.json
github-token: ${{ secrets.GITHUB_TOKEN }}
auto-push: true
# Ratio indicating how worse the current benchmark result is.
# 150% means if last build took 40s and current takes >60s, it will trigger an alert
alert-threshold: "225%"
fail-on-alert: true
# Enable alert commit comment
comment-on-alert: true
# Mention @jchavarri in the commit comment
alert-comment-cc-users: '@jchavarri'

40
unikernel/duniverse/dune_/.github/workflows/binaries.yml vendored Normal file
View file

@ -0,0 +1,40 @@
name: Binaries
on:
workflow_dispatch:
jobs:
binary:
name: Create
strategy:
fail-fast: false
matrix:
include:
- os: macos-13
name: x86_64-apple-darwin
installable: .#
- os: macos-14
name: aarch64-apple-darwin
installable: .#
- os: ubuntu-22.04
name: x86_64-unknown-linux-musl
installable: .#dune-static
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v4
with:
fetch-depth: 0 # for git describe
- uses: cachix/install-nix-action@v22
- run: echo "(version $(git describe --always --dirty --abbrev=7))" >> dune-project
- run: nix build ${{ matrix.installable }}
- uses: actions/upload-artifact@v4
with:
path: result/bin/dune
name: dune-${{ matrix.name }}
combine:
runs-on: ubuntu-latest
needs: binary
steps:
- uses: actions/upload-artifact/merge@v4
with:
separate-directories: true

27
unikernel/duniverse/dune_/.github/workflows/mirage.yml vendored Normal file
View file

@ -0,0 +1,27 @@
name: Mirage
on:
workflow_dispatch:
jobs:
build:
name: Build caldav
runs-on: ubuntu-latest
steps:
- name: Clone caldav
uses: actions/checkout@v4
with:
repository: roburio/caldav
ref: 51f0d150542348dc259b7c9f7bc70ee592243f7f
- name: Use OCaml ${{ matrix.ocaml-compiler }}
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: 4.14.x
opam-depext: false
- run: opam repo set-url default git+https://github.com/ocaml/opam-repository#dc24cade5f037058a4d86fcdd008159923152db5
- run: sed -i s/1.3/2.7/ dune-project
- run: opam pin add -n dune.dev git+https://github.com/ocaml/dune#$GITHUB_SHA
- run: sudo apt install libseccomp-dev
- run: opam install mirage.4.4.2 opam-monorepo.0.3.6
- run: cd mirage; opam exec -- mirage configure -f config.ml -t hvt
- run: cd mirage; opam exec -- make depend lock pull build

38
unikernel/duniverse/dune_/.github/workflows/oxcaml.yml vendored Normal file
View file

@ -0,0 +1,38 @@
name: OxCaml (experimental)
on:
push:
branches:
- main
workflow_dispatch:
pull_request:
permissions:
contents: read
jobs:
oxcaml:
name: Building Dune with OxCaml
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v4
- name: Install OCaml
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: ocaml-variants.5.2.0+ox
# CR maiste: Update jst to not depend on a working commit anymore. It
# prevents non working commits to break the Dune CI
opam-repositories: |
oxcaml: "git+https://github.com/oxcaml/opam-repository.git"
default: "git+https://github.com/ocaml/opam-repository.git"
- name: Install deps
run: |
opam install . --deps-only
- name: Build dune
run: opam exec -- make bootstrap
- name: Run OxCaml tests
run: opam exec -- ./dune.exe test ./test/blackbox-tests/test-cases/oxcaml

300
unikernel/duniverse/dune_/.github/workflows/workflow.yml vendored Normal file
View file

@ -0,0 +1,300 @@
name: CI
on:
push:
branches:
- main
pull_request:
workflow_dispatch:
merge_group:
concurrency:
group: "${{ github.workflow }} @ ${{ github.event.pull_request.head.label || github.head_ref || github.ref }}"
cancel-in-progress: true
permissions:
contents: read
jobs:
#
# Stage 1
#
nix-build:
name: Nix Build
strategy:
fail-fast: false
matrix:
os:
- macos-latest
- ubuntu-latest
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v4
- uses: cachix/install-nix-action@v31
with:
extra_nix_config: |
extra-substituters = https://anmonteiro.nix-cache.workers.dev
extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY=
- run: nix build
nix-test:
name: Nix Tests
strategy:
fail-fast: false
matrix:
os:
- ubuntu-latest
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v4
- uses: cachix/install-nix-action@v31
with:
extra_nix_config: |
extra-substituters = https://anmonteiro.nix-cache.workers.dev
extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY=
- run: nix develop -i -c make test
fmt:
name: Format
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v4
- uses: cachix/install-nix-action@v31
with:
extra_nix_config: |
extra-substituters = https://anmonteiro.nix-cache.workers.dev
extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY=
- run: nix develop .#fmt -c make fmt
doc:
name: Documentation
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v4
- uses: cachix/install-nix-action@v31
with:
extra_nix_config: |
extra-substituters = https://anmonteiro.nix-cache.workers.dev
extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY=
- run: nix develop .#doc -c make doc
env:
LC_ALL: C
#
# Stage 2
#
build:
name: Build
# we only start building our other jobs, once our main tests have passed
needs: nix-test
strategy:
fail-fast: false
matrix:
# Please keep the list in sync with the minimal version of OCaml in
# dune-project, dune.opam.template and bootstrap.ml
#
# We don't run tests on all versions of the Windows environment and on
# 4.02.x and 4.07.x in other environments
include:
# OCaml trunk:
- ocaml-compiler: ocaml-variants.5.4.0+trunk
os: ubuntu-latest
# OCaml 5:
## ubuntu (x86)
- ocaml-compiler: 5.3.x
os: ubuntu-latest
run_tests: true
## macos (Apple Silicon)
- ocaml-compiler: 5.3.x
os: macos-latest
run_tests: true
## macos (x86)
- ocaml-compiler: 5.3.x
os: macos-13
## MSVC
- ocaml-compiler: ocaml-compiler.5.3.0,system-msvc
os: windows-latest
run_tests: true
## mingw
- ocaml-compiler: ocaml-base-compiler.5.3.0,system-mingw
os: windows-latest
run_tests: true
# OCaml 4:
## ubuntu (x86)
- ocaml-compiler: 4.14.x
os: ubuntu-latest
## ubuntu (x86-32)
- ocaml-compiler: "ocaml-variants.4.14.2+options,ocaml-option-32bit"
os: ubuntu-latest
apt_update: true
## macos (Apple Silicon)
- ocaml-compiler: 4.14.x
os: macos-latest
# OCaml 4.08:
## ubuntu (x86)
- ocaml-compiler: 4.08.x
os: ubuntu-latest
runs-on: ${{ matrix.os }}
steps:
- name: Checkout code
uses: actions/checkout@v4
# The 32 bit gcc/g++ packages are by default out-of-date so we need to
# manually update our package listing.
- name: Update apt package listing
if: ${{ matrix.apt_update == true }}
run: sudo apt update
- name: Use OCaml ${{ matrix.ocaml-compiler }}
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: ${{ matrix.ocaml-compiler }}
# Install ocamlfind-secondary and ocaml-secondary-compiler, if needed
- run: opam install ./dune.opam --deps-only --with-test
- name: Install system deps on macOS
run: brew install coreutils pkg-config file
if: ${{ matrix.os == 'macos-latest' }}
# dune doesn't have any additional dependencies so we can build it right
# away this makes it possible to see build errors as soon as possible
- run: opam exec -- make release
- name: Install deps
# CR-soon Alizter: Lwt 5.9.2 breaks on msvc so we pin it here. Remove
# this when https://github.com/ocsigen/lwt/issues/1071 is fixed.
run: |
opam pin add lwt 5.9.1 --no-action
opam install . --deps-only --with-test
opam exec -- make dev-deps
if: ${{ matrix.run_tests }}
- name: Run test suite on Unix
run: opam exec -- make test
if: ${{ matrix.os != 'windows-latest' && matrix.run_tests }}
- name: Run test suite on Win32
run: opam exec -- make test-windows
if: ${{ matrix.os == 'windows-latest' && matrix.run_tests }}
# We never build configurator
- name: Build configurator
run: opam install ./dune-configurator.opam
if: ${{ matrix.configurator == true }}
coq:
name: Coq 8.16.1
needs: nix-build
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v4
- uses: cachix/install-nix-action@v31
with:
extra_nix_config: |
extra-substituters = https://anmonteiro.nix-cache.workers.dev
extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY=
- run: nix develop .#coq -c make test-coq
env:
# We disable the Dune cache when running the tests
DUNE_CACHE: disabled
wasm:
name: Wasm_of_ocaml
needs: nix-build
runs-on: ubuntu-latest
steps:
- name: Install Node
uses: actions/setup-node@v4
with:
node-version: latest
- name: Set-up Binaryen
uses: Aandreba/setup-binaryen@v1.0.0
with:
token: ${{ github.token }}
- name: Checkout Code
uses: actions/checkout@v4
- name: Use OCaml 5.2.x
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: 5.2.x
- name: Install faked binaryen-bin package
# The binaries have already been downloaded
run: opam install --fake binaryen-bin
- name: Install Wasm_of_ocaml
run: opam install "wasm_of_ocaml-compiler>=6.1"
- name: Set Git User
run: |
git config --global user.name github-actions[bot]
git config --global user.email github-actions[bot]@users.noreply.github.com
- name: Run Tests
run: opam exec -- make test-wasm
cygwin:
name: Cygwin Build
runs-on: windows-latest
steps:
- uses: actions/checkout@v4
- name: Setup Cygwin
uses: cygwin/cygwin-install-action@v6
with:
packages: ocaml gcc-core make
- name: Bootstrap Dune
run: make bootstrap
## In order to build dune locally we need to have the re library
## available. Even if we do, it is likely that our vendored blake3 rules
## will miss cygwin support. So for now, we don't enable the rest.
# - name: Build Dune
# run: _boot/dune build dune.install
create-local-opam-switch:
name: Create local opam switch
needs: nix-build
strategy:
fail-fast: true
matrix:
os:
- macos-latest
- ubuntu-latest
ocaml-compiler:
- 5
- 4.14
runs-on: ${{ matrix.os }}
steps:
- name: Use OCaml ${{ matrix.ocaml-compiler }}
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: ${{ matrix.ocaml-compiler }}
- uses: actions/checkout@v4
- name: Create an empty switch
run: opam switch create . --empty
- name: Pin local packages to local dependencies
run: opam pin add . -n --with-version=dev
- name: Install external dependencies
run: opam install .
build-microbench:
name: Build microbenchmarks
needs: nix-build
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v4
- uses: cachix/install-nix-action@v31
with:
extra_nix_config: |
extra-substituters = https://anmonteiro.nix-cache.workers.dev
extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY=
- run: nix develop .#microbench -c make dune build bench/micro

29
unikernel/duniverse/dune_/.gitignore vendored Normal file
View file

@ -0,0 +1,29 @@
_opam
_build
_boot
_test_boot
_perf
_coverage
__pycache__
*.install
# vim swap files
*.swp
*.swo
# emacs lock files
.#*
# vscode settings
.vscode
# git-ps hooks
.git-ps
.duneboot.*
Makefile.dev
src/dune_rules/setup.ml
result
.DS_Store
nix/profiles/

3
unikernel/duniverse/dune_/.ocamlformat Normal file
View file

@ -0,0 +1,3 @@
version=0.27.0
profile=janestreet
ocaml-version=4.08.0

3
unikernel/duniverse/dune_/.ocamlformat-ignore Normal file
View file

@ -0,0 +1,3 @@
boot/libs.ml
src/dune_rules/assets.ml
src/dune_rules/setup.defaults.ml

1
unikernel/duniverse/dune_/.ocp-indent Normal file
View file

@ -0,0 +1 @@
JaneStreet

17
unikernel/duniverse/dune_/.readthedocs.yaml Normal file
View file

@ -0,0 +1,17 @@
version: 2
build:
os: "ubuntu-22.04"
tools:
python: "3.10"
sphinx:
configuration: doc/conf.py
formats:
- pdf
- epub
python:
install:
- requirements: doc/requirements.txt

4880
unikernel/duniverse/dune_/CHANGES.md Normal file
View file

File diff suppressed because it is too large Load diff

7
unikernel/duniverse/dune_/CODE_OF_CONDUCT.md Normal file
View file

@ -0,0 +1,7 @@
# Code of Conduct
This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md).
# Enforcement
This project follows the OCaml Code of Conduct [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement).

89
unikernel/duniverse/dune_/CONTRIBUTING.md Normal file
View file

@ -0,0 +1,89 @@
Dune is an community orientated open source project. It was originally
developed at [Jane Street][js] and is now maintained by Jane Street,
[Tarides][tarides] as well as several developers from the OCaml
community.
Contributions to Dune are welcome and should be submitted via GitHub
pull requests against the `main` branch. See [./doc/hacking.rst][hack]
for a guide to getting started on the code base.
Dune is distributed under the MIT license and contributors are
required to sign their work in order to certify that they have the
right to submit it under this license. See the following section for
more details.
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`.
It is possible to set up `git` so that it signs off automatically by using a
prepare-commit-msg hook in git. See <https://stackoverflow.com/a/46536244> for
details. As noted in the manual for `format.signOff`, note that adding the
`Signed-off-by` trailer should be a conscious act and means that you certify
you have the rights to submit this work under the same open source license.
[dco]: http://developercertificate.org/
[js]: https://www.janestreet.com/
[tarides]: https://tarides.com/
[hack]: ./doc/hacking.rst
Coding style
------------
- wrap lines at 80 characters,
- use `[Ss]nake_case` over `[Pp]ascalCase`.

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

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

178
unikernel/duniverse/dune_/Makefile Normal file
View file

@ -0,0 +1,178 @@
.DEFAULT_GOAL := help
PREFIX_ARG := $(if $(PREFIX),--prefix $(PREFIX),)
LIBDIR_ARG := $(if $(LIBDIR),--libdir $(LIBDIR),)
DESTDIR_ARG := $(if $(DESTDIR),--destdir $(DESTDIR),)
INSTALL_ARGS := $(PREFIX_ARG) $(LIBDIR_ARG) $(DESTDIR_ARG)
BIN := ./_boot/dune.exe
# Dependencies recommended for developing dune locally,
# but not wanted in CI
DEV_DEPS := \
core_bench \
patdiff
TEST_OCAMLVERSION := 5.3.0
# When updating this version, don't forget to also bump the number in the docs.
-include Makefile.dev
.PHONY: help
help:
@cat doc/make-help.txt
.PHONY: bootstrap
bootstrap:
$(MAKE) -B $(BIN)
.PHONY: test-bootstrap
test-bootstrap:
@ocaml boot/bootstrap.ml --boot-dir _test_boot
.PHONY: release
release: $(BIN)
@$(BIN) build @install -p dune --profile dune-bootstrap
$(BIN):
@ocaml boot/bootstrap.ml
dev: $(BIN)
$(BIN) build @install
watch: $(BIN)
$(BIN) build @install --watch
all: $(BIN)
$(BIN) build
.PHONY: install
install:
$(BIN) install $(INSTALL_ARGS) dune
.PHONY: uninstall
uninstall:
$(BIN) uninstall $(INSTALL_ARGS) dune
.PHONY: reinstall
reinstall: uninstall install
.PHONY: install-ocamlformat
install-ocamlformat:
opam install -y ocamlformat.$$(awk -F = '$$1 == "version" {print $$2}' .ocamlformat)
.PHONY: dev-deps
dev-deps:
opam install -y . --deps-only --with-dev-setup
.PHONY: dev-deps-sans-melange
dev-deps-sans-melange: dev-deps
.PHONY: dev-switch
dev-switch:
opam update
# Ensuring that either a dev switch already exists or a new one is created
if test -d _opam ; then \
opam install -y --update-invariant ocaml.$(TEST_OCAMLVERSION); \
else \
opam switch create -y . $(TEST_OCAMLVERSION) --no-install ; \
fi
opam pin add -y . -n --with-version=dev
opam install -y . --deps-only --with-test --with-dev-setup
$(MAKE) install-ocamlformat
opam install -y $(DEV_DEPS)
.PHONY: test
test: $(BIN)
$(BIN) runtest
test-windows: $(BIN)
$(BIN) build @runtest-windows
test-js: $(BIN)
$(BIN) build @runtest-js
test-wasm: $(BIN)
DUNE_WASM_TEST=enable $(BIN) build @runtest-wasm
test-coq: $(BIN)
DUNE_COQ_TEST=enable $(BIN) build @runtest-coq
test-melange: $(BIN)
$(BIN) build @runtest-melange
test-all: $(BIN)
$(BIN) build @runtest @runtest-js @runtest-coq @runtest-melange
test-all-sans-melange: $(BIN)
$(BIN) build @runtest @runtest-js @runtest-coq
.PHONY: check
check: $(BIN)
@$(BIN) build @check
.PHONY: fmt
fmt: $(BIN)
@$(BIN) fmt
.PHONY: promote
promote: $(BIN)
@$(BIN) promote
.PHONY: accept-corrections
accept-corrections: promote
.PHONY: clean
clean:
rm -rf _boot _build
distclean: clean
rm -f src/dune_rules/setup.ml
.PHONY: doc
doc:
sphinx-build -W doc doc/_build
# livedoc-deps: you may need to [pip3 install sphinx-autobuild] and [pip3 install -r doc/requirements.txt]
livedoc:
cd doc && sphinx-autobuild . _build --port 8888 -q --re-ignore '\.#.*'
update-jbuilds: $(BIN)
$(BIN) build @doc/runtest --auto-promote
# If the first argument is "run"...
ifeq (dune,$(firstword $(MAKECMDGOALS)))
# use the rest as arguments for "run"
RUN_ARGS := $(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS))
# ...and turn them into do-nothing targets
$(eval $(RUN_ARGS):;@:)
endif
.PHONY: bench
bench: $(BIN)
@$(BIN) exec -- ./bench/bench.exe $(BIN)
.PHONY: dune
dune: $(BIN)
$(BIN) $(RUN_ARGS)
# Use this target to make sure that we always run the in source dune when making
# the release
.PHONY: opam-release
opam-release: dev
$(BIN) exec -- $(MAKE) dune-release
dune-release:
dune-release tag
dune-release distrib --skip-build --skip-lint --skip-tests
# See https://github.com/ocamllabs/dune-release/issues/206
DUNE_RELEASE_DELEGATE=github-dune-release-delegate dune-release publish --verbose
dune-release opam pkg
dune-release opam submit
.PHONY: docker-build-image
docker-build-image:
docker build -f docker/dev.Dockerfile -t dune .
.PHONY: docker-compose
docker-compose:
docker compose -f docker/dev.yml run dune bash

152
unikernel/duniverse/dune_/README.md Normal file
View file

@ -0,0 +1,152 @@
![Dune][logo]
# A Composable Build System for OCaml
[![Main Workflow][workflow-badge]][workflow]
[![Release][release-badge]][release]
[![License][license-badge]][license]
[![Contributors][contributors-badge]][contributors]
[logo]: doc/assets/imgs/dune_logo_459x116.png
[workflow]: https://github.com/ocaml/dune/actions/workflows/workflow.yml
[workflow-badge]: https://img.shields.io/github/actions/workflow/status/ocaml/dune/workflow.yml?label=CI&logo=github
[release]: https://github.com/ocaml/dune/releases/latest
[release-badge]: https://img.shields.io/github/v/release/ocaml/dune?label=release
[license]: https://github.com/ocaml/dune/blob/main/LICENSE.md
[license-badge]: https://img.shields.io/github/license/ocaml/dune
[contributors]: https://github.com/ocaml/dune/graphs/contributors
[contributors-badge]: https://img.shields.io/github/contributors-anon/ocaml/dune
Dune is a build system for OCaml. It provides a consistent experience and takes
care of the low-level details of OCaml compilation. You need only to provide a
description of your project, and Dune will do the rest.
Dune implements a scheme that's inspired from the one used inside Jane Street
and adapted to the open source world. It has matured over a long time and is
used daily by hundreds of developers, meaning it's highly tested and productive.
Dune comes with a [manual][manual]. If you want to get started without reading
too much, look at the [quick start guide][quick-start] or watch [this
introduction video][video].
The [example][example] directory contains examples of projects using Dune.
[manual]: https://dune.readthedocs.io/en/latest/
[quick-start]: https://dune.readthedocs.io/en/latest/quick-start.html
[example]: https://github.com/ocaml/dune/tree/main/example
[merlin]: https://github.com/ocaml/merlin
[opam]: https://opam.ocaml.org
[issues]: https://github.com/ocaml/dune/issues
[discussions]: https://github.com/ocaml/dune/discussions
[dune-release]: https://github.com/ocamllabs/dune-release
[video]: https://youtu.be/BNZhmMAJarw
# How does it work?
Dune reads project metadata from `dune` files, which are static files with a
simple S-expression syntax. It uses this information to setup build rules,
generate configuration files for development tools such as [Merlin][merlin],
handle installation, etc.
Dune itself is fast, has very little overhead, and supports parallel builds on
all platforms. It has no system dependencies. OCaml is all you need to build
Dune and packages using Dune.
In particular, one can install OCaml on Windows with a binary installer and then
use only the Windows Console to build Dune and packages using Dune.
# Strengths
## Composable
Dune is composable, meaning that multiple Dune projects can be arranged
together, leading to a single build that Dune knows how to execute. This allows
for monorepos of projects.
Dune makes simultaneous development on multiple packages a trivial task.
## Gracefully Handles Multi-Package Repositories
Dune knows how to handle repositories containing several packages. When building
via [opam][opam], it is able to correctly use libraries that were previously
installed, even if they are already present in the source tree.
The magic invocation is:
```console
$ dune build --only-packages <package-name> @install
```
## Build Against Several Configurations at Once
Dune can build a given source code repository against several configurations
simultaneously. This helps maintaining packages across several versions of
OCaml, as you can test them all at once without hassle.
In particular, this makes it easy to handle
[cross-compilation][cross-compilation]. This feature requires [opam][opam].
[cross-compilation]: https://dune.readthedocs.io/en/latest/cross-compilation.html
# Installation
## Requirements
Dune requires OCaml version 4.08.0 to build itself and can build OCaml projects
using OCaml 4.02.3 or greater.
## Installation
We recommended installing Dune via the [opam package manager][opam]:
```console
$ opam install dune
```
If you are new to opam, make sure to run `eval $(opam config env)` to make
`dune` available in your `PATH`. The `dune` binary is self-contained and
relocatable, so you can safely copy it somewhere else to make it permanently
available.
You can also build it manually with:
```console
$ make release
$ make install
```
If you do not have `make`, you can do the following:
```console
$ ocaml boot/bootstrap.ml
$ ./dune.exe build -p dune --profile dune-bootstrap
$ ./dune.exe install dune
```
The first command builds the `dune.exe` binary. The second builds the additional
files installed by Dune, such as the _man_ pages, and the last simply installs
all of that on the system.
**Please note**: unless you ran the optional `./configure` script, you can
simply copy `dune.exe` anywhere and it will just work. `dune` is fully
relocatable and discovers its environment at runtime rather than hard-coding it
at compilation time.
# Support
[![Issues][issues-badge]][issues]
[![Discussions][discussions-badge]][discussions]
[![Discuss OCaml][discuss-ocaml-badge]][discuss-ocaml]
[![Discord][discord-badge]][discord]
If you have questions or issues about Dune, you can ask in [our GitHub
discussions page][discussions] or [open a ticket on GitHub][issues].
[discussions]: https://github.com/ocaml/dune/discussions
[discussions-badge]: https://img.shields.io/github/discussions/ocaml/dune?logo=github
[issues]: https://github.com/ocaml/dune/issues
[issues-badge]: https://img.shields.io/github/issues/ocaml/dune?logo=github
[discuss-ocaml]: https://discuss.ocaml.org
[discuss-ocaml-badge]: https://img.shields.io/discourse/topics?server=https%3A%2F%2Fdiscuss.ocaml.org%2F
[discord]: https://discord.com/invite/cCYQbqN
[discord-badge]: https://img.shields.io/discord/436568060288172042?logo=discord

4
unikernel/duniverse/dune_/bench.Dockerfile Normal file
View file

@ -0,0 +1,4 @@
FROM ocaml/opam:debian-12-ocaml-4.14
RUN opam depext -u patdiff.v0.15.0
COPY --chown=opam:opam . bench-dir
WORKDIR bench-dir

275
unikernel/duniverse/dune_/bench/bench.ml Normal file
View file

@ -0,0 +1,275 @@
open Stdune
module Process = Dune_engine.Process
module Console = struct
include Dune_console
let printf fmt = printf ("[Bench] " ^^ fmt)
end
module Json = struct
include Chrome_trace.Json
include Dune_stats.Json
end
module Output = struct
type measurement =
[ `Int of int
| `Float of float
]
type bench =
{ name : string
; metrics : (string * [ measurement | `List of measurement list ] * string) list
}
let json_of_bench { name; metrics } : Json.t =
let metrics =
List.map metrics ~f:(fun (name, value, units) ->
let value =
match value with
| `Int i -> `Int i
| `Float f -> `Float f
| `List xs -> `List (xs :> Json.t list)
in
`Assoc [ "name", `String name; "value", value; "units", `String units ])
in
`Assoc [ "name", `String name; "metrics", `List metrics ]
;;
type t =
{ config : (string * Json.t) list
; version : int
; results : bench list
}
let to_json { config; version; results } : Json.t =
let assoc = [ "results", `List (List.map results ~f:json_of_bench) ] in
let assoc = ("version", `Int version) :: assoc in
let assoc =
match config with
| [] -> assoc
| _ :: _ -> ("config", `Assoc config) :: assoc
in
`Assoc assoc
;;
end
let git =
lazy
(let path = Env.get Env.initial "PATH" |> Option.value_exn |> Bin.parse_path in
Bin.which ~path "git" |> Option.value_exn)
;;
let dune = Path.of_string (Filename.concat Fpath.initial_cwd Sys.argv.(1))
let output_limit = Dune_engine.Execution_parameters.Action_output_limit.default
let make_stdout () = Process.Io.make_stdout ~output_on_success:Swallow ~output_limit
let make_stderr () = Process.Io.make_stderr ~output_on_success:Swallow ~output_limit
module Package = struct
type t =
{ org : string
; name : string
}
let uri { org; name } = sprintf "https://github.com/%s/%s" org name
let make org name = { org; name }
let clone t =
let stdout_to = make_stdout () in
let stderr_to = make_stderr () in
let stdin_from = Process.Io.(null In) in
Process.run
Strict
~display:Quiet
~stdout_to
~stderr_to
~stdin_from
(Lazy.force git)
[ "clone"; uri t ]
;;
end
let duniverse =
let pkg = Package.make in
[ pkg "ocaml-dune" "dune-bench" ]
;;
let prepare_workspace () =
Fiber.parallel_iter duniverse ~f:(fun (pkg : Package.t) ->
Fpath.rm_rf pkg.name;
Console.printf "cloning %s/%s" pkg.org pkg.name;
Fiber.finalize
(fun () -> Package.clone pkg)
~finally:(fun () ->
Fiber.return @@ Console.printf "finished cloning %s/%s" pkg.org pkg.name))
;;
let dune_build ~name ~sandbox =
let stdin_from = Process.(Io.null In) in
let stdout_to = make_stdout () in
let stderr_to = make_stderr () in
let gc_dump = Temp.create File ~prefix:"gc_stat" ~suffix:name in
let open Fiber.O in
(* Build with timings and gc stats *)
let+ times =
Process.run_with_times
Strict
dune
~display:Quiet
~stdin_from
~stdout_to
~stderr_to
([ "build"
; "@install"
; "--release"
; "--cache" (* explicitly disable cache *)
; "disabled"
; "--dump-gc-stats"
; Path.to_string gc_dump
]
@
match sandbox with
| `Yes -> [ "--sandbox"; "hardlink" ]
| `No -> [])
in
(* Read the gc stats from the dump file *)
Dune_lang.Parser.parse_string
~mode:Single
~fname:(Path.to_string gc_dump)
(Io.read_file gc_dump)
|> Dune_lang.Decoder.parse Dune_util.Gc.decode Univ_map.empty
|> Metrics.make times
;;
let run_bench ~sandbox =
let open Fiber.O in
let* clean = dune_build ~name:"clean" ~sandbox in
let+ zero =
let rec zero acc n =
if n = 0
then Fiber.return (List.rev acc)
else
let* time = dune_build ~name:("zero" ^ string_of_int n) ~sandbox in
zero (time :: acc) (pred n)
in
zero [] 5
in
clean, zero
;;
type ('float, 'int) bench_results =
{ size : int
; clean : ('float, 'int) Metrics.t
; zero : ('float, 'int) Metrics.t list
}
let tag_results { size; clean; zero } =
let tag data = Metrics.map ~f:(fun t -> `Float t) ~g:(fun t -> `Int t) data in
let list_tag data =
List.map data ~f:tag
|> Metrics.unzip
|> Metrics.map ~f:(fun x -> `List x) ~g:(fun x -> `List x)
in
`Int size, tag clean, list_tag zero
;;
(** Display all clean and null builds with a few exceptions:
- fragments - not consistent between builds
- stack_size - not very useful
- forced_collections - only available in OCaml >= 4.12 *)
let display_clean_and_zero_with_sandboxing
({ elapsed_time
; user_cpu_time
; system_cpu_time
; minor_words
; promoted_words
; major_words
; minor_collections
; major_collections
; heap_words
; heap_chunks
; live_words
; live_blocks
; free_words
; free_blocks
; largest_free
; fragments = _
; compactions
; top_heap_words
; stack_size = _
} :
_ Metrics.t)
(zero : _ Metrics.t)
=
let display what units clean zero =
{ Output.name = what
; metrics = [ "[Clean] " ^ what, clean, units; "[Null] " ^ what, zero, units ]
}
in
[ display "Build Time" "Seconds" elapsed_time zero.elapsed_time
; display "Minor Words" "Approx. Words" minor_words zero.minor_words
; display "Promoted Words" "Approx. Words" promoted_words zero.promoted_words
; display "Major Words" "Approx. Words" major_words zero.major_words
; display "Minor Collections" "Collections" minor_collections zero.minor_collections
; display "Major Collections" "Collections" major_collections zero.major_collections
; display "Heap Words" "Words" heap_words zero.heap_words
; display "Heap Chunks" "Chunks" heap_chunks zero.heap_chunks
; display "Live Words" "Words" live_words zero.live_words
; display "Live Blocks" "Blocks" live_blocks zero.live_blocks
; display "Free Words" "Words" free_words zero.free_words
; display "Free Blocks" "Blocks" free_blocks zero.free_blocks
; display "Largest Free" "Words" largest_free zero.largest_free
; display "Compactions" "Compactions" compactions zero.compactions
; display "Top Heap Words" "Words" top_heap_words zero.top_heap_words
; display "User CPU Time" "Seconds" user_cpu_time zero.user_cpu_time
; display "System CPU Time" "Seconds" system_cpu_time zero.system_cpu_time
]
;;
let format_results bench_results =
(* tagging data for json conversion *)
let size, clean, zero = tag_results bench_results in
(* bench results *)
[ { Output.name = "Misc"; metrics = [ "Size of _boot/dune.exe", size, "Bytes" ] } ]
@ display_clean_and_zero_with_sandboxing clean zero
;;
let () =
Dune_util.Log.init ~file:No_log_file ();
let dir = Temp.create Dir ~prefix:"dune" ~suffix:"bench" in
Sys.chdir (Path.to_string dir);
Path.as_external dir |> Option.value_exn |> Path.set_root;
Path.Build.set_build_dir (Path.Outside_build_dir.of_string "_build");
let module Scheduler = Dune_engine.Scheduler in
let config =
Dune_engine.Clflags.display := Quiet;
{ Scheduler.Config.concurrency = 10
; stats = None
; print_ctrl_c_warning = false
; watch_exclusions = []
}
in
let size =
let stat : Unix.stats = Path.stat_exn dune in
stat.st_size
in
let results =
Scheduler.Run.go config ~on_event:(fun _ _ -> ())
@@ fun () ->
let open Fiber.O in
(* Prepare the workspace *)
let* () = prepare_workspace () in
(* Build the clean and null builds *)
Console.printf "Building clean and null builds";
let+ clean, zero = run_bench ~sandbox:`No in
Console.printf "Finished building clean and null builds";
(* Return the bench results *)
format_results { size; clean; zero }
in
let version = 4 in
let output = { Output.config = []; version; results } in
print_string (Json.to_string (Output.to_json output));
flush stdout
;;

0
unikernel/duniverse/dune_/bench/bench.mli Normal file
View file

27
unikernel/duniverse/dune_/bench/dune Normal file
View file

@ -0,0 +1,27 @@
(executable
(name bench)
(modules bench metrics)
(libraries
dune_stats
dune_console
chrome_trace
stdune
fiber
dune_lang
dune_engine
dune_util))
(rule
(alias bench)
(action
(run ./bench.exe %{bin:dune})))
(executable
(modules gen_synthetic)
(libraries unix)
(name gen_synthetic))
(executable
(modules gen_synthetic_dune_watch)
(libraries unix)
(name gen_synthetic_dune_watch))

40
unikernel/duniverse/dune_/bench/gen-benchmark.sh Executable file
View file

@ -0,0 +1,40 @@
#!/bin/bash
set -eu
usage()
{
cat <<EOF
Usage:
$(basename "${0}") <command> <clean_command> <name>
EOF
}
if [ $# -ne 3 ]; then
usage
exit 1
fi
command="${1}"
clean_command="${2}"
name="${3}"
hyperfine "${command}" \
--show-output \
--warmup 2 \
--runs 3 \
--prepare "${clean_command}" \
--export-json bench.json \
> /dev/null
mean_time=$(cat bench.json | jq '.results[0].mean | tostring')
cat<<EOF
[
{
"name": "${name}",
"unit": "seconds",
"value": ${mean_time}
}
]
EOF

37
unikernel/duniverse/dune_/bench/gen_synthetic.ml Normal file
View file

@ -0,0 +1,37 @@
open Printf
let write_modules basedir num_modules =
for current_mod = 1 to num_modules do
let modname = sprintf "%s/m_%d" basedir current_mod in
let f = open_out (sprintf "%s.ml" modname) in
close_out f
done
;;
let dune =
{|
(library
(name test))
|}
;;
let write basedir =
let () = Unix.mkdir basedir 0o777 in
let f = open_out (Filename.concat basedir "dune") in
output_string f dune;
let () = close_out f in
write_modules basedir
;;
let () =
let basedir = ref "." in
let num_modules = ref 0 in
Arg.parse
[ ( "-n"
, Arg.Int (fun n -> num_modules := n)
, "<n> number of modules to include in the synthetic library" )
]
(fun d -> basedir := d)
(sprintf "usage: %s [basedir]" (Filename.basename Sys.argv.(0)));
write !basedir !num_modules
;;

96
unikernel/duniverse/dune_/bench/gen_synthetic_dune_watch.ml Normal file
View file

@ -0,0 +1,96 @@
open Printf
type lib =
| Leaf
| Internal
let subsets_per_library = 4
let count n = Array.to_list (Array.init n (fun k -> k + 1))
let write_subset base_dir library_index subset =
let mod_rows = 10 in
let mod_cols = 10 in
for row = 1 to mod_rows do
for col = 1 to mod_cols do
let deps =
if row = 1
then
if library_index = 1
then []
else
List.flatten
(List.map
(fun k ->
List.map
(fun j ->
sprintf "M_%d_%d_%d_%d.f()" (library_index - 1) j mod_rows k)
(count subsets_per_library))
(count mod_cols))
else
List.map
(fun k -> sprintf "M_%d_%d_%d_%d.f()" library_index subset (row - 1) k)
(count mod_cols)
in
let deps = List.rev ("()" :: List.rev deps) in
let str_deps = String.concat ";\n " deps in
let mod_text = sprintf "let f() =\n %s\n" str_deps in
let modname = sprintf "%s/m_%d_%d_%d_%d" base_dir library_index subset row col in
let f = open_out (sprintf "%s.ml" modname) in
output_string f mod_text;
close_out f;
let f = open_out (sprintf "%s.mli" modname) in
output_string f "val f : unit -> unit";
close_out f
done
done
;;
let write_lib ~base_dir ~lib ~dune =
let name =
match lib with
| Leaf -> "leaf"
| Internal -> "internal"
in
let lib_dir = Filename.concat base_dir name in
let () = Unix.mkdir lib_dir 0o777 in
let f = open_out (Filename.concat lib_dir "dune") in
output_string f dune;
let () = close_out f in
let library_index =
match lib with
| Leaf -> 2
| Internal -> 1
in
for subset = 1 to subsets_per_library do
write_subset lib_dir library_index subset
done
;;
let write base_dir =
let () = Unix.mkdir base_dir 0o777 in
let dune =
{|
(library
(name leaf)
(libraries internal))
|}
in
write_lib ~base_dir ~lib:Leaf ~dune;
let dune =
{|
(library
(name internal)
(wrapped false))
|}
in
write_lib ~base_dir ~lib:Internal ~dune
;;
let () =
let base_dir = ref "." in
Arg.parse
[]
(fun d -> base_dir := d)
(sprintf "usage: %s [base_dir]" (Filename.basename Sys.argv.(0)));
write !base_dir
;;

125
unikernel/duniverse/dune_/bench/metrics.ml Normal file
View file

@ -0,0 +1,125 @@
open Stdune
type ('float, 'int) t =
{ elapsed_time : 'float
; user_cpu_time : 'float
; system_cpu_time : 'float
; minor_words : 'float
; promoted_words : 'float
; major_words : 'float
; minor_collections : 'int
; major_collections : 'int
; heap_words : 'int
; heap_chunks : 'int
; live_words : 'int
; live_blocks : 'int
; free_words : 'int
; free_blocks : 'int
; largest_free : 'int
; fragments : 'int
; compactions : 'int
; top_heap_words : 'int
; stack_size : 'int
}
let make (times : Proc.Times.t) (gc : Gc.stat) =
(* We default to 0 for the other processor times since they are rarely None in
pracice. *)
let { Proc.Resource_usage.user_cpu_time; system_cpu_time } =
Option.value
times.resource_usage
~default:{ user_cpu_time = 0.; system_cpu_time = 0. }
in
{ elapsed_time = times.elapsed_time
; user_cpu_time
; system_cpu_time
; minor_words = gc.minor_words
; promoted_words = gc.promoted_words
; major_words = gc.major_words
; minor_collections = gc.minor_collections
; major_collections = gc.major_collections
; heap_words = gc.heap_words
; heap_chunks = gc.heap_chunks
; live_words = gc.live_words
; live_blocks = gc.live_blocks
; free_words = gc.free_words
; free_blocks = gc.free_blocks
; largest_free = gc.largest_free
; fragments = gc.fragments
; compactions = gc.compactions
; top_heap_words = gc.top_heap_words
; stack_size = gc.stack_size
}
;;
let map ~f ~g (metrics : ('float, 'int) t) : ('float_, 'int_) t =
{ elapsed_time = f metrics.elapsed_time
; user_cpu_time = f metrics.user_cpu_time
; system_cpu_time = f metrics.system_cpu_time
; minor_words = f metrics.minor_words
; promoted_words = f metrics.promoted_words
; major_words = f metrics.major_words
; minor_collections = g metrics.minor_collections
; major_collections = g metrics.major_collections
; heap_words = g metrics.heap_words
; heap_chunks = g metrics.heap_chunks
; live_words = g metrics.live_words
; live_blocks = g metrics.live_blocks
; free_words = g metrics.free_words
; free_blocks = g metrics.free_blocks
; largest_free = g metrics.largest_free
; fragments = g metrics.fragments
; compactions = g metrics.compactions
; top_heap_words = g metrics.top_heap_words
; stack_size = g metrics.stack_size
}
;;
(** Turns a list of records into a record of lists. *)
let unzip (metrics : ('float, 'int) t list) : ('float list, 'int list) t =
List.fold_left
metrics
~init:
{ elapsed_time = []
; user_cpu_time = []
; system_cpu_time = []
; minor_words = []
; promoted_words = []
; major_words = []
; minor_collections = []
; major_collections = []
; heap_words = []
; heap_chunks = []
; live_words = []
; live_blocks = []
; free_words = []
; free_blocks = []
; largest_free = []
; fragments = []
; compactions = []
; top_heap_words = []
; stack_size = []
}
~f:(fun acc x ->
{ elapsed_time = x.elapsed_time :: acc.elapsed_time
; user_cpu_time = x.user_cpu_time :: acc.user_cpu_time
; system_cpu_time = x.system_cpu_time :: acc.system_cpu_time
; minor_words = x.minor_words :: acc.minor_words
; promoted_words = x.promoted_words :: acc.promoted_words
; major_words = x.major_words :: acc.major_words
; minor_collections = x.minor_collections :: acc.minor_collections
; major_collections = x.major_collections :: acc.major_collections
; heap_words = x.heap_words :: acc.heap_words
; heap_chunks = x.heap_chunks :: acc.heap_chunks
; live_words = x.live_words :: acc.live_words
; live_blocks = x.live_blocks :: acc.live_blocks
; free_words = x.free_words :: acc.free_words
; free_blocks = x.free_blocks :: acc.free_blocks
; largest_free = x.largest_free :: acc.largest_free
; fragments = x.fragments :: acc.fragments
; compactions = x.compactions :: acc.compactions
; top_heap_words = x.top_heap_words :: acc.top_heap_words
; stack_size = x.stack_size :: acc.stack_size
})
|> map ~f:List.rev ~g:List.rev
;;

66
unikernel/duniverse/dune_/bench/metrics.mli Normal file
View file

@ -0,0 +1,66 @@
open Stdune
(** [('float, 'int) t] is a record of metrics about the current process. It
includes timing information and information available from [Gc.stat]. It is
polymorphic in the type of field values to allow for the definition of
[unzip] functions which make serialisation easier. *)
type ('float, 'int) t =
{ elapsed_time : 'float
(** Real time elapsed since the process started and the process
finished. *)
; user_cpu_time : 'float
(** The amount of CPU time spent in user mode during the process. Other
processes and blocked time are not included. *)
; system_cpu_time : 'float
(** The amount of CPU time spent in kernel mode during the process.
Similar to user time, other processes and time spent blocked by
other processes are not counted. *)
; minor_words : 'float
(** Number of words allocated in the minor heap since the program was
started. *)
; promoted_words : 'float
(** Number of words that have been promoted from the minor to the major
heap since the program was started. *)
; major_words : 'float
(** Number of words allocated in the major heap since the program was
started. *)
; minor_collections : 'int
(** Number of minor collections since the program was started. *)
; major_collections : 'int
(** Number of major collection cycles completed since the program was
started. *)
; heap_words : 'int (** Total size of the major heap, in words. *)
; heap_chunks : 'int
(** Number of contiguous pieces of memory that make up the major heap. *)
; live_words : 'int
(** Number of words of live data in the major heap, including the header
words. *)
; live_blocks : 'int (** Number of live blocks in the major heap. *)
; free_words : 'int (** Number of words in the free list. *)
; free_blocks : 'int (** Number of blocks in the free list. *)
; largest_free : 'int (** Size (in words) of the largest block in the free list. *)
; fragments : 'int
(** Number of wasted words due to fragmentation. These are 1-words free
blocks placed between two live blocks. They are not available for
allocation. *)
; compactions : 'int (** Number of heap compactions since the program was started. *)
; top_heap_words : 'int (** Maximum size reached by the major heap, in words. *)
; stack_size : 'int (** Current size of the stack, in words. *)
}
(** [make t gc] creates a new metrics record from the given [t] and [gc]
information. *)
val make : Proc.Times.t -> Gc.stat -> (float, int) t
(** [map ~f ~g m] applies [f] to the float fields and [g] to the int fields of
[m]. *)
val map
: f:('float -> 'float_)
-> g:('int -> 'int_)
-> ('float, 'int) t
-> ('float_, 'int_) t
(** [unzip m] takes a list of metrics [m] and returns a records with the lists
of values for each field. This is particularly convenient when serialising
to json. *)
val unzip : ('float, 'int) t list -> ('float list, 'int list) t

28
unikernel/duniverse/dune_/bench/micro/copyfile.ml Normal file
View file

@ -0,0 +1,28 @@
open Stdune
let dir =
(if Array.length Sys.argv > 1
then (
let dir = Path.of_filename_relative_to_initial_cwd Sys.argv.(1) in
Temp.temp_in_dir Dir ~dir)
else Temp.create Dir)
~prefix:"copyfile"
~suffix:"bench"
;;
let contents =
let len =
if Array.length Sys.argv > 2 then Int.of_string_exn Sys.argv.(2) else 50_000
in
String.make len '0'
;;
let () =
let src = Path.relative dir "initial" in
Io.write_file (Path.relative dir "initial") contents;
let chmod _ = 444 in
for i = 1 to 10_000 do
let dst = Path.relative dir (sprintf "dst-%d" i) in
Io.copy_file ~chmod ~src ~dst ()
done
;;

24
unikernel/duniverse/dune_/bench/micro/digest_bench.ml Normal file
View file

@ -0,0 +1,24 @@
open Stdune
module Digest = Dune_digest
module Caml = Stdlib
let create_file size =
let name = Printf.sprintf "digest-bench-%d" size in
let out = open_out name in
for _ = 1 to size do
output_char out 'X'
done;
close_out out;
at_exit (fun () -> Unix.unlink name);
name
;;
let%bench_fun ("string" [@indexed len = [ 10; 100; 1_000; 10_000; 1_000_000 ]]) =
let s = String.make len 'x' in
fun () -> ignore (Digest.string s)
;;
let%bench_fun ("file" [@indexed len = [ 10; 100; 1_000; 10_000; 100_000; 1_000_000 ]]) =
let f = Path.of_filename_relative_to_initial_cwd (create_file len) in
fun () -> ignore (Digest.file f)
;;

1
unikernel/duniverse/dune_/bench/micro/digest_bench_main.ml Normal file
View file

@ -0,0 +1 @@
Inline_benchmarks_public.Runner.main ~libname:"digest_bench"

57
unikernel/duniverse/dune_/bench/micro/dune Normal file
View file

@ -0,0 +1,57 @@
(executable
(name copyfile)
(modules copyfile)
(libraries stdune))
(executable
(name main)
(modules main)
(libraries dune_bench core_bench.inline_benchmarks))
(executable
(name memo_bench_main)
(allow_overlapping_dependencies)
(modules memo_bench_main)
(libraries memo_bench core_bench.inline_benchmarks))
(library
(name thread_pool_bench)
(modules thread_pool_bench)
(library_flags -linkall)
(preprocess
(pps ppx_bench))
(libraries dune_thread_pool unix threads.posix core_bench.inline_benchmarks))
(executable
(name thread_pool_bench_main)
(allow_overlapping_dependencies)
(modules thread_pool_bench_main)
(libraries thread_pool_bench core_bench.inline_benchmarks))
(library
(name digest_bench)
(modules digest_bench)
(library_flags -linkall)
(preprocess
(pps ppx_bench))
(libraries dune_digest stdune unix core_bench.inline_benchmarks))
(executable
(name digest_bench_main)
(allow_overlapping_dependencies)
(modules digest_bench_main)
(libraries digest_bench core_bench.inline_benchmarks))
(library
(name path_bench)
(modules path_bench)
(library_flags -linkall)
(preprocess
(pps ppx_bench))
(libraries base stdune core_bench.inline_benchmarks))
(executable
(name path_bench_main)
(allow_overlapping_dependencies)
(modules path_bench_main)
(libraries path_bench core_bench.inline_benchmarks))

6
unikernel/duniverse/dune_/bench/micro/dune_bench/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name dune_bench)
(libraries stdune fiber dune_engine dune_rules)
(library_flags -linkall)
(preprocess
(pps ppx_bench)))

39
unikernel/duniverse/dune_/bench/micro/dune_bench/scheduler_bench.ml Normal file
View file

@ -0,0 +1,39 @@
(* Benchmark the scheduler *)
open Stdune
open Dune_engine
module Caml = Stdlib
let config =
Dune_engine.Clflags.display := Short;
{ Scheduler.Config.concurrency = 1
; stats = None
; print_ctrl_c_warning = false
; watch_exclusions = []
}
;;
let setup =
lazy
(Path.set_root (Path.External.cwd ());
Path.Build.set_build_dir (Path.Outside_build_dir.of_string "_build"))
;;
let prog = Option.value_exn (Bin.which ~path:(Env_path.path Env.initial) "true")
let run () = Process.run ~display:Quiet ~env:Env.initial Strict prog []
let go ~jobs fiber =
Scheduler.Run.go ~on_event:(fun _ _ -> ()) { config with concurrency = jobs } fiber
;;
let%bench_fun "single" =
Lazy.force setup;
fun () -> go run ~jobs:1
;;
let l = List.init 100 ~f:ignore
let%bench_fun ("many" [@indexed jobs = [ 1; 2; 4; 8 ]]) =
Lazy.force setup;
fun () -> go ~jobs (fun () -> Fiber.parallel_iter l ~f:run)
;;

1
unikernel/duniverse/dune_/bench/micro/main.ml Normal file
View file

@ -0,0 +1 @@
Inline_benchmarks_public.Runner.main ~libname:"dune_bench"

174
unikernel/duniverse/dune_/bench/micro/memo_bench/benchmarks.ml Normal file
View file

@ -0,0 +1,174 @@
open Stdune
let invalidation_acc = ref Memo.Invalidation.empty
module Memo = struct
include Memo
let sample_count =
(* Count number of samples of all lifted computations, to allow simple
detection of looping tests executed by [run] *)
ref 0
;;
let exec build =
(* not expected to be used in re-entrant way *)
sample_count := 0;
Memo.reset !invalidation_acc;
invalidation_acc := Memo.Invalidation.empty;
let fiber = Memo.run build in
Fiber.run fiber ~iter:(fun _ -> failwith "deadlock?")
;;
let memoize t =
let l = Memo.lazy_ ~cutoff:(fun _ _ -> false) (fun () -> t) in
Memo.of_thunk (fun () -> Memo.Lazy.force l)
;;
let map2 x y ~f =
map ~f:(fun (x, y) -> f x y) (Memo.fork_and_join (fun () -> x) (fun () -> y))
;;
let all l = Memo.all_concurrently l
end
let run tenacious = Memo.exec tenacious
module Var = struct
type 'a t =
{ value : 'a ref
; cell : (unit, 'a) Memo.Cell.t
}
let create value =
let value = ref value in
{ value
; cell = Memo.lazy_cell ~cutoff:(fun _ _ -> false) (fun () -> Memo.return !value)
}
;;
let set t v =
t.value := v;
invalidation_acc
:= Memo.Invalidation.combine
!invalidation_acc
(Memo.Cell.invalidate ~reason:Memo.Invalidation.Reason.Test t.cell)
;;
let read t = Memo.of_thunk (fun () -> Memo.Cell.read t.cell)
let peek t = !(t.value)
end
let incr v = Var.set v (Var.peek v)
module Case = struct
(* The first [unit] it to delay the creation of functions until benchmarking
is ready to run. *)
type 'a t =
{ create_and_compute : unit -> unit -> 'a
; incr_and_recompute : unit -> unit -> 'a
; restore_from_cache : unit -> unit -> 'a
}
let create (f : unit -> _ Var.t * 'a Memo.t) : 'a t =
let create_and_compute () () = run (f () |> snd) in
let incr_and_recompute () =
let var, build = f () in
let (_ : 'a) = run build in
fun () ->
incr var;
run build
in
let restore_from_cache () =
let build = f () |> snd in
let (_ : 'a) = run build in
fun () -> run build
in
{ create_and_compute; incr_and_recompute; restore_from_cache }
;;
end
let one_bind =
Case.create (fun () ->
let v = Var.create 0 in
( v
, List.fold_left
~init:(Memo.return 0)
(List.init 1 ~f:(fun _i -> ()))
~f:(fun acc () ->
Memo.bind acc ~f:(fun acc -> Memo.map (Var.read v) ~f:(fun v -> acc + v))) ))
;;
let%bench_fun "1-bind (create and compute)" = one_bind.create_and_compute ()
let%bench_fun "1-bind (incr and recompute)" = one_bind.incr_and_recompute ()
let%bench_fun "1-bind (restore from cache)" = one_bind.restore_from_cache ()
let twenty_reads =
Case.create (fun () ->
let v = Var.create 0 in
( v
, List.fold_left
~init:(Memo.return 0)
(List.init 20 ~f:(fun _i -> ()))
~f:(fun acc () ->
Memo.bind acc ~f:(fun acc -> Memo.map (Var.read v) ~f:(fun v -> acc + v))) ))
;;
let%bench_fun "20-reads (create and compute)" = twenty_reads.create_and_compute ()
let%bench_fun "20-reads (incr and recompute)" = twenty_reads.incr_and_recompute ()
let%bench_fun "20-reads (restore from cache)" = twenty_reads.restore_from_cache ()
let clique =
Case.create (fun () ->
let v = Var.create 0 in
let read_v = Memo.memoize (Var.read v) in
( v
, List.fold_left
~init:read_v
(List.init 30 ~f:(fun _i -> ()))
~f:(fun acc () ->
let node = Memo.memoize acc in
Memo.map2 node acc ~f:( + )) ))
;;
let%bench_fun "clique (create and compute)" = clique.create_and_compute ()
let%bench_fun "clique (incr and recompute)" = clique.incr_and_recompute ()
let%bench_fun "clique (restore from cache)" = clique.restore_from_cache ()
let bipartite =
Case.create (fun () ->
let first_var = Var.create 0 in
let inputs =
List.init 30 ~f:(fun i ->
let v = if i = 0 then first_var else Var.create 0 in
Memo.memoize (Var.read v))
in
let matrix i j = if i = j then 1 else 0 in
let outputs =
List.init 30 ~f:(fun i ->
Memo.memoize
(Memo.all
(List.mapi inputs ~f:(fun j x -> Memo.map x ~f:(fun x -> matrix i j * x)))
|> Memo.map ~f:(List.fold_left ~init:0 ~f:( + ))))
in
first_var, Memo.memoize (Memo.all outputs))
;;
let%bench_fun "bipartite (create and compute)" = bipartite.create_and_compute ()
let%bench_fun "bipartite (incr and recompute)" = bipartite.incr_and_recompute ()
let%bench_fun "bipartite (restore from cache)" = bipartite.restore_from_cache ()
let memo_diamonds =
Case.create (fun () ->
let v = Var.create 0 in
( v
, List.fold_left
~init:(Var.read v)
(List.init 20 ~f:(fun _i -> ()))
~f:(fun acc () ->
Memo.memoize (Memo.bind acc ~f:(fun x -> Memo.map acc ~f:(fun y -> x + y)))) ))
;;
let%bench_fun "memo diamonds (create and compute)" = memo_diamonds.create_and_compute ()
let%bench_fun "memo diamonds (incr and recompute)" = memo_diamonds.incr_and_recompute ()
let%bench_fun "memo diamonds (restore from cache)" = memo_diamonds.restore_from_cache ()

0
unikernel/duniverse/dune_/bench/micro/memo_bench/benchmarks.mli Normal file
View file

6
unikernel/duniverse/dune_/bench/micro/memo_bench/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name memo_bench)
(library_flags -linkall)
(preprocess
(pps ppx_bench))
(libraries fiber stdune memo core_bench.inline_benchmarks))

62
unikernel/duniverse/dune_/bench/micro/memo_bench/memo_intf.ml Normal file
View file

@ -0,0 +1,62 @@
module type Monad_intf = sig
type 'a t
val return : 'a -> 'a t
val bind : 'a t -> f:('a -> 'b t) -> 'b t
val map : 'a t -> f:('a -> 'b) -> 'b t
module Let_syntax : sig
val return : 'a -> 'a t
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
end
end
module type Test_env = sig
module Glass : sig
type t
val create : unit -> t
val break : t -> unit
end
module Io : sig
include Monad_intf
module Ivar : sig
type 'a io := 'a t
type 'a t
val create : unit -> 'a t
val read : 'a t -> 'a io
val fill : 'a t -> 'a -> unit io
end
val of_thunk : (unit -> 'a t) -> 'a t
end
module Memo : sig
include Monad_intf
val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
val all : 'a t list -> 'a list t
val of_glass : Glass.t -> 'a -> 'a t
val of_thunk : (unit -> 'a t) -> 'a t
val of_io : (unit -> 'a Io.t) -> 'a t
val memoize : 'a t -> 'a t
end
module Var : sig
type 'a t
val create : 'a -> 'a t
val set : 'a t -> 'a -> unit
val read : 'a t -> 'a Memo.t
(** peek once without registering interest in future updates *)
val peek : 'a t -> 'a
end
val run : 'a Memo.t -> 'a
val make_counter : unit -> int Memo.t * (unit -> unit)
end

121
unikernel/duniverse/dune_/bench/micro/memo_bench/memo_tests_env.ml Normal file
View file

@ -0,0 +1,121 @@
module Io = struct
type 'a t = 'a Fiber.t
let of_thunk f = Fiber.of_thunk f
let map t ~f = Fiber.map t ~f
let bind t ~f = Fiber.bind t ~f:(fun x -> f x)
let return x = Fiber.return x
module Ivar = struct
include Fiber.Ivar
let read x = read x
let fill x v = fill x v
end
module Let_syntax = struct
let ( let+ ) x f = map x ~f
let ( let* ) x f = bind x ~f
let return = return
end
end
let invalidation_acc = ref Memo.Invalidation.empty
module Memo = struct
include Memo
let sample_count =
(* Count number of samples of all lifted computations, to allow simple
detection of looping tests executed by [run] *)
ref 0
;;
let exec build =
(* not expected to be used in re-entrant way *)
sample_count := 0;
Memo.reset !invalidation_acc;
invalidation_acc := Memo.Invalidation.empty;
let fiber = Memo.run build in
Fiber.run fiber ~iter:(fun _ -> failwith "deadlock?")
;;
let of_io f = Memo.of_reproducible_fiber (Fiber.of_thunk f)
let memoize t =
let l = Memo.lazy_ ~cutoff:(fun _ _ -> false) (fun () -> t) in
Memo.of_thunk (fun () -> Memo.Lazy.force l)
;;
let map2 x y ~f =
map ~f:(fun (x, y) -> f x y) (Memo.fork_and_join (fun () -> x) (fun () -> y))
;;
let all l = Memo.all_concurrently l
module Glass = struct
type t = (unit, unit) Memo.Cell.t
let create () = Memo.lazy_cell ~cutoff:(fun _ _ -> false) (fun () -> Memo.return ())
let break (t : t) =
invalidation_acc
:= Memo.Invalidation.combine
(Memo.Cell.invalidate ~reason:Memo.Invalidation.Reason.Test t)
!invalidation_acc
;;
end
let of_glass (g : Glass.t) v =
Memo.of_thunk (fun () -> Memo.map (Memo.Cell.read g) ~f:(fun () -> v))
;;
let of_thunk f = Memo.of_reproducible_fiber (Fiber.of_thunk (fun () -> Memo.run (f ())))
module Let_syntax = struct
let ( let+ ) x f = map x ~f
let ( let* ) x f = bind x ~f
let return = return
end
end
let run tenacious = Memo.exec tenacious
module Glass = Memo.Glass
let make_counter () =
let r = ref 0 in
let glass = Glass.create () in
let break () = Glass.break glass in
( Memo.map
(Memo.of_thunk (fun () -> Memo.Cell.read glass))
~f:(fun () ->
incr r;
!r)
, break )
;;
module Var = struct
type 'a t =
{ value : 'a ref
; cell : (unit, 'a) Memo.Cell.t
}
let create value =
let value = ref value in
{ value
; cell = Memo.lazy_cell ~cutoff:(fun _ _ -> false) (fun () -> Memo.return !value)
}
;;
let set t v =
t.value := v;
invalidation_acc
:= Memo.Invalidation.combine
!invalidation_acc
(Memo.Cell.invalidate ~reason:Memo.Invalidation.Reason.Test t.cell)
;;
let read t = Memo.of_thunk (fun () -> Memo.Cell.read t.cell)
let peek t = !(t.value)
end

1
unikernel/duniverse/dune_/bench/micro/memo_bench_main.ml Normal file
View file

@ -0,0 +1 @@
Inline_benchmarks_public.Runner.main ~libname:"memo_bench"

67
unikernel/duniverse/dune_/bench/micro/path_bench.ml Normal file
View file

@ -0,0 +1,67 @@
module Path = Stdune.Path
module Fpath = Stdune.Fpath
open Base
module Filename = Stdlib.Filename
let () = Path.Build.set_build_dir (In_source_dir Path.Source.(relative root "_build"))
let root = "."
let short_path = "a/b/c"
let long_path = List.init 20 ~f:(fun _ -> "foo-bar-baz") |> String.concat ~sep:"/"
let%bench_fun
("is_root"
[@params path = [ "root", "."; "short path", short_path; "long path", long_path ]])
=
fun () -> ignore (Fpath.is_root path)
;;
let%bench_fun
("reach"
[@params
t
= [ "from root long path", (long_path, root)
; "from root short path", (short_path, root)
; "reach root from short path", (root, short_path)
; "reach root from long path", (root, long_path)
; ( "reach long path from similar long path"
, (Filename.concat long_path "a", Filename.concat long_path "b") )
; ( "reach short path from similar short path"
, (Filename.concat short_path "a", Filename.concat short_path "b") )
]])
=
let t, from = t in
let t = Path.of_string t in
let from = Path.of_string from in
fun () -> ignore (Path.reach t ~from)
;;
let%bench_fun
("Path.Local.relative"
[@params
t
= [ "left root", (".", long_path)
; "right root", (long_path, ".")
; "short paths", (short_path, short_path)
; "long paths", (long_path, long_path)
]])
=
let x, y = t in
let x = Path.Local.of_string x in
fun () -> ignore (Path.Local.relative x y)
;;
let%bench_fun
("Path.Local.append"
[@params
t
= [ "left root", (".", long_path)
; "right root", (long_path, ".")
; "short paths", (short_path, short_path)
; "long paths", (long_path, long_path)
]])
=
let x, y = t in
let x = Path.Local.of_string x in
let y = Path.Local.of_string y in
fun () -> ignore (Path.Local.append x y)
;;

1
unikernel/duniverse/dune_/bench/micro/path_bench_main.ml Normal file
View file

@ -0,0 +1 @@
Inline_benchmarks_public.Runner.main ~libname:"path_bench"

12
unikernel/duniverse/dune_/bench/micro/runner.sh Executable file
View file

@ -0,0 +1,12 @@
#!/usr/bin/env sh
export BENCHMARKS_RUNNER=TRUE
case "$1" in
"dune" ) test="dune_bench"; main="main";;
"memo" ) test="memo_bench"; main="memo_bench_main";;
"thread_pool" ) test="thread_pool_bench"; main="thread_pool_bench_main";;
"digest" ) test="digest_bench"; main="digest_bench_main";;
"path" ) test="path_bench"; main="path_bench_main";;
esac
shift;
export BENCH_LIB="$test"
exec ./dune.exe exec --release -- "./bench/micro/$main.exe" -fork -run-without-cross-library-inlining "$@"

47
unikernel/duniverse/dune_/bench/micro/thread_pool_bench.ml Normal file
View file

@ -0,0 +1,47 @@
open Dune_thread_pool
let spawn_thread f = ignore (Thread.create f ())
let%bench "almost no-op" =
let tp = Thread_pool.create ~min_workers:10 ~max_workers:50 ~spawn_thread in
let tasks = 50_000 in
let counter = Atomic.make tasks in
let f () = Atomic.decr counter in
for _ = 0 to tasks - 1 do
Thread_pool.task tp ~f
done;
while Atomic.get counter > 0 do
Thread.yield ()
done
;;
let%bench "syscall" =
let tp = Thread_pool.create ~min_workers:10 ~max_workers:50 ~spawn_thread in
let tasks = 50_000 in
let counter = Atomic.make tasks in
let f () =
Unix.sleepf 0.0;
Atomic.decr counter
in
for _ = 0 to tasks - 1 do
Thread_pool.task tp ~f
done;
while Atomic.get counter > 0 do
Thread.yield ()
done
;;
let%bench "syscall - no background" =
let tasks = 50_000 in
let counter = Atomic.make tasks in
let f () =
Unix.sleepf 0.0;
Atomic.decr counter
in
for _ = 0 to tasks - 1 do
f ()
done;
while Atomic.get counter > 0 do
Thread.yield ()
done
;;

1
unikernel/duniverse/dune_/bench/micro/thread_pool_bench_main.ml Normal file
View file

@ -0,0 +1 @@
Inline_benchmarks_public.Runner.main ~libname:"thread_pool_bench"

90
unikernel/duniverse/dune_/bench/perf.sh Executable file
View file

@ -0,0 +1,90 @@
#!/usr/bin/env bash
# Run this script simply as ./bench/perf.sh from the root directory.
set -e
TEST_REPO=https://github.com/ocaml-dune/dune-bench
TEST_COMMIT=b6bfaf2974ec8ee1eea92c4316ec37b9966322e3
# Some alternative benchmarks:
# TEST_REPO=https://github.com/ocaml/dune
# TEST_COMMIT=002edc11f4e0a57f11d5226cb2497c8b406027b5
# TEST_REPO=https://github.com/avsm/platform
# TEST_COMMIT=b254e3c6b60f3c0c09dfdcde92eb1abdc267fa1c
dune() {
TIMEFORMAT=$'real %Rs\nuser %Us\nsys %Ss\n'; time ../_build/default/bin/main.exe "$@" > /dev/null 2>&1
}
setup_test() {
mkdir -p _perf
cd _perf
if [ ! -f README.md ]; then
echo "Cloning $TEST_REPO..."
wget $TEST_REPO/archive/$TEST_COMMIT.tar.gz
tar -xzf $TEST_COMMIT.tar.gz --strip-components=1
fi
cd ..
}
pad () {
while IFS='' read -r x; do printf "%-$1s\n" "$x"; done
}
run_test() {
echo "Building Dune..."
# [make release] is used for bootstrapping, but the real binary to benchmark is
# then produced by a separate dune invocation.
# This is done mainly because [make release] won't rebuild dune if it's stale.
make release > /dev/null
./dune.exe build _build/default/bin/main.exe
cd _perf
rm -rf _build
echo "Running full build..."
dune build --release --cache=disabled 2>> $1
echo "Running zero build..."
dune build --release --cache=disabled 2>> $1
cd ..
}
setup_test
CURRENT_BRANCH=$(git branch | sed -n -e 's/^\* \(.*\)/\1/p')
rm -f _perf/rows _perf/current _perf/main
echo " " >> _perf/rows
echo " " >> _perf/rows
echo " |" >> _perf/rows
echo "Full build |" >> _perf/rows
echo " |" >> _perf/rows
echo " " >> _perf/rows
echo " |" >> _perf/rows
echo "Zero build |" >> _perf/rows
echo " |" >> _perf/rows
echo "Current branch" >> _perf/current
echo "==============" >> _perf/current
echo "Testing the current branch ($CURRENT_BRANCH)"
run_test current
echo " Main branch " >> _perf/main
echo "=============" >> _perf/main
git checkout main
echo "Testing main"
run_test main
git checkout $CURRENT_BRANCH
echo ""
echo "Summary for building $TEST_REPO:"
echo ""
paste -d ' ' <(pad 10 < _perf/rows) <(pad 14 < _perf/current) _perf/main

63
unikernel/duniverse/dune_/bench/run-synthetic-dune-watch.sh Executable file
View file

@ -0,0 +1,63 @@
#!/bin/bash
set -eu
usage()
{
cat <<EOF
Usage:
$(basename "${0}") <path_to_dune>
EOF
}
if [ $# -ne 1 ]; then
usage
exit 1
fi
path_to_dune="${1}"
start_dune () {
((${path_to_dune} build "$@" --watch @all > .#dune-output 2>&1) || (echo exit $? >> .#dune-output)) &
DUNE_PID=$!;
}
timeout="$(command -v timeout || echo gtimeout)"
with_timeout () {
$timeout 2 "$@"
exit_code=$?
if [ "$exit_code" = 124 ]
then
echo Timed out
cat .#dune-output
else
return "$exit_code"
fi
}
stop_dune () {
with_timeout dune shutdown;
wait $DUNE_PID;
cat .#dune-output;
}
echo Breaking build
echo "let f() = 2" > ./internal/m_1_1_1_1.ml
echo "val f : unit -> int" > ./internal/m_1_1_1_1.mli
echo Starting dune
start_dune
echo Checking for error
until grep 'error' .#dune-output > /dev/null; do sleep 0.1; done
echo Found, fixing build
echo "let f() = ()" > ./internal/m_1_1_1_1.ml
echo "val f : unit -> unit" > ./internal/m_1_1_1_1.mli
echo Checking for success
until grep 'Success' .#dune-output > /dev/null; do sleep 0.1; done
echo Found, stopping dune
stop_dune

145
unikernel/duniverse/dune_/bin/alias.ml Normal file
View file

@ -0,0 +1,145 @@
open Import
module Alias = Dune_engine.Alias
module Alias0 = Dune_rules.Alias
module Alias_builder = Dune_rules.Alias_builder
type t =
{ name : Alias.Name.t
; recursive : bool
; dir : Path.Source.t
; contexts : Dune_rules.Context.t list
}
let pp { name; recursive; dir; contexts = _ } =
let open Pp.O in
let s =
(if recursive then "@" else "@@")
^ Path.Source.to_string (Path.Source.relative dir (Alias.Name.to_string name))
in
let pp = Pp.verbatim "alias" ++ Pp.space ++ Pp.verbatim s in
if recursive then Pp.verbatim "recursive" ++ Pp.space ++ pp else pp
;;
let in_dir ~name ~recursive ~contexts dir =
let checked = Util.check_path contexts dir in
match checked with
| External _ ->
User_error.raise
[ Pp.textf "@@ on the command line must be followed by a relative path" ]
| In_source_dir dir -> { dir; recursive; name; contexts }
| In_private_context _ ->
User_error.raise [ Pp.textf "no aliases in the testing context" ]
| In_install_dir _ ->
User_error.raise
[ Pp.textf
"Invalid alias: %s."
(Path.to_string_maybe_quoted
(Path.build Install.Context.install_context.build_dir))
; Pp.textf "There are no aliases in %s." (Path.to_string_maybe_quoted dir)
]
| In_build_dir (ctx, dir) ->
{ dir
; recursive
; name
; contexts =
[ List.find_exn contexts ~f:(fun c ->
Context_name.equal (Context.name c) (Context.name ctx))
]
}
;;
let of_string (root : Workspace_root.t) ~recursive s ~contexts =
let path = Path.relative Path.root (root.reach_from_root_prefix ^ s) in
if Path.is_root path
then
User_error.raise
[ Pp.textf "@ on the command line must be followed by a valid alias name" ]
else (
let dir = Path.parent_exn path in
let name = Alias.Name.of_string (Path.basename path) in
in_dir ~name ~recursive ~contexts dir)
;;
let find_dir_specified_on_command_line ~dir =
let open Memo.O in
Source_tree.find_dir dir
>>| function
| Some dir -> dir
| None ->
User_error.raise
[ Pp.textf
"Don't know about directory %s specified on the command line!"
(Path.Source.to_string_maybe_quoted dir)
]
;;
let dep_on_alias_multi_contexts ~dir ~name ~contexts =
ignore (find_dir_specified_on_command_line ~dir : _ Memo.t);
let context_to_alias_expansion ctx =
let ctx_dir = Context_name.build_dir ctx in
let dir = Path.Build.(append_source ctx_dir dir) in
Alias_builder.alias (Alias.make ~dir name)
in
Action_builder.all_unit (List.map contexts ~f:context_to_alias_expansion)
;;
let dep_on_alias_rec_multi_contexts ~dir:src_dir ~name ~contexts =
let open Action_builder.O in
let* dir = Action_builder.of_memo (find_dir_specified_on_command_line ~dir:src_dir) in
let* alias_statuses =
Action_builder.all
(List.map contexts ~f:(fun ctx ->
let dir =
Path.Build.append_source
(Context_name.build_dir ctx)
(Source_tree.Dir.path dir)
in
Dune_rules.Alias_rec.dep_on_alias_rec name dir))
in
match
Alias0.is_standard name
|| List.exists alias_statuses ~f:(fun (x : Alias_builder.Alias_status.t) ->
match x with
| Defined -> true
| Not_defined -> false)
with
| true -> Action_builder.return ()
| false ->
let* load_dir =
Action_builder.all
@@ List.map contexts ~f:(fun ctx ->
let dir =
Source_tree.Dir.path dir
|> Path.Build.append_source (Context_name.build_dir ctx)
|> Path.build
in
Action_builder.of_memo @@ Load_rules.load_dir ~dir)
in
let hints =
let candidates =
Alias.Name.Set.union_map load_dir ~f:(function
| Load_rules.Loaded.Build build -> Alias.Name.Set.of_keys build.aliases
| _ -> Alias.Name.Set.empty)
in
User_message.did_you_mean
(Alias.Name.to_string name)
~candidates:(Alias.Name.Set.to_list_map ~f:Alias.Name.to_string candidates)
in
User_error.raise
~hints
[ Pp.textf
"Alias %S specified on the command line is empty."
(Alias.Name.to_string name)
; Pp.textf
"It is not defined in %s or any of its descendants."
(Path.Source.to_string_maybe_quoted src_dir)
]
;;
let request { name; recursive; dir; contexts } =
let contexts = List.map ~f:Context.name contexts in
(if recursive then dep_on_alias_rec_multi_contexts else dep_on_alias_multi_contexts)
~dir
~name
~contexts
;;

25
unikernel/duniverse/dune_/bin/alias.mli Normal file
View file

@ -0,0 +1,25 @@
open Import
type t = private
{ name : Dune_engine.Alias.Name.t
; recursive : bool
; dir : Path.Source.t
; contexts : Context.t list
}
val in_dir
: name:Dune_engine.Alias.Name.t
-> recursive:bool
-> contexts:Context.t list
-> Path.t
-> t
val of_string
: Workspace_root.t
-> recursive:bool
-> string
-> contexts:Context.t list
-> t
val pp : t -> _ Pp.t
val request : t -> unit Action_builder.t

155
unikernel/duniverse/dune_/bin/arg.ml Normal file
View file

@ -0,0 +1,155 @@
open Stdune
include Cmdliner.Arg
include struct
open Dune_lang
module Stanza = Stanza
module String_with_vars = String_with_vars
module Profile = Profile
module Pform = Pform
module Lib_name = Lib_name
module Dep_conf = Dep_conf
end
module Package = Dune_lang.Package
module Context_name = Dune_engine.Context_name
let package_name = conv Package.Name.conv
module Path = struct
module External = struct
type t = string
let path p = Path.External.of_filename_relative_to_initial_cwd p
let arg s = s
let conv = conv ((fun p -> Ok p), Format.pp_print_string)
end
type t = string
let path p = Path.of_filename_relative_to_initial_cwd p
let arg s = s
let conv = conv ((fun p -> Ok p), Format.pp_print_string)
end
let path = Path.conv
let external_path = Path.External.conv
let profile = conv Profile.conv
module Dep = struct
module Dep_conf = Dep_conf
type t = Dep_conf.t
let equal = Dep_conf.equal
let file s = Dep_conf.File (String_with_vars.make_text Loc.none s)
let make_alias_sw ~dir s =
let path =
Dune_engine.Alias.Name.to_string s
|> Stdune.Path.Local.relative dir
|> Stdune.Path.Local.to_string
in
String_with_vars.make_text Loc.none path
;;
let alias ~dir s = Dep_conf.Alias (make_alias_sw ~dir s)
let alias_rec ~dir s = Dep_conf.Alias_rec (make_alias_sw ~dir s)
let parse_alias s =
if not (String.is_prefix s ~prefix:"@")
then None
else (
let pos, recursive =
if String.length s >= 2 && s.[1] = '@' then 2, false else 1, true
in
let s = String_with_vars.make_text Loc.none (String.drop s pos) in
Some (if recursive then Dep_conf.Alias_rec s else Dep_conf.Alias s))
;;
let dep_parser =
Dune_lang.Syntax.set
Stanza.syntax
(Active Stanza.latest_version)
(String_with_vars.set_decoding_env
(Pform.Env.initial ~stanza:Stanza.latest_version ~extensions:[])
Dep_conf.decode)
;;
let parser s =
match parse_alias s with
| Some dep -> Ok dep
| None ->
(match
Dune_lang.Decoder.parse
dep_parser
Univ_map.empty
(Dune_lang.Parser.parse_string
~fname:"command line"
~mode:Dune_lang.Parser.Mode.Single
s)
with
| x -> Ok x
| exception User_error.E msg -> Error (User_message.to_string msg))
;;
let string_of_alias ~recursive sv =
let prefix = if recursive then "@" else "@@" in
String_with_vars.text_only sv |> Option.map ~f:(fun s -> prefix ^ s)
;;
let printer ppf t =
let s =
match t with
| Dep_conf.Alias sv -> string_of_alias ~recursive:false sv
| Alias_rec sv -> string_of_alias ~recursive:true sv
| File sv -> Some (Dune_lang.to_string (String_with_vars.encode sv))
| _ -> None
in
let s =
match s with
| Some s -> s
| None -> Dune_lang.to_string (Dep_conf.encode t)
in
Format.pp_print_string ppf s
;;
let conv = conv' (parser, printer)
let to_string_maybe_quoted t = String.maybe_quoted (Format.asprintf "%a" printer t)
let alias_arg =
let parse x = Ok (Dep_conf.Alias (String_with_vars.make_text Loc.none x)) in
conv' (parse, printer)
;;
let alias_rec_arg =
let parse x = Ok (Dep_conf.Alias_rec (String_with_vars.make_text Loc.none x)) in
conv' (parse, printer)
;;
end
let dep = Dep.conv
let bytes =
let decode repr =
let ast =
Dune_lang.Parser.parse_string
~fname:"command line"
~mode:Dune_lang.Parser.Mode.Single
repr
in
match Dune_lang.Decoder.parse Dune_lang.Decoder.bytes_unit Univ_map.empty ast with
| x -> Result.Ok x
| exception User_error.E msg -> Result.Error (`Msg (User_message.to_string msg))
in
let pp_print_int64 state i = Format.pp_print_string state (Int64.to_string i) in
conv (decode, pp_print_int64)
;;
let graph_format : Dune_graph.Graph.File_format.t conv =
conv Dune_graph.Graph.File_format.conv
;;
let context_name : Context_name.t conv = conv Context_name.conv
let lib_name = conv Lib_name.conv
let version = pair ~sep:'.' int int

42
unikernel/duniverse/dune_/bin/arg.mli Normal file
View file

@ -0,0 +1,42 @@
open Stdune
include module type of struct
include Cmdliner.Arg
end
module Path : sig
module External : sig
type t
val path : t -> Path.External.t
val arg : t -> string
end
type t
val path : t -> Path.t
val arg : t -> string
end
module Dep : sig
type t = Dune_lang.Dep_conf.t
val equal : t -> t -> bool
val file : string -> t
val alias : dir:Stdune.Path.Local.t -> Dune_engine.Alias.Name.t -> t
val alias_rec : dir:Stdune.Path.Local.t -> Dune_engine.Alias.Name.t -> t
val to_string_maybe_quoted : t -> string
val alias_arg : t conv
val alias_rec_arg : t conv
end
val bytes : int64 conv
val context_name : Dune_engine.Context_name.t conv
val dep : Dep.t conv
val graph_format : Dune_graph.Graph.File_format.t conv
val path : Path.t conv
val external_path : Path.External.t conv
val package_name : Dune_lang.Package.Name.t conv
val profile : Dune_lang.Profile.t conv
val lib_name : Dune_lang.Lib_name.t conv
val version : Dune_lang.Syntax.Version.t conv

215
unikernel/duniverse/dune_/bin/build.ml Normal file
View file

@ -0,0 +1,215 @@
open Import
let with_metrics ~common f =
let start_time = Unix.gettimeofday () in
Fiber.finalize f ~finally:(fun () ->
let duration = Unix.gettimeofday () -. start_time in
if Common.print_metrics common
then (
let gc_stat = Gc.quick_stat () in
(* We reset Memo counters below, unconditionally. *)
let memo_counters_report = Memo.Metrics.report ~reset_after_reporting:false in
Console.print_user_message
(User_message.make
([ Pp.textf "%s" memo_counters_report
; Pp.textf
"(%.2fs total, %.1fM heap words)"
duration
(float_of_int gc_stat.heap_words /. 1_000_000.)
; Pp.text "Timers:"
]
@ List.map
~f:(fun (timer, { Metrics.Timer.Measure.cumulative_time; count }) ->
Pp.textf
"%s - time spent = %.2fs, count = %d"
timer
cumulative_time
count)
(String.Map.to_list (Metrics.Timer.aggregated_timers ())))));
Memo.Metrics.reset ();
Fiber.return ())
;;
let run_build_system ~common ~request =
let run ~(toplevel : unit Memo.Lazy.t) =
with_metrics ~common (fun () -> build (fun () -> Memo.Lazy.force toplevel))
in
let open Fiber.O in
Fiber.finalize
(fun () ->
(* CR-someday amokhov: Currently we invalidate cached timestamps on every
incremental rebuild. This conservative approach helps us to work around
some [mtime] resolution problems (e.g. on Mac OS). It would be nice to
find a way to avoid doing this. In fact, this may be unnecessary even
for the initial build if we assume that the user does not modify files
in the [_build] directory. For now, it's unclear if optimising this is
worth the effort. *)
Cached_digest.invalidate_cached_timestamps ();
let* setup = Import.Main.setup () in
let request =
Action_builder.bind (Action_builder.of_memo setup) ~f:(fun setup ->
request setup)
in
(* CR-someday cmoseley: Can we avoid creating a new lazy memo node every
time the build system is rerun? *)
(* This top-level node is used for traversing the whole Memo graph. *)
let toplevel_cell, toplevel =
Memo.Lazy.Expert.create ~name:"toplevel" (fun () ->
let open Memo.O in
let+ (), (_ : Dep.Fact.t Dep.Map.t) =
Action_builder.evaluate_and_collect_facts request
in
())
in
let* res = run ~toplevel in
let+ () =
match Common.dump_memo_graph_file common with
| None -> Fiber.return ()
| Some file ->
let path = Path.external_ file in
let+ graph =
Memo.dump_cached_graph
~time_nodes:(Common.dump_memo_graph_with_timing common)
toplevel_cell
in
Graph.serialize graph ~path ~format:(Common.dump_memo_graph_format common)
(* CR-someday cmoseley: It would be nice to use Persistent to dump a
copy of the graph's internal representation here, so it could be used
without needing to re-run the build*)
in
res)
~finally:(fun () ->
Hooks.End_of_build.run ();
Fiber.return ())
;;
let poll_handling_rpc_build_requests ~(common : Common.t) ~config =
let open Fiber.O in
let rpc =
match Common.rpc common with
| `Allow server -> server
| `Forbid_builds -> Code_error.raise "rpc server must be allowed in passive mode" []
in
Scheduler.Run.poll_passive
~get_build_request:
(let+ (Build (targets, ivar)) = Dune_rpc_impl.Server.pending_build_action rpc in
let request setup =
Target.interpret_targets (Common.root common) config setup targets
in
run_build_system ~common ~request, ivar)
;;
let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit =
Scheduler.go_with_rpc_server_and_console_status_reporting ~common ~config (fun () ->
let open Fiber.O in
(* Run two fibers concurrently. One is responible for rebuilding targets
named on the command line in reaction to file system changes. The other
is responsible for building targets named in RPC build requests. *)
let+ () = Scheduler.Run.poll (run_build_system ~common ~request)
and+ () = poll_handling_rpc_build_requests ~common ~config in
())
;;
let run_build_command_poll_passive ~common ~config ~request:_ : unit =
(* CR-someday aalekseyev: It would've been better to complain if [request] is
non-empty, but we can't check that here because [request] is a function.*)
Scheduler.go_with_rpc_server_and_console_status_reporting ~common ~config (fun () ->
poll_handling_rpc_build_requests ~common ~config)
;;
let run_build_command_once ~(common : Common.t) ~config ~request =
let open Fiber.O in
let once () =
let+ res = run_build_system ~common ~request in
match res with
| Error `Already_reported -> raise Dune_util.Report_error.Already_reported
| Ok () -> ()
in
Scheduler.go_with_rpc_server ~common ~config once
;;
let run_build_command ~(common : Common.t) ~config ~request =
(match Common.watch common with
| Yes Eager -> run_build_command_poll_eager
| Yes Passive -> run_build_command_poll_passive
| No -> run_build_command_once)
~common
~config
~request
;;
let build_via_rpc_server ~print_on_success ~targets =
Rpc_common.wrap_build_outcome_exn
~print_on_success
(Rpc.Build.build ~wait:true)
targets
()
;;
let build =
let doc = "Build the given targets, or the default ones if none are given." in
let man =
[ `S "DESCRIPTION"
; `P {|Targets starting with a $(b,@) are interpreted as aliases.|}
; `Blocks Common.help_secs
; Common.examples
[ "Build all targets in the current source tree", "dune build"
; "Build targets in the `./foo/bar' directory", "dune build ./foo/bar"
; ( "Build the minimal set of targets required for tooling such as Merlin \
(useful for quickly detecting errors)"
, "dune build @check" )
; "Run all code formatting tools in-place", "dune build --auto-promote @fmt"
]
]
in
let name_ = Arg.info [] ~docv:"TARGET" in
let term =
let+ builder = Common.Builder.term
and+ targets = Arg.(value & pos_all dep [] name_)
and+ aliases_rec = Arg.(value & opt_all Dep.alias_rec_arg [] & info [ "alias-rec" ])
and+ aliases = Arg.(value & opt_all Dep.alias_arg [] & info [ "alias" ]) in
let targets = List.concat [ targets; aliases; aliases_rec ] in
let targets =
match targets with
| [] -> [ Common.Builder.default_target builder ]
| _ :: _ -> targets
in
let common, config = Common.init builder in
(* Here we need to find out whether another instance of dune already holds
the global build lock, as this will determine whether the current
instance of dune will perform the build itself or send a build request
to the RPC server in an already-running dune process. The method of
checking whether another dune instance holds the lock is to simply try
to take the lock. If taking the lock succeeds then the current process
will perform the build itself, and future attempts by this process to
take the lock are guaranteed to succeed. If taking the lock fails then
we know that another instance of dune must have it, and the current
process will send a build RPC request to that dune instance. Checking
the status of the lock by taking prevents a race condition where the
state of the lock could otherwise change between checking it and taking
it. *)
match Dune_util.Global_lock.lock ~timeout:None with
| Error lock_held_by ->
(* This case is reached if dune detects that another instance of dune
is already running. Rather than performing the build itself, the
current instance of dune will instruct the already-running instance to
perform the build by sending an RPC message. As only one RPC server
can run at a time we need to use a fiber scheduler which does not run
an RPC server in the background to schedule the fiber which will
perform the RPC call.
*)
Rpc_common.run_via_rpc
~builder
~common
~config
lock_held_by
(Rpc.Build.build ~wait:true)
targets
| Ok () ->
let request setup =
Target.interpret_targets (Common.root common) config setup targets
in
run_build_command ~common ~config ~request
in
Cmd.v (Cmd.info "build" ~doc ~man ~envs:Common.envs) term
;;

24
unikernel/duniverse/dune_/bin/build.mli Normal file
View file

@ -0,0 +1,24 @@
open Import
(** Connect to an RPC server (waiting for the server to start if necessary) and
then send a request to the server to build the specified targets. If the
build fails then a diagnostic error message is printed. If
[print_on_success] is true then this function will also print a message
after the build succeeds. *)
val build_via_rpc_server
: print_on_success:bool
-> targets:Dune_lang.Dep_conf.t list
-> unit Fiber.t
val run_build_system
: common:Common.t
-> request:(Dune_rules.Main.build_system -> unit Action_builder.t)
-> (unit, [ `Already_reported ]) result Fiber.t
val build : unit Cmd.t
val run_build_command
: common:Common.t
-> config:Dune_config.t
-> request:(Dune_rules.Main.build_system -> unit Action_builder.t)
-> unit

117
unikernel/duniverse/dune_/bin/cache.ml Normal file
View file

@ -0,0 +1,117 @@
open Import
(* CR-someday amokhov: Implement other commands supported by Jenga. *)
let trim =
let info =
let doc = "Trim the Dune cache." in
let man =
[ `P "Trim the Dune cache to a specified size or by a specified amount."
; `S "EXAMPLES"
; `Pre
{|Trimming the Dune cache to 1 GB.
\$ dune cache trim --size=1GB |}
; `Pre
{|Trimming 500 MB from the Dune cache.
\$ dune cache trim --trimmed-size=500MB |}
]
in
Cmd.info "trim" ~doc ~man
in
Cmd.v info
@@ let+ trimmed_size =
Arg.(
value
& opt (some bytes) None
& info
~docv:"BYTES"
[ "trimmed-size" ]
~doc:"Size to trim from the cache. $(docv) is the same as for --size.")
and+ size =
Arg.(
value
& opt (some bytes) None
& info
~docv:"BYTES"
[ "size" ]
~doc:
(sprintf
"Size to trim the cache to. $(docv) is the number of bytes followed by \
a unit. Byte units can be one of %s."
(String.enumerate_or
(List.map
~f:(fun (units, _) -> List.hd units)
Bytes_unit.conversion_table))))
in
Log.init_disabled ();
let open Result.O in
match
let+ goal =
match trimmed_size, size with
| Some trimmed_size, None -> Result.Ok trimmed_size
| None, Some size ->
Result.Ok (Int64.sub (Dune_cache.Trimmer.overhead_size ()) size)
| _ -> Result.Error "please specify either --size or --trimmed-size"
in
Dune_cache.Trimmer.trim ~goal
with
| Error s -> User_error.raise [ Pp.text s ]
| Ok { trimmed_bytes; number_of_files_removed } ->
User_message.print
(User_message.make
[ Pp.textf
"Freed %s (%d files removed)"
(Bytes_unit.pp trimmed_bytes)
number_of_files_removed
])
;;
let size =
let info =
let doc = "Query the size of the Dune cache." in
let man =
[ `P
"Compute the total size of files in the Dune cache which are not hardlinked \
from any build directory and output it in a human-readable form."
]
in
Cmd.info "size" ~doc ~man
in
Cmd.v info
@@ let+ machine_readable =
Arg.(
value
& flag
& info [ "machine-readable" ] ~doc:"Outputs size as a plain number of bytes.")
in
let size = Dune_cache.Trimmer.overhead_size () in
if machine_readable
then User_message.print (User_message.make [ Pp.textf "%Ld" size ])
else User_message.print (User_message.make [ Pp.textf "%s" (Bytes_unit.pp size) ])
;;
let clear =
let info =
let doc = "Clear the Dune cache." in
let man = [ `P "Remove any traces of the Dune cache." ] in
Cmd.info "clear" ~doc ~man
in
Cmd.v info @@ Term.(const Dune_cache_storage.clear $ const ())
;;
let command =
let info =
let doc = "Manage Dune's shared cache of build artifacts." in
let man =
[ `S "DESCRIPTION"
; `P
"Dune can share build artifacts between workspaces. We currently only support \
a few subcommands; however, we plan to provide more functionality soon."
]
in
Cmd.info "cache" ~doc ~man
in
Cmd.group info [ trim; size; clear ]
;;

3
unikernel/duniverse/dune_/bin/cache.mli Normal file
View file

@ -0,0 +1,3 @@
open Import
val command : unit Cmd.t

25
unikernel/duniverse/dune_/bin/clean.ml Normal file
View file

@ -0,0 +1,25 @@
open Import
let command =
let doc = "Clean the project." in
let man =
[ `S "DESCRIPTION"
; `P {|Removes files added by dune such as _build, <package>.install, and .merlin|}
; `Blocks Common.help_secs
]
in
let term =
let+ builder = Common.Builder.term in
(* Disable log file creation. Indeed, we are going to delete the whole build directory
right after and that includes deleting the log file. Not only would creating the
log file be useless but with some FS this also causes [dune clean] to fail (cf
https://github.com/ocaml/dune/issues/2964). *)
let builder = Common.Builder.disable_log_file builder in
let _common, _config = Common.init builder in
Dune_util.Global_lock.lock_exn ~timeout:None;
Dune_engine.Target_promotion.files_in_source_tree_to_delete ()
|> Path.Source.Set.iter ~f:(fun p -> Path.unlink_no_err (Path.source p));
Path.rm_rf Path.build_dir
in
Cmd.v (Cmd.info "clean" ~doc ~man) term
;;

3
unikernel/duniverse/dune_/bin/clean.mli Normal file
View file

@ -0,0 +1,3 @@
open Import
val command : unit Cmd.t

1480
unikernel/duniverse/dune_/bin/common.ml Normal file
View file

File diff suppressed because it is too large Load diff

84
unikernel/duniverse/dune_/bin/common.mli Normal file
View file

@ -0,0 +1,84 @@
open Dune_config_file
open Stdune
type t
val x : t -> Dune_engine.Context_name.t option
val capture_outputs : t -> bool
val root : t -> Workspace_root.t
val rpc
: t
-> [ `Allow of Dune_lang.Dep_conf.t Dune_rpc_impl.Server.t
(** Will run rpc if in watch mode and acquire the build lock *)
| `Forbid_builds (** Promise not to build anything. For now, this isn't checked *)
]
val watch_exclusions : t -> string list
val stats : t -> Dune_stats.t option
val print_metrics : t -> bool
val dump_memo_graph_file : t -> Path.External.t option
val dump_memo_graph_format : t -> Dune_graph.Graph.File_format.t
val dump_memo_graph_with_timing : t -> bool
val watch : t -> Dune_rpc_impl.Watch_mode_config.t
val file_watcher : t -> Dune_engine.Scheduler.Run.file_watcher
val prefix_target : t -> string -> string
(** [Builder] describes how to initialize Dune. *)
module Builder : sig
type t
val equal : t -> t -> bool
val root : t -> string option
val set_root : t -> string -> t
val forbid_builds : t -> t
val default_root_is_cwd : t -> bool
val set_default_root_is_cwd : t -> bool -> t
val set_log_file : t -> Dune_util.Log.File.t -> t
val disable_log_file : t -> t
val set_promote : t -> Dune_engine.Clflags.Promote.t -> t
val default_target : t -> Arg.Dep.t
val term : t Cmdliner.Term.t
val default : t
end
(** [init] creates a [Common.t] by executing a sequence of side-effecting actions to
initialize Dune's working environment based on the options determined in the\
[Builder.t].
Return the [Common.t] and the final configuration, which is the same as the one
returned in the [config] field of [Dune_rules.Workspace.workspace ()]) *)
val init : Builder.t -> t * Dune_config_file.Dune_config.t
(** [examples [("description", "dune cmd foo"); ...]] is an [EXAMPLES] manpage
section of enumerated examples illustrating how to run the documented
commands. *)
val examples : (string * string) list -> Cmdliner.Manpage.block
(** [command_synopsis subcommands] is a custom [SYNOPSIS] manpage section
listing the given [subcommands]. Each subcommand is prefixed with the `dune`
top-level command. *)
val command_synopsis : string list -> Cmdliner.Manpage.block list
val help_secs : Cmdliner.Manpage.block list
val footer : Cmdliner.Manpage.block
val envs : Cmdliner.Cmd.Env.info list
val debug_backtraces : bool Cmdliner.Term.t
val config_from_config_file : Dune_config.Partial.t Cmdliner.Term.t
val display_term : Dune_config.Display.t option Cmdliner.Term.t
val context_arg : doc:string -> Dune_engine.Context_name.t Cmdliner.Term.t
(** A [--build-info] command line argument that print build information
(included in [term]) *)
val build_info : unit Cmdliner.Term.t
val default_build_dir : string
module Let_syntax : sig
val ( let+ ) : 'a Cmdliner.Term.t -> ('a -> 'b) -> 'b Cmdliner.Term.t
val ( and+ ) : 'a Cmdliner.Term.t -> 'b Cmdliner.Term.t -> ('a * 'b) Cmdliner.Term.t
end
(** [one_of term1 term2] allows options from [term1] or exclusively options from
[term2]. If the user passes options from both terms, an error is reported. *)
val one_of : 'a Cmdliner.Term.t -> 'a Cmdliner.Term.t -> 'a Cmdliner.Term.t

7
unikernel/duniverse/dune_/bin/coq/coq.ml Normal file
View file

@ -0,0 +1,7 @@
open Import
let doc = "Command group related to Coq."
let sub_commands_synopsis = Common.command_synopsis [ "coq top FILE -- ARGS" ]
let man = [ `Blocks sub_commands_synopsis ]
let info = Cmd.info ~doc ~man "coq"
let group = Cmd.group info [ Coqtop.command ]

3
unikernel/duniverse/dune_/bin/coq/coq.mli Normal file
View file

@ -0,0 +1,3 @@
open Import
val group : unit Cmd.t

159
unikernel/duniverse/dune_/bin/coq/coqtop.ml Normal file
View file

@ -0,0 +1,159 @@
open Import
let doc = "Execute a Coq toplevel with the local configuration."
let man =
[ `S "DESCRIPTION"
; `P
{|$(b,dune coq top FILE -- ARGS) runs the Coq toplevel to process the
given $(b,FILE). The given arguments are completed according to the
local configuration. This is equivalent to running $(b,coqtop ARGS)
with a $(b,_CoqProject) file containing the local configurations
from the $(b,dune) files, but does not require maintaining a
$(b,_CoqProject) file.|}
; `Blocks Common.help_secs
]
;;
let info = Cmd.info "top" ~doc ~man
let term =
let+ default_builder = Common.Builder.term
and+ context =
let doc = "Run the Coq toplevel in this build context." in
Common.context_arg ~doc
and+ coqtop =
let doc = "Run the given toplevel command instead of the default." in
Arg.(value & opt string "coqtop" & info [ "toplevel" ] ~docv:"CMD" ~doc)
and+ coq_file_arg =
Arg.(required & pos 0 (some string) None (Arg.info [] ~docv:"COQFILE"))
and+ extra_args = Arg.(value & pos_right 0 string [] (Arg.info [] ~docv:"ARGS"))
and+ no_rebuild =
Arg.(
value
& flag
& info [ "no-build" ] ~doc:"Don't rebuild dependencies before executing.")
in
let common, config =
let builder =
if no_rebuild then Common.Builder.forbid_builds default_builder else default_builder
in
Common.init builder
in
let coq_file_arg = Common.prefix_target common coq_file_arg |> Path.Local.of_string in
let coqtop, args, env =
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
let* setup = Import.Main.setup () in
let* setup = Memo.run setup in
let sctx = Import.Main.find_scontext_exn setup ~name:context in
let context = Dune_rules.Super_context.context sctx in
let coq_file_build =
Path.Build.append_local (Context.build_dir context) coq_file_arg
in
let dir =
(match Path.Local.parent coq_file_arg with
| None -> Path.Local.root
| Some dir -> dir)
|> Path.Build.append_local (Context.build_dir context)
in
let* coqtop, args, env =
build_exn
@@ fun () ->
let open Memo.O in
let* (tr : Dune_rules.Dir_contents.triage) =
Dune_rules.Dir_contents.triage sctx ~dir
in
let dir =
match tr with
| Group_part dir -> dir
| Standalone_or_root _ -> dir
in
let* dc = Dune_rules.Dir_contents.get sctx ~dir in
let* coq_src = Dune_rules.Dir_contents.coq dc in
let coq_module =
let source = coq_file_build in
match Dune_rules.Coq.Coq_sources.find_module ~source coq_src with
| Some m -> snd m
| None ->
let hints =
[ Pp.textf "Is the file part of a stanza?"
; Pp.textf "Has the file been written to disk?"
]
in
User_error.raise
~hints
[ Pp.textf "Cannot find file: %s" (coq_file_arg |> Path.Local.to_string) ]
in
let stanza = Dune_rules.Coq.Coq_sources.lookup_module coq_src coq_module in
let args, use_stdlib, coq_lang_version, wrapper_name, mode =
match stanza with
| None ->
User_error.raise
[ Pp.textf
"File not part of any stanza: %s"
(coq_file_arg |> Path.Local.to_string)
]
| Some (`Theory theory) ->
( Dune_rules.Coq.Coq_rules.coqtop_args_theory
~sctx
~dir
~dir_contents:dc
theory
coq_module
, theory.buildable.use_stdlib
, theory.buildable.coq_lang_version
, Dune_rules.Coq.Coq_lib_name.wrapper (snd theory.name)
, theory.buildable.mode )
| Some (`Extraction extr) ->
( Dune_rules.Coq.Coq_rules.coqtop_args_extraction ~sctx ~dir extr coq_module
, extr.buildable.use_stdlib
, extr.buildable.coq_lang_version
, "DuneExtraction"
, extr.buildable.mode )
in
(* Run coqdep *)
let* (_ : unit * Dep.Fact.t Dep.Map.t) =
let deps_of =
if no_rebuild
then Action_builder.return ()
else (
let mode =
match mode with
| None -> Dune_rules.Coq.Coq_mode.VoOnly
| Some mode -> mode
in
Dune_rules.Coq.Coq_rules.deps_of
~dir
~use_stdlib
~wrapper_name
~mode
~coq_lang_version
coq_module)
in
Action_builder.evaluate_and_collect_facts deps_of
in
(* Get args *)
let* (args, _) : string list * Dep.Fact.t Dep.Map.t =
let* args = args in
let dir = Path.external_ Path.External.initial_cwd in
let args = Dune_rules.Command.expand ~dir (S args) in
Action_builder.evaluate_and_collect_facts args.build
in
let* prog = Super_context.resolve_program_memo sctx ~dir ~loc:None coqtop in
let prog = Action.Prog.ok_exn prog in
let* () = Build_system.build_file prog in
let+ env = Super_context.context_env sctx in
Path.to_string prog, args, env
in
let args =
let topfile = Path.to_absolute_filename (Path.build coq_file_build) in
("-topfile" :: topfile :: args) @ extra_args
in
Fiber.return (coqtop, args, env)
in
restore_cwd_and_execve (Common.root common) coqtop args env
;;
let command = Cmd.v info term

3
unikernel/duniverse/dune_/bin/coq/coqtop.mli Normal file
View file

@ -0,0 +1,3 @@
open Import
val command : unit Cmd.t

141
unikernel/duniverse/dune_/bin/describe/aliases_targets.ml Normal file
View file

@ -0,0 +1,141 @@
open Import
let ls_term (fetch_results : Path.Build.t -> string list Action_builder.t) =
let+ builder = Common.Builder.term
and+ paths = Arg.(value & pos_all string [ "." ] & info [] ~docv:"DIR")
and+ context =
Common.context_arg ~doc:"The context to look in. Defaults to the default context."
in
let common, config = Common.init builder in
let request (_ : Dune_rules.Main.build_system) =
let header = List.length paths > 1 in
let open Action_builder.O in
let+ paragraphs =
Action_builder.List.map paths ~f:(fun path ->
(* The user supplied directory *)
let dir = Path.of_string path in
(* The _build and source tree version of this directory *)
let build_dir, src_dir =
match (dir : Path.t) with
| In_source_tree d ->
Path.Build.append_source (Dune_engine.Context_name.build_dir context) d, d
| In_build_dir d ->
let src_dir =
(* We only drop the build context if it is correct. *)
match Path.Build.extract_build_context d with
| Some (dir_context_name, d) ->
if
Dune_engine.Context_name.equal
context
(Dune_engine.Context_name.of_string dir_context_name)
then d
else
User_error.raise
[ Pp.textf
"Directory %s is not in context %S."
(Path.to_string_maybe_quoted dir)
(Dune_engine.Context_name.to_string context)
]
| None -> Code_error.raise "aliases_targets: build dir without context" []
in
d, src_dir
| External _ ->
User_error.raise
[ Pp.textf
"Directories outside of the project are not supported: %s"
(Path.to_string_maybe_quoted dir)
]
in
(* Check if the directory exists. *)
let* () =
Action_builder.of_memo
@@
let open Memo.O in
Source_tree.find_dir src_dir
>>= function
| Some _ -> Memo.return ()
| None ->
(* The directory didn't exist. We therefore check if it was a
directory target and error for the user accordingly. *)
let+ is_dir_target =
Load_rules.is_under_directory_target (Path.build build_dir)
in
if is_dir_target
then
User_error.raise
[ Pp.textf
"Directory %s is a directory target. This command does not support \
the inspection of directory targets."
(Path.to_string dir)
]
else
User_error.raise
[ Pp.textf "Directory %s does not exist." (Path.to_string dir) ]
in
let+ targets = fetch_results build_dir in
(* If we are printing multiple directories, we print the directory
name as a header. *)
(if header then [ Pp.textf "%s:" (Path.to_string dir) ] else [])
@ [ Pp.concat_map targets ~f:Pp.text ~sep:Pp.space ]
|> Pp.concat ~sep:Pp.space)
in
Console.print
[ Pp.vbox @@ Pp.concat_map ~f:Pp.vbox paragraphs ~sep:(Pp.seq Pp.space Pp.space) ]
in
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
Build.run_build_system ~common ~request
>>| fun (_ : (unit, [ `Already_reported ]) result) -> ()
;;
module Aliases_cmd = struct
let fetch_results (dir : Path.Build.t) =
let open Action_builder.O in
let+ alias_targets =
let+ load_dir =
Action_builder.of_memo (Load_rules.load_dir ~dir:(Path.build dir))
in
match load_dir with
| Load_rules.Loaded.Build build -> Dune_engine.Alias.Name.Map.keys build.aliases
| _ -> []
in
List.map ~f:Dune_engine.Alias.Name.to_string alias_targets
;;
let term = ls_term fetch_results
let command =
let doc = "Print aliases in a given directory. Works similarly to ls." in
Cmd.v (Cmd.info "aliases" ~doc ~envs:Common.envs) term
;;
end
module Targets_cmd = struct
let fetch_results (dir : Path.Build.t) =
let open Action_builder.O in
let+ targets =
let open Memo.O in
Target.all_direct_targets (Some (Path.Build.drop_build_context_exn dir))
>>| Path.Build.Map.to_list
|> Action_builder.of_memo
in
List.filter_map targets ~f:(fun (path, kind) ->
match Path.Build.equal (Path.Build.parent_exn path) dir with
| false -> None
| true ->
(* directory targets can be distinguied by the trailing path separator
*)
Some
(match kind with
| Target.File -> Path.Build.basename path
| Directory -> Path.Build.basename path ^ Filename.dir_sep))
;;
let term = ls_term fetch_results
let command =
let doc = "Print targets in a given directory. Works similarly to ls." in
Cmd.v (Cmd.info "targets" ~doc ~envs:Common.envs) term
;;
end

15
unikernel/duniverse/dune_/bin/describe/aliases_targets.mli Normal file
View file

@ -0,0 +1,15 @@
open Import
(** ls like commands for showing aliases and targets *)
module Aliases_cmd : sig
(** The aliases command lists all the aliases available in the given
directory, defaulting to the current working directory. *)
val command : unit Cmd.t
end
module Targets_cmd : sig
(** The targets command lists all the targets available in the given
directory, defaulting to the current working directory. *)
val command : unit Cmd.t
end

56
unikernel/duniverse/dune_/bin/describe/describe.ml Normal file
View file

@ -0,0 +1,56 @@
open Import
(* This command is not yet versioned, but some people are using it in
non-released tools. If you change the format of the output, please contact:
- rotor people for "describe workspace"
- duniverse people for "describe opam-files" *)
let subcommands =
[ Describe_workspace.command
; Describe_external_lib_deps.command
; Describe_opam_files.command
; Describe_pp.command
; Printenv.command
; Print_rules.command
; Installed_libraries.command
; Aliases_targets.Targets_cmd.command
; Aliases_targets.Aliases_cmd.command
; Package_entries.command
; Describe_pkg.command
; Describe_contexts.command
; Describe_depexts.command
; Describe_location.command
]
;;
let group =
let doc = "Describe the workspace." in
let man =
[ `S "DESCRIPTION"
; `P
{|Describe what is in the current workspace in either human or
machine readable form.
By default, this command output a human readable description of
the current workspace. This output is aimed at human and is not
suitable for machine processing. In particular, it is not versioned.
If you want to interpret the output of this command from a program,
you must use the $(b,--format) option to specify a machine readable
format as well as the $(b,--lang) option to get a stable output.|}
; `Blocks Common.help_secs
]
in
let info = Cmd.info "describe" ~doc ~man in
let default = Describe_workspace.term in
Cmd.group ~default info subcommands
;;
module Show = struct
let group =
let doc = "Command group for showing information about the workspace" in
Cmd.group (Cmd.info ~doc "show") subcommands
;;
end

9
unikernel/duniverse/dune_/bin/describe/describe.mli Normal file
View file

@ -0,0 +1,9 @@
open Import
(** Command group for dune describe *)
val group : unit Cmd.t
module Show : sig
(** Command group for dune show (alias of describe) *)
val group : unit Cmd.t
end

23
unikernel/duniverse/dune_/bin/describe/describe_contexts.ml Normal file
View file

@ -0,0 +1,23 @@
open Import
let term =
let+ builder = Common.Builder.term in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
let* setup = Import.Main.setup () in
let+ setup = Memo.run setup in
let ctxts =
List.map
~f:(fun (name, _) -> Context_name.to_string name)
(Context_name.Map.to_list setup.scontexts)
in
List.iter ctxts ~f:print_endline
;;
let command =
let doc = "List the build contexts available in the workspace." in
let info = Cmd.info ~doc "contexts" in
Cmd.v info term
;;

4
unikernel/duniverse/dune_/bin/describe/describe_contexts.mli Normal file
View file

@ -0,0 +1,4 @@
open Import
(** Dune command to print out the available build contexts.*)
val command : unit Cmd.t

24
unikernel/duniverse/dune_/bin/describe/describe_depexts.ml Normal file
View file

@ -0,0 +1,24 @@
open Import
let print_depexts context_name =
let open Fiber.O in
let+ depexts =
build_exn (fun () -> Dune_rules.Pkg_rules.all_filtered_depexts context_name)
in
Console.print [ Pp.concat_map ~sep:Pp.newline ~f:Pp.verbatim depexts ]
;;
let term =
let+ builder = Common.Builder.term
and+ context_name = Common.context_arg ~doc:"Build context to use." in
let builder = Common.Builder.forbid_builds builder in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config (fun () -> print_depexts context_name)
;;
let info =
let doc = "Print the list of all the available depexts" in
Cmd.info "depexts" ~doc
;;
let command = Cmd.v info term

4
unikernel/duniverse/dune_/bin/describe/describe_depexts.mli Normal file
View file

@ -0,0 +1,4 @@
open Import
(** Command to print all depexts *)
val command : unit Cmd.t

234
unikernel/duniverse/dune_/bin/describe/describe_external_lib_deps.ml Normal file
View file

@ -0,0 +1,234 @@
open Import
module Lib_dep = Dune_lang.Lib_dep
module Kind = struct
type t =
| Required
| Optional
let to_dyn : t -> Dyn.t = function
| Required -> String "required"
| Optional -> String "optional"
;;
end
type lib_dep =
{ name : Lib_name.t
; kind : Kind.t
}
let lib_dep_to_dyn t =
let open Dyn in
List [ String (Lib_name.to_string t.name); Kind.to_dyn t.kind ]
;;
module Item = struct
module Kind = struct
type t =
| Executables
| Library
| Tests
let to_string = function
| Executables -> "executables"
| Library -> "library"
| Tests -> "tests"
;;
end
type t =
{ kind : Kind.t
; dir : Path.Source.t
; external_deps : lib_dep list
; internal_deps : lib_dep list
; names : string list
; package : Package.t option
; extensions : string list
}
let to_dyn { kind; dir; external_deps; internal_deps; names; package; extensions } =
let open Dyn in
let record =
record
[ "names", (list string) names
; "extensions", (list string) extensions
; "package", option Package.Name.to_dyn (Option.map ~f:Package.name package)
; "source_dir", String (Path.Source.to_string dir)
; "external_deps", list lib_dep_to_dyn external_deps
; "internal_deps", list lib_dep_to_dyn internal_deps
]
in
Variant (Kind.to_string kind, [ record ])
;;
end
type dep =
| Local of lib_dep
| External of lib_dep
let is_external db name =
let open Memo.O in
let+ lib = Dune_rules.Lib.DB.find_even_when_hidden db name in
match lib with
| None -> true
| Some t ->
(match Dune_rules.Lib_info.status (Dune_rules.Lib.info t) with
| Installed_private | Public _ | Private _ -> false
| Installed -> true)
;;
let resolve_lib db name kind =
let open Memo.O in
let+ is_external = is_external db name in
if is_external then External { name; kind } else Local { name; kind }
;;
let resolve_lib_pps db preprocess =
let open Memo.O in
Dune_rules.Instrumentation.with_instrumentation
preprocess
~instrumentation_backend:(Dune_rules.Lib.DB.instrumentation_backend db)
|> Resolve.Memo.read_memo
>>| Dune_lang.Preprocess.Per_module.pps
>>= Memo.parallel_map ~f:(fun (_, name) -> resolve_lib db name Kind.Required)
;;
let resolve_lib_deps db lib_deps =
let open Memo.O in
Memo.parallel_map lib_deps ~f:(fun (lib : Lib_dep.t) ->
match lib with
| Direct (_, name) | Re_export (_, name) ->
let+ v = resolve_lib db name Kind.Required in
[ v ]
| Select select ->
select.choices
|> Memo.parallel_map ~f:(fun (choice : Lib_dep.Select.Choice.t) ->
Lib_name.Set.to_string_list choice.required
@ Lib_name.Set.to_string_list choice.forbidden
|> Memo.parallel_map ~f:(fun name ->
let name = Lib_name.of_string name in
resolve_lib db name Kind.Optional))
>>| List.concat)
>>| List.concat
;;
let resolve_libs db dir libraries preprocess names package kind extensions =
let open Memo.O in
let open Item in
let* lib_deps = resolve_lib_deps db libraries in
let+ lib_pps = resolve_lib_pps db preprocess in
let deps = lib_deps @ lib_pps in
let internal_deps, external_deps =
deps
|> List.partition_map ~f:(function
| Local lib -> Either.Left lib
| External lib -> Either.Right lib)
in
{ external_deps; internal_deps; kind; names; package; dir; extensions }
;;
let exes_extensions (lib_config : Dune_rules.Lib_config.t) modes =
Dune_rules.Executables.Link_mode.Map.to_list modes
|> List.map ~f:(fun (m, loc) ->
Dune_rules.Executables.Link_mode.extension
m
~loc
~ext_obj:lib_config.ext_obj
~ext_dll:lib_config.ext_dll)
;;
let libs db (context : Context.t) =
let open Memo.O in
let* dune_files = Context.name context |> Dune_rules.Dune_load.dune_files in
Memo.parallel_map dune_files ~f:(fun (dune_file : Dune_rules.Dune_file.t) ->
Dune_file.stanzas dune_file
>>= Memo.parallel_map ~f:(fun stanza ->
let dir = Dune_file.dir dune_file in
match Stanza.repr stanza with
| Dune_rules.Executables.T exes ->
let* ocaml = Context.ocaml context in
resolve_libs
db
dir
exes.buildable.libraries
exes.buildable.preprocess
(List.map (Nonempty_list.to_list exes.names) ~f:snd)
exes.package
Item.Kind.Executables
(exes_extensions ocaml.lib_config exes.modes)
>>| List.singleton
| Dune_rules.Library.T lib ->
resolve_libs
db
dir
lib.buildable.libraries
lib.buildable.preprocess
[ Dune_rules.Library.best_name lib |> Lib_name.to_string ]
(Dune_rules.Library.package lib)
Item.Kind.Library
[]
>>| List.singleton
| Dune_rules.Tests.T tests ->
let* ocaml = Context.ocaml context in
resolve_libs
db
dir
tests.exes.buildable.libraries
tests.exes.buildable.preprocess
(List.map (Nonempty_list.to_list tests.exes.names) ~f:snd)
(if Option.is_none tests.package then tests.exes.package else tests.package)
Item.Kind.Tests
(exes_extensions ocaml.lib_config tests.exes.modes)
>>| List.singleton
| _ -> Memo.return [])
>>| List.concat)
>>| List.concat
;;
let external_resolved_libs (context : Context.t) =
let open Memo.O in
let* scope = Dune_rules.Scope.DB.find_by_dir (Context.build_dir context) in
let db = Dune_rules.Scope.libs scope in
libs db context
>>| List.filter ~f:(fun (x : Item.t) ->
not (List.is_empty x.external_deps && List.is_empty x.internal_deps))
;;
let to_dyn context_name external_resolved_libs =
let open Dyn in
Tuple [ String context_name; list Item.to_dyn external_resolved_libs ]
;;
let term =
let+ builder = Common.Builder.term
and+ context_name = Common.context_arg ~doc:"Build context to use."
and+ _ = Describe_lang_compat.arg
and+ format = Describe_format.arg in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
let* setup = Import.Main.setup () in
let* setup = Memo.run setup in
let super_context = Import.Main.find_scontext_exn setup ~name:context_name in
build_exn
@@ fun () ->
let open Memo.O in
let context_name =
Super_context.context super_context
|> Context.name
|> Dune_engine.Context_name.to_string
in
external_resolved_libs (Super_context.context super_context)
>>| to_dyn context_name
>>| Describe_format.print_dyn format
;;
let command =
let doc =
"Print out external libraries needed to build the project. It's an approximated set \
of libraries."
in
let info = Cmd.info ~doc "external-lib-deps" in
Cmd.v info term
;;

4
unikernel/duniverse/dune_/bin/describe/describe_external_lib_deps.mli Normal file
View file

@ -0,0 +1,4 @@
open Import
(** Dune command to describe the external library dependencies *)
val command : unit Cmd.t

34
unikernel/duniverse/dune_/bin/describe/describe_format.ml Normal file
View file

@ -0,0 +1,34 @@
open Import
type t =
| Sexp
| Csexp
let all = [ "sexp", Sexp; "csexp", Csexp ]
let arg =
let doc = Printf.sprintf "$(docv) must be %s" (Arg.doc_alts_enum all) in
Arg.(value & opt (enum all) Sexp & info [ "format" ] ~docv:"FORMAT" ~doc)
;;
let print_as_sexp dyn =
let rec dune_lang_of_sexp : Sexp.t -> Dune_lang.t = function
| Atom s -> Dune_lang.atom_or_quoted_string s
| List l -> List (List.map l ~f:dune_lang_of_sexp)
in
let cst =
dyn
|> Sexp.of_dyn
|> dune_lang_of_sexp
|> Dune_lang.Ast.add_loc ~loc:Loc.none
|> Dune_lang.Cst.concrete
in
let version = Dune_lang.Syntax.greatest_supported_version_exn Stanza.syntax in
Pp.to_fmt Stdlib.Format.std_formatter (Dune_lang.Format.pp_top_sexps ~version [ cst ])
;;
let print_dyn t dyn =
match t with
| Csexp -> Csexp.to_channel stdout (Sexp.of_dyn dyn)
| Sexp -> print_as_sexp dyn
;;

13
unikernel/duniverse/dune_/bin/describe/describe_format.mli Normal file
View file

@ -0,0 +1,13 @@
open Import
(** Formatting utilities for dune describe commands *)
type t =
| Sexp
| Csexp
(** Command line option for taking a serialisation format *)
val arg : t Term.t
(** [print_dyn t dyn] prints the dyn to stdout serialised as configured in [t] *)
val print_dyn : t -> Dyn.t -> unit

11
unikernel/duniverse/dune_/bin/describe/describe_lang_compat.ml Normal file
View file

@ -0,0 +1,11 @@
let arg =
Arg.(
value
& opt (some string) None
& info
[ "lang" ]
~docv:"VERSION"
~doc:
"This argument has no effect and is deprecated. It exists solely for backwards \
compatibility.")
;;

5
unikernel/duniverse/dune_/bin/describe/describe_lang_compat.mli Normal file
View file

@ -0,0 +1,5 @@
(** Dune describe commands used to take a --lang argument that did nothing
expect for dune describe workspace. To keep compatilbility with accepting
such an argument we provide a dummy argument here that can be used. It's
value will typically be ignored. *)
val arg : string option Cmdliner.Term.t

43
unikernel/duniverse/dune_/bin/describe/describe_location.ml Normal file
View file

@ -0,0 +1,43 @@
open! Import
let doc =
"Print the path to the executable using the same resolution logic as [dune exec]."
;;
let man =
[ `S "DESCRIPTION"
; `P
{|$(b,dune describe location NAME) prints the path to the executable NAME using the same logic as:
|}
; `Pre "$ dune exec NAME"
; `P
"Dune will first try to resolve the executable within the public executables in \
the current project, then inside the \"bin\" directory of each package among the \
project's dependencies (when using dune package management), and finally within \
the directories listed in the $PATH environment variable."
]
;;
let info = Cmd.info "location" ~doc ~man
let term : unit Term.t =
let+ builder = Common.Builder.term
and+ context = Common.context_arg ~doc:{|Run the command in this build context.|}
and+ prog =
Arg.(required & pos 0 (some Exec.Cmd_arg.conv) None (Arg.info [] ~docv:"PROG"))
in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
let* setup = Import.Main.setup () in
build_exn
@@ fun () ->
let open Memo.O in
let* sctx = setup >>| Import.Main.find_scontext_exn ~name:context in
let* prog = Exec.Cmd_arg.expand ~root:(Common.root common) ~sctx prog in
let+ path = Exec.get_path common sctx ~prog >>| Path.to_string in
Dune_console.printf "%s" path
;;
let command = Cmd.v info term

3
unikernel/duniverse/dune_/bin/describe/describe_location.mli Normal file
View file

@ -0,0 +1,3 @@
open! Import
val command : unit Cmd.t

38
unikernel/duniverse/dune_/bin/describe/describe_opam_files.ml Normal file
View file

@ -0,0 +1,38 @@
open Import
let term =
let+ builder = Common.Builder.term
and+ format = Describe_format.arg
and+ _ = Describe_lang_compat.arg in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
build_exn
@@ fun () ->
let open Memo.O in
let+ project = Source_tree.root () >>| Source_tree.Dir.project in
let packages = Dune_project.packages project |> Package.Name.Map.values in
let opam_file_to_dyn pkg =
let opam_file = Path.source (Package.opam_file pkg) in
let contents =
if Dune_project.generate_opam_files project
then (
let template_file = Dune_rules.Opam_create.template_file opam_file in
let template =
if Path.exists template_file
then Some (template_file, Io.read_file template_file)
else None
in
Dune_rules.Opam_create.generate project pkg ~template)
else Io.read_file opam_file
in
Dyn.Tuple [ String (Path.to_string opam_file); String contents ]
in
packages |> Dyn.list opam_file_to_dyn |> Describe_format.print_dyn format
;;
let command =
let doc = "Print information about the opam files that have been discovered." in
let info = Cmd.info ~doc "opam-files" in
Cmd.v info term
;;

4
unikernel/duniverse/dune_/bin/describe/describe_opam_files.mli Normal file
View file

@ -0,0 +1,4 @@
open Import
(** Dune command to describe the opam files in a workspace *)
val command : unit Cmd.t

200
unikernel/duniverse/dune_/bin/describe/describe_pkg.ml Normal file
View file

@ -0,0 +1,200 @@
open Import
module Lock_dir = Dune_pkg.Lock_dir
module Local_package = Dune_pkg.Local_package
module Show_lock = struct
let print_lock lock_dir_arg () =
let open Fiber.O in
let* lock_dir_paths =
Memo.run (Workspace.workspace ())
>>| Pkg_common.Lock_dirs_arg.lock_dirs_of_workspace lock_dir_arg
in
Fiber.parallel_map lock_dir_paths ~f:(fun lock_dir_path ->
let+ platform = Pkg_common.solver_env_from_system_and_context ~lock_dir_path in
let lock_dir = Lock_dir.read_disk_exn lock_dir_path in
let packages =
Lock_dir.Packages.pkgs_on_platform_by_name lock_dir.packages ~platform
|> Package_name.Map.values
in
Pp.concat
~sep:Pp.space
[ Pp.hovbox
@@ Pp.textf "Contents of %s:" (Path.Source.to_string_maybe_quoted lock_dir_path)
; Pkg_common.pp_packages packages
]
|> Pp.vbox)
>>| Console.print
;;
let term =
let+ builder = Common.Builder.term
and+ lock_dir_arg = Pkg_common.Lock_dirs_arg.term in
let builder = Common.Builder.forbid_builds builder in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config @@ print_lock lock_dir_arg
;;
let command =
let doc = "Display packages in a lock file" in
let info = Cmd.info ~doc "lock" in
Cmd.v info term
;;
end
module Dependency_hash = struct
let print_local_packages_hash () =
let open Fiber.O in
let+ local_packages =
Pkg_common.find_local_packages
|> Memo.run
>>| Package_name.Map.values
>>| List.map ~f:Local_package.for_solver
in
let hash =
Local_package.For_solver.non_local_dependencies local_packages
|> Local_package.Dependency_hash.of_dependency_formula
in
match hash with
| None -> User_error.raise [ Pp.text "No non-local dependencies" ]
| Some dependency_hash ->
print_endline (Local_package.Dependency_hash.to_string dependency_hash)
;;
let term =
let+ builder = Common.Builder.term in
let builder = Common.Builder.forbid_builds builder in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config print_local_packages_hash
;;
let info =
let doc =
"Print the hash of the project's non-local dependencies such as what would appear \
in the \"dependency_hash\" field of a a lock.dune file."
in
Cmd.info "dependency-hash" ~doc
;;
let command = Cmd.v info term
end
module List_locked_dependencies = struct
module Package_universe = Dune_pkg.Package_universe
module Lock_dir = Dune_pkg.Lock_dir
module Opam_repo = Dune_pkg.Opam_repo
module Package_version = Dune_pkg.Package_version
module Opam_solver = Dune_pkg.Opam_solver
let info =
let doc = "List the dependencies locked by a lockdir" in
let man = [ `S "DESCRIPTION"; `P "List the dependencies locked by a lockdir" ] in
Cmd.info "list-locked-dependencies" ~doc ~man
;;
let package_deps_in_lock_dir_pp package_universe package_name ~transitive =
let traverse, traverse_word =
if transitive then `Transitive, "Transitive" else `Immediate, "Immediate"
in
let opam_package =
Package_universe.opam_package_of_package package_universe package_name
in
let list_dependencies which =
Package_universe.opam_package_dependencies_of_package
package_universe
package_name
~which
~traverse
in
Pp.concat
~sep:Pp.cut
[ Pp.hbox
(Pp.textf
"%s dependencies of local package %s"
traverse_word
(OpamPackage.to_string opam_package))
; Pp.enumerate (list_dependencies `Non_test) ~f:(fun opam_package ->
Pp.text (OpamPackage.to_string opam_package))
; Pp.enumerate (list_dependencies `Test_only) ~f:(fun opam_package ->
Pp.textf "%s (test only)" (OpamPackage.to_string opam_package))
]
|> Pp.vbox
;;
let enumerate_lock_dirs_by_path workspace ~lock_dirs =
let lock_dirs = Pkg_common.Lock_dirs_arg.lock_dirs_of_workspace lock_dirs workspace in
List.filter_map lock_dirs ~f:(fun lock_dir_path ->
if Path.exists (Path.source lock_dir_path)
then (
try Some (lock_dir_path, Lock_dir.read_disk_exn lock_dir_path) with
| User_error.E e ->
User_warning.emit
[ Pp.textf
"Failed to parse lockdir %s:"
(Path.Source.to_string_maybe_quoted lock_dir_path)
; User_message.pp e
];
None)
else None)
;;
let list_locked_dependencies ~transitive ~lock_dirs () =
let open Fiber.O in
let* lock_dirs_by_path, local_packages =
let open Memo.O in
Memo.both
(Workspace.workspace () >>| enumerate_lock_dirs_by_path ~lock_dirs)
Pkg_common.find_local_packages
|> Memo.run
in
let+ pp =
Fiber.parallel_map lock_dirs_by_path ~f:(fun (lock_dir_path, lock_dir) ->
let+ platform = Pkg_common.solver_env_from_system_and_context ~lock_dir_path in
let package_universe =
Package_universe.create ~platform local_packages lock_dir |> User_error.ok_exn
in
Pp.vbox
(Pp.concat
~sep:Pp.cut
[ Pp.hbox
(Pp.textf
"Dependencies of local packages locked in %s"
(Path.Source.to_string_maybe_quoted lock_dir_path))
; Pp.enumerate
(Package_name.Map.keys local_packages)
~f:(package_deps_in_lock_dir_pp package_universe ~transitive)
|> Pp.box
]))
>>| Pp.concat ~sep:Pp.cut
>>| Pp.vbox
in
Console.print [ pp ]
;;
let term =
let+ builder = Common.Builder.term
and+ transitive =
Arg.(
value
& flag
& info
[ "transitive" ]
~doc:
"Display transitive dependencies (by default only immediate dependencies \
are displayed)")
and+ lock_dirs = Pkg_common.Lock_dirs_arg.term in
let builder = Common.Builder.forbid_builds builder in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config
@@ list_locked_dependencies ~transitive ~lock_dirs
;;
let command = Cmd.v info term
end
let command =
let doc = "Subcommands related to package management" in
let info = Cmd.info ~doc "pkg" in
Cmd.group
info
[ Show_lock.command; List_locked_dependencies.command; Dependency_hash.command ]
;;

3
unikernel/duniverse/dune_/bin/describe/describe_pkg.mli Normal file
View file

@ -0,0 +1,3 @@
open Import
val command : unit Cmd.t

183
unikernel/duniverse/dune_/bin/describe/describe_pp.ml Normal file
View file

@ -0,0 +1,183 @@
open Import
module Dialect = Dune_lang.Dialect
let dialect_and_ml_kind file =
let open Memo.O in
let _base, ext =
let file = Path.of_string file in
Path.split_extension file
in
let+ project = Source_tree.root () >>| Source_tree.Dir.project in
let dialects = Dune_project.dialects project in
match Dialect.DB.find_by_extension dialects ext with
| None -> User_error.raise [ Pp.textf "unsupported extension: %s" ext ]
| Some x -> x
;;
let execute_pp_action ~sctx file pp_file dump_file =
let open Memo.O in
let* expander =
let bindings =
Dune_lang.Pform.Map.singleton
(Var Input_file)
[ Dune_lang.Value.Path (Path.build (pp_file |> Path.as_in_build_dir_exn)) ]
in
let dir = pp_file |> Path.parent_exn |> Path.as_in_build_dir_exn in
Super_context.expander sctx ~dir >>| Dune_rules.Expander.add_bindings ~bindings
in
let context = Dune_rules.Expander.context expander in
let build_dir = Context_name.build_dir context in
let* input =
let* action, _observing_facts =
let* loc, action =
let+ dialect, ml_kind = dialect_and_ml_kind file in
match Dialect.print_ast dialect ml_kind with
| Some print_ast -> print_ast
| None ->
(* fall back to the OCaml print_ast function, known to exist, if one
doesn't exist for this dialect. *)
Dialect.print_ast Dialect.ocaml ml_kind |> Option.value_exn
in
let build =
let open Action_builder.O in
let+ build =
Dune_rules.For_tests.Action_unexpanded.expand_no_targets
action
~chdir:build_dir
~loc
~expander
~deps:[]
~what:"describe pp"
in
Action.with_outputs_to dump_file build.action
in
Action_builder.evaluate_and_collect_facts build
in
let+ env = Dune_rules.Super_context.context_env sctx
and+ execution_parameters = Dune_engine.Execution_parameters.default in
let targets =
let unvalidated = Targets.File.create dump_file in
match Targets.validate unvalidated with
| Valid targets -> targets
| No_targets
| Inconsistent_parent_dir
| File_and_directory_target_with_the_same_name _ -> assert false
in
{ Dune_engine.Action_exec.targets = Some targets
; root = Path.build build_dir
; context = Some (Dune_engine.Build_context.create ~name:context)
; env
; rule_loc = Loc.none
; execution_parameters
; action
}
in
let ok =
let open Fiber.O in
let build_deps deps = Build_system.build_deps deps |> Memo.run in
let* result = Dune_engine.Action_exec.exec input ~build_deps in
Dune_engine.Action_exec.Exec_result.ok_exn result >>| ignore
in
Memo.of_non_reproducible_fiber ok
;;
let print_pped_file =
let dump_file pp_file ~ml_kind =
Path.set_extension
pp_file
~ext:
(match (ml_kind : Ocaml.Ml_kind.t) with
| Intf -> ".cmi.dump"
| Impl -> ".cmo.dump")
|> Path.as_in_build_dir_exn
in
fun ~sctx file pp_file ~ml_kind ->
let open Memo.O in
let dump_file = dump_file pp_file ~ml_kind in
let+ () = execute_pp_action ~sctx file pp_file dump_file in
let dump_file = Path.build dump_file in
match Path.stat dump_file with
| Ok { st_kind = S_REG; _ } ->
Io.cat dump_file;
Path.unlink_no_err dump_file
| _ ->
User_error.raise
[ Pp.textf "cannot find a dump file: %s" (Path.to_string dump_file) ]
;;
let find_module ~sctx file =
let open Memo.O in
let src = Path.drop_optional_build_context_src_exn (Path.build file) in
Dune_rules.Top_module.find_module sctx src
>>| function
| None -> None
| Some (m, _, _, origin) ->
(match
Dune_rules.Ml_sources.Origin.preprocess origin
|> Dune_lang.Preprocess.Per_module.find (Dune_rules.Module.name m)
with
| Pps { staged = true; loc; _ } -> Some (`Staged_pps loc)
| _ -> Some (`Module m))
;;
let get_pped_file super_context file =
let open Memo.O in
let context = Super_context.context super_context in
let in_build_dir file =
file |> Path.to_string |> Path.Build.relative (Context.build_dir context)
in
let file_in_build_dir =
if String.is_empty file
then User_error.raise [ Pp.textf "No file given." ]
else Path.of_string file |> in_build_dir
in
let* ml_kind =
let+ _, ml_kind = dialect_and_ml_kind file in
ml_kind
in
let file_not_found () =
User_error.raise
[ Pp.textf "%s does not exist" (Path.Build.to_string_maybe_quoted file_in_build_dir)
]
in
find_module ~sctx:super_context file_in_build_dir
>>= function
| None -> file_not_found ()
| Some (`Module m) ->
(match
Dune_rules.Module.source m ~ml_kind |> Option.map ~f:Dune_rules.Module.File.path
with
| None -> file_not_found ()
| Some pp_file ->
let+ () = Build_system.build_file pp_file in
Ok (pp_file, ml_kind))
| Some (`Staged_pps loc) ->
User_error.raise ~loc [ Pp.text "staged_pps are not supported." ]
;;
let term =
let+ builder = Common.Builder.term
and+ context_name = Common.context_arg ~doc:"Build context to use."
and+ _ = Describe_lang_compat.arg
and+ file = Arg.(required & pos 0 (some string) None (Arg.info [] ~docv:"FILE")) in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
let* setup = Import.Main.setup () in
let* setup = Memo.run setup in
let sctx = Import.Main.find_scontext_exn setup ~name:context_name in
build_exn
@@ fun () ->
let open Memo.O in
let* result = get_pped_file sctx file in
match result with
| Error file -> Io.cat file |> Memo.return
| Ok (pp_file, ml_kind) -> print_pped_file ~sctx file pp_file ~ml_kind
;;
let command =
let doc = "Build a given FILE and print the preprocessed output." in
let info = Cmd.info ~doc "pp" in
Cmd.v info term
;;

4
unikernel/duniverse/dune_/bin/describe/describe_pp.mli Normal file
View file

@ -0,0 +1,4 @@
open Import
(** Dune command to show the preprocessed version of a file. *)
val command : unit Cmd.t

687
unikernel/duniverse/dune_/bin/describe/describe_workspace.ml Normal file
View file

@ -0,0 +1,687 @@
open Import
module Options = struct
(* Option flags for what to do while crawling the workspace *)
type t =
{ with_deps : bool (* whether to compute direct dependencies between modules *)
; with_pps : bool
(* whether to include the dependencies to ppx-rewriters (that are
used at compile time) *)
}
(* whether to sanitize absolute paths of workspace items, and their UIDs, to
ensure reproducible tests *)
let sanitize_for_tests = ref false
let arg_with_deps =
let open Arg in
value
& flag
& info
[ "with-deps" ]
~doc:"Whether the dependencies between modules should be printed."
;;
let arg_with_pps =
let open Arg in
value
& flag
& info
[ "with-pps" ]
~doc:
"Whether the dependencies towards ppx-rewriters (that are called at compile \
time) should be taken into account."
;;
let arg_sanitize_for_tests =
let open Arg in
value
& flag
& info
[ "sanitize-for-tests" ]
~doc:
"Sanitize the absolute paths in workspace items, and the associated UIDs, so \
that the output is reproducible."
;;
let arg : t Term.t =
let+ with_deps = arg_with_deps
and+ with_pps = arg_with_pps
and+ sanitize_for_tests_value = arg_sanitize_for_tests in
sanitize_for_tests := sanitize_for_tests_value;
{ with_deps; with_pps }
;;
end
(* The module [Descr] is a typed representation of the description of a
workspace, that is provided by the ``dune describe workspace`` command.
Each sub-module contains a [to_dyn] function, that translates the
descriptors to a value of type [Dyn.t].
The typed representation aims at precisely describing the structure of the
information computed by ``dune describe``, and hopefully make users' life
easier in decoding the S-expressions into meaningful contents. *)
module Descr = struct
(* [dyn_path p] converts a path to a value of type [Dyn.t]. Remark: this is
different from Path.to_dyn, that produces extra tags from a variant
datatype. *)
let dyn_path (p : Path.t) : Dyn.t = String (Path.to_string p)
(* Description of the dependencies of a module *)
module Mod_deps = struct
type t =
{ for_intf : Dune_rules.Module_name.t list
(* direct module dependencies for the interface *)
; for_impl : Dune_rules.Module_name.t list
(* direct module dependencies for the implementation *)
}
(* Conversion to the [Dyn.t] type *)
let to_dyn { for_intf; for_impl } =
let open Dyn in
record
[ "for_intf", list Dune_rules.Module_name.to_dyn for_intf
; "for_impl", list Dune_rules.Module_name.to_dyn for_impl
]
;;
end
(* Description of modules *)
module Mod = struct
type t =
{ name : Dune_rules.Module_name.t (* name of the module *)
; impl : Path.t option (* path to the .ml file, if any *)
; intf : Path.t option (* path to the .mli file, if any *)
; cmt : Path.t option (* path to the .cmt file, if any *)
; cmti : Path.t option (* path to the .cmti file, if any *)
; module_deps : Mod_deps.t (* direct module dependencies *)
}
(* Conversion to the [Dyn.t] type *)
let to_dyn { Options.with_deps; _ } { name; impl; intf; cmt; cmti; module_deps }
: Dyn.t
=
let open Dyn in
let optional_fields =
let module_deps =
if with_deps then Some ("module_deps", Mod_deps.to_dyn module_deps) else None
in
(* we build a list of options, that is later filtered, so that adding
new optional fields in the future can be done easily *)
match module_deps with
| None -> []
| Some module_deps -> [ module_deps ]
in
record
@@ [ "name", Dune_rules.Module_name.to_dyn name
; "impl", option dyn_path impl
; "intf", option dyn_path intf
; "cmt", option dyn_path cmt
; "cmti", option dyn_path cmti
]
@ optional_fields
;;
end
(* Description of executables *)
module Exe = struct
type t =
{ names : string list (* names of the executable *)
; requires : Digest.t list
(* list of direct dependencies to libraries, identified by their
digests *)
; modules : Mod.t list (* list of the modules the executable is composed of *)
; include_dirs : Path.t list (* list of include directories *)
}
let map_path t ~f = { t with include_dirs = List.map ~f t.include_dirs }
(* Conversion to the [Dyn.t] type *)
let to_dyn options { names; requires; modules; include_dirs } : Dyn.t =
let open Dyn in
record
[ "names", List (List.map ~f:(fun name -> String name) names)
; "requires", Dyn.(list string) (List.map ~f:Digest.to_string requires)
; "modules", list (Mod.to_dyn options) modules
; "include_dirs", list dyn_path include_dirs
]
;;
end
(* Description of libraries *)
module Lib = struct
type t =
{ name : Lib_name.t (* name of the library *)
; uid : Digest.t (* digest of the library *)
; local : bool (* whether this library is local *)
; requires : Digest.t list
(* list of direct dependendies to libraries, identified by their
digests *)
; source_dir : Path.t
(* path to the directory that contains the sources of this library *)
; modules : Mod.t list (* list of the modules the executable is composed of *)
; include_dirs : Path.t list (* list of include directories *)
}
let map_path t ~f =
{ t with source_dir = f t.source_dir; include_dirs = List.map ~f t.include_dirs }
;;
(* Conversion to the [Dyn.t] type *)
let to_dyn options { name; uid; local; requires; source_dir; modules; include_dirs }
: Dyn.t
=
let open Dyn in
record
[ "name", Lib_name.to_dyn name
; "uid", String (Digest.to_string uid)
; "local", Bool local
; "requires", (list string) (List.map ~f:Digest.to_string requires)
; "source_dir", dyn_path source_dir
; "modules", list (Mod.to_dyn options) modules
; "include_dirs", (list dyn_path) include_dirs
]
;;
end
(* Description of items: executables, or libraries *)
module Item = struct
type t =
| Executables of Exe.t
| Library of Lib.t
| Root of Path.t
| Build_context of Path.t
let map_path t ~f =
match t with
| Executables exe -> Executables (Exe.map_path exe ~f)
| Library lib -> Library (Lib.map_path lib ~f)
| Root r -> Root (f r)
| Build_context c -> Build_context (f c)
;;
(* Conversion to the [Dyn.t] type *)
let to_dyn options : t -> Dyn.t = function
| Executables exe_descr -> Variant ("executables", [ Exe.to_dyn options exe_descr ])
| Library lib_descr -> Variant ("library", [ Lib.to_dyn options lib_descr ])
| Root root -> Variant ("root", [ String (Path.to_absolute_filename root) ])
| Build_context build_ctxt ->
Variant ("build_context", [ String (Path.to_string build_ctxt) ])
;;
end
(* Description of a workspace: a list of items *)
module Workspace = struct
type t = Item.t list
(* Conversion to the [Dyn.t] type *)
let to_dyn options (items : t) : Dyn.t = Dyn.list (Item.to_dyn options) items
end
end
module Lang = struct
type t = Dune_lang.Syntax.Version.t
let arg_conv =
let parser s =
match Scanf.sscanf s "%u.%u" (fun a b -> a, b) with
| Ok t -> Ok t
| Error () -> Error (`Msg "Expected version of the form NNN.NNN.")
in
let printer ppf t =
Stdlib.Format.fprintf ppf "%s" (Dune_lang.Syntax.Version.to_string t)
in
Arg.conv ~docv:"VERSION" (parser, printer)
;;
let arg : t Term.t =
Term.ret
@@ let+ v =
Arg.(
value
& opt arg_conv (0, 1)
& info
[ "lang" ]
~docv:"VERSION"
~doc:"Behave the same as this version of Dune.")
in
if v = (0, 1)
then `Ok v
else (
let msg =
let pp =
"Only --lang 0.1 is available at the moment as this command is not yet \
stabilised. If you would like to release a software that relies on the \
output of 'dune describe', please open a ticket on \
https://github.com/ocaml/dune."
|> Pp.text
in
Stdlib.Format.asprintf "%a" Pp.to_fmt pp
in
`Error (true, msg))
;;
end
(* The following module is responsible sanitizing the output of
[dune describe workspace], so that the absolute paths and the UIDs that
depend on them are stable for tests. These paths may differ, depending on
the machine they are run on. *)
module Sanitize_for_tests = struct
module Workspace = struct
let fake_findlib = lazy (Path.External.of_string "/FINDLIB")
let fake_workspace = lazy (Path.External.of_string "/WORKSPACE_ROOT")
let sanitize_with_findlib ~findlib_paths path =
let path = Path.external_ path in
List.find_map findlib_paths ~f:(fun candidate ->
let open Option.O in
let* candidate = Path.as_external candidate in
(* if the path to rename is an external path, try to find the
OCaml root inside, and replace it with a fixed string *)
let+ without_prefix = Path.drop_prefix ~prefix:(Path.external_ candidate) path in
(* we have found the OCaml root path: let's replace it with a
constant string *)
Path.External.append_local (Lazy.force fake_findlib) without_prefix)
;;
(* Sanitizes a workspace description, by renaming non-reproducible UIDs and
paths *)
let really_sanitize ~findlib_paths items =
let rename_path = function
(* we have found a path for OCaml's root: let's define the renaming
function *)
| Path.External path ->
sanitize_with_findlib ~findlib_paths path
|> Option.value ~default:path
|> Path.external_
| In_source_tree p ->
(* Replace the workspace root with a fixed string *)
Path.External.append_local (Lazy.force fake_workspace) (Path.Source.to_local p)
|> Path.external_
| path ->
(* Otherwise, it should not be changed *)
path
in
(* now, we rename the UIDs in the [requires] field , while reversing the
list of items, so that we get back the original ordering *)
List.map ~f:(Descr.Item.map_path ~f:rename_path) items
;;
(* Sanitizes a workspace description when options ask to do so, or performs
no change at all otherwise *)
let sanitize ~findlib_paths items =
if !Options.sanitize_for_tests then really_sanitize ~findlib_paths items else items
;;
end
end
(* Crawl the workspace to get all the data *)
module Crawl = struct
open Dune_rules
open Dune_engine
open Memo.O
(* Computes the digest of a library *)
let uid_of_library (lib : Lib.t) : Digest.t =
let name = Lib.name lib in
if Lib.is_local lib
then (
let source_dir = Lib_info.src_dir (Lib.info lib) in
Digest.generic (name, Path.to_string source_dir))
else Digest.generic name
;;
let immediate_deps_of_module ~options ~obj_dir ~modules unit =
match (options : Options.t) with
| { with_deps = false; _ } ->
Action_builder.return { Ocaml.Ml_kind.Dict.intf = []; impl = [] }
| { with_deps = true; _ } ->
let deps ml_kind =
Dune_rules.Dep_rules.immediate_deps_of unit modules ~obj_dir ~ml_kind
in
let open Action_builder.O in
let+ intf, impl = Action_builder.both (deps Intf) (deps Impl) in
{ Ocaml.Ml_kind.Dict.intf; impl }
;;
(* Builds the description of a module from a module and its object directory *)
let module_
~obj_dir
~(deps_for_intf : Module.t list)
~(deps_for_impl : Module.t list)
(m : Module.t)
: Descr.Mod.t
=
let source ml_kind = Option.map (Module.source m ~ml_kind) ~f:Module.File.path in
let cmt ml_kind =
Dune_rules.Obj_dir.Module.cmt_file obj_dir m ~ml_kind ~cm_kind:(Ocaml Cmi)
in
{ Descr.Mod.name = Module.name m
; impl = source Impl
; intf = source Intf
; cmt = cmt Impl
; cmti = cmt Intf
; module_deps =
{ for_intf = List.map ~f:Module.name deps_for_intf
; for_impl = List.map ~f:Module.name deps_for_impl
}
}
;;
(* Builds the list of modules *)
let modules ~obj_dir ~deps_of modules_ : Descr.Mod.t list Memo.t =
modules_
|> Modules.With_vlib.drop_vlib
|> Modules.fold ~init:(Memo.return []) ~f:(fun m macc ->
let* acc = macc in
let deps = deps_of m in
let+ { Ocaml.Ml_kind.Dict.intf = deps_for_intf; impl = deps_for_impl }, _ =
Dune_engine.Action_builder.evaluate_and_collect_facts deps
in
module_ ~obj_dir ~deps_for_intf ~deps_for_impl m :: acc)
;;
(* Builds a workspace item for the provided executables object *)
let executables sctx ~options ~project ~dir (exes : Executables.t)
: (Descr.Item.t * Lib.Set.t) option Memo.t
=
let* expander = Super_context.expander sctx ~dir in
Expander.eval_blang expander exes.enabled_if
>>= function
| false -> Memo.return None
| true ->
let first_exe = snd (Nonempty_list.hd exes.names) in
let* scope =
Scope.DB.find_by_project (Super_context.context sctx |> Context.name) project
in
let* modules_, obj_dir =
let+ modules_, obj_dir =
Dir_contents.get sctx ~dir
>>= Dir_contents.ocaml
>>= Ml_sources.modules_and_obj_dir
~libs:(Scope.libs scope)
~for_:(Exe { first_exe })
in
Modules.With_vlib.modules modules_, obj_dir
in
let* pp_map =
let+ version =
let+ ocaml = Super_context.context sctx |> Context.ocaml in
ocaml.version
in
Staged.unstage
@@ Pp_spec.pped_modules_map
(Dune_lang.Preprocess.Per_module.without_instrumentation
exes.buildable.preprocess)
version
in
let deps_of module_ =
let module_ = pp_map module_ in
immediate_deps_of_module ~options ~obj_dir ~modules:modules_ module_
in
let obj_dir = Obj_dir.of_local obj_dir in
let* modules_ = modules ~obj_dir ~deps_of modules_ in
let+ requires =
let* compile_info = Exe_rules.compile_info ~scope exes in
let open Resolve.Memo.O in
let* requires = Lib.Compile.direct_requires compile_info in
if options.with_pps
then
let+ pps = Lib.Compile.pps compile_info in
pps @ requires
else Resolve.Memo.return requires
in
(match Resolve.peek requires with
| Error () -> None
| Ok libs ->
let include_dirs = Obj_dir.all_cmis obj_dir in
let exe_descr =
{ Descr.Exe.names = List.map ~f:snd (Nonempty_list.to_list exes.names)
; requires = List.map ~f:uid_of_library libs
; modules = modules_
; include_dirs
}
in
Some (Descr.Item.Executables exe_descr, Lib.Set.of_list libs))
;;
(* Builds a workspace item for the provided library object *)
let library sctx ~options (lib : Lib.t) : Descr.Item.t option Memo.t =
let* requires = Lib.requires lib in
match Resolve.peek requires with
| Error () -> Memo.return None
| Ok requires ->
let name = Lib.name lib in
let info = Lib.info lib in
let src_dir = Lib_info.src_dir info in
let obj_dir = Lib_info.obj_dir info in
let+ modules_ =
match Lib.is_local lib with
| false -> Memo.return []
| true ->
(* XXX why do we have a second object directory? *)
let* modules_, obj_dir_ =
let* libs =
Scope.DB.find_by_dir (Path.as_in_build_dir_exn src_dir) >>| Scope.libs
in
let+ modules_, obj_dir_ =
Dir_contents.get sctx ~dir:(Path.as_in_build_dir_exn src_dir)
>>= Dir_contents.ocaml
>>= Ml_sources.modules_and_obj_dir
~libs
~for_:(Library (Lib_info.lib_id info |> Lib_id.to_local_exn))
in
Modules.With_vlib.modules modules_, obj_dir_
in
let* pp_map =
let+ version =
let+ ocaml = Super_context.context sctx |> Context.ocaml in
ocaml.version
in
Staged.unstage
@@ Pp_spec.pped_modules_map
(Dune_lang.Preprocess.Per_module.without_instrumentation
(Lib_info.preprocess info))
version
in
let deps_of module_ =
immediate_deps_of_module
~options
~obj_dir:obj_dir_
~modules:modules_
(pp_map module_)
in
modules ~obj_dir ~deps_of modules_
in
let include_dirs = Obj_dir.all_cmis obj_dir in
let lib_descr =
{ Descr.Lib.name
; uid = uid_of_library lib
; local = Lib.is_local lib
; requires = List.map requires ~f:uid_of_library
; source_dir = src_dir
; modules = modules_
; include_dirs
}
in
Some (Descr.Item.Library lib_descr)
;;
(* [source_path_is_in_dirs dirs p] tests whether the source path [p] is a
descendant of some of the provided directory [dirs]. If [dirs = None],
then it always succeeds. If [dirs = Some l], then a matching directory is
search in the list [l]. *)
let source_path_is_in_dirs dirs (p : Path.Source.t) =
match dirs with
| None -> true
| Some dirs -> List.exists ~f:(fun dir -> Path.Source.is_descendant p ~of_:dir) dirs
;;
(* Tests whether a dune file is located in a path that is a descendant of
some directory *)
let dune_file_is_in_dirs dirs dune_file =
Dune_file.dir dune_file |> source_path_is_in_dirs dirs
;;
(* Tests whether a library is located in a path that is a descendant of some
directory *)
let lib_is_in_dirs dirs (lib : Lib.t) =
source_path_is_in_dirs
dirs
(Path.drop_build_context_exn @@ Lib_info.best_src_dir @@ Lib.info lib)
;;
(* Builds a workspace item for the root path *)
let root () = Descr.Item.Root Path.root
(* Builds a workspace item for the build directory path *)
let build_ctxt (context : Context.t) : Descr.Item.t =
Descr.Item.Build_context (Path.build (Context.build_dir context))
;;
(* Builds a workspace description for the provided dune setup and context *)
let workspace
options
({ Dune_rules.Main.contexts = _; scontexts } : Dune_rules.Main.build_system)
(context : Context.t)
dirs
: Descr.Workspace.t Memo.t
=
let context_name = Context.name context in
let sctx = Context_name.Map.find_exn scontexts context_name in
let open Memo.O in
let* dune_files =
Dune_load.dune_files context_name >>| List.filter ~f:(dune_file_is_in_dirs dirs)
in
let* exes, exe_libs =
(* the list of workspace items that describe executables, and the list of
their direct library dependencies *)
Memo.parallel_map dune_files ~f:(fun (dune_file : Dune_file.t) ->
Dune_file.stanzas dune_file
>>= Memo.parallel_map ~f:(fun stanza ->
match Stanza.repr stanza with
| Executables.T exes ->
let dir =
Path.Build.append_source
(Context.build_dir context)
(Dune_file.dir dune_file)
in
let project = Dune_file.project dune_file in
executables sctx ~options ~project ~dir exes
| _ -> Memo.return None)
>>| List.filter_opt)
>>| List.concat
>>| List.split
in
let exe_libs =
(* conflate the dependencies of executables into a single set *)
Lib.Set.union_all exe_libs
in
let* project_libs =
(* the list of libraries declared in the project *)
Dune_load.projects ()
>>= Memo.parallel_map ~f:(fun project ->
Scope.DB.find_by_project (Context.name context) project
>>| Scope.libs
>>= Lib.DB.all)
>>| Lib.Set.union_all
>>| Lib.Set.filter ~f:(lib_is_in_dirs dirs)
in
let+ libs =
(* the executables' libraries, and the project's libraries *)
Lib.Set.union exe_libs project_libs
|> Lib.Set.to_list
|> Lib.descriptive_closure ~with_pps:options.with_pps
>>= Memo.parallel_map ~f:(library ~options sctx)
>>| List.filter_opt
in
let root = root () in
let build_ctxt = build_ctxt context in
root :: build_ctxt :: (exes @ libs)
;;
end
let find_dir common dir =
let p = Path.Source.(relative root) (Common.prefix_target common dir) in
let s = Path.source p in
if not @@ Path.exists s
then User_error.raise [ Pp.textf "No such file or directory: %s" (Path.to_string s) ];
if not @@ Path.is_directory s
then
User_error.raise
[ Pp.textf "File exists, but is not a directory: %s" (Path.to_string s) ];
Memo.return p
;;
let term : unit Term.t =
let+ builder = Common.Builder.term
and+ what =
Arg.(
value
& pos_all string []
& info
[]
~docv:"DIRS"
~doc:
"prints a description of the workspace's structure. If some directories DIRS \
are provided, then only those directories of the workspace are considered.")
and+ context_name = Common.context_arg ~doc:"Build context to use."
and+ format = Describe_format.arg
and+ lang = Lang.arg
and+ options = Options.arg in
let common, config = Common.init builder in
let dirs =
let args = "workspace" :: what in
let parse =
Dune_lang.Syntax.set Stanza.syntax (Active lang)
@@
let open Dune_lang.Decoder in
fields
@@ field "workspace"
@@ let+ dirs = repeat relative_file in
(* [None] means that all directories should be accepted,
whereas [Some l] means that only the directories in the
list [l] should be accepted. The checks on whether the
paths exist and whether they are directories are performed
later in the [describe] function. *)
let dirs = if List.is_empty dirs then None else Some dirs in
dirs
in
let ast =
Dune_lang.Ast.add_loc
~loc:Loc.none
(List (List.map args ~f:Dune_lang.atom_or_quoted_string))
in
Dune_lang.Decoder.parse parse Univ_map.empty ast
in
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
let* setup = Import.Main.setup () in
build_exn
@@ fun () ->
let open Memo.O in
let* setup = setup in
let super_context = Import.Main.find_scontext_exn setup ~name:context_name in
let context = Super_context.context super_context in
let* findlib_paths = Context.findlib_paths context in
(* prefix directories with the workspace root, so that the
command also works correctly when it is run from a
subdirectory *)
Memo.Option.map dirs ~f:(Memo.List.map ~f:(find_dir common))
>>= Crawl.workspace options setup context
>>| Sanitize_for_tests.Workspace.sanitize ~findlib_paths
>>| Descr.Workspace.to_dyn options
>>| Describe_format.print_dyn format
;;
let command =
let doc =
"Print a description of the workspace's structure. If some directories DIRS are \
provided, then only those directories of the workspace are considered."
in
let info = Cmd.info ~doc "workspace" in
Cmd.v info term
;;

6
unikernel/duniverse/dune_/bin/describe/describe_workspace.mli Normal file
View file

@ -0,0 +1,6 @@
open Import
val term : unit Term.t
(** Dune command that describes the workspace *)
val command : unit Cmd.t

26
unikernel/duniverse/dune_/bin/describe/package_entries.ml Normal file
View file

@ -0,0 +1,26 @@
open Import
let term =
let+ builder = Common.Builder.term
and+ context_name = Common.context_arg ~doc:"Build context to use."
and+ format = Describe_format.arg in
let common, config = Common.init builder in
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
let* setup = Import.Main.setup () in
let* setup = Memo.run setup in
let super_context = Import.Main.find_scontext_exn setup ~name:context_name in
build_exn
@@ fun () ->
let open Memo.O in
Dune_rules.Install_rules.stanzas_to_entries super_context
>>| Package.Name.Map.to_dyn (Dyn.list Install.Entry.Sourced.to_dyn)
>>| Describe_format.print_dyn format
;;
let command =
let doc = "prints information about the entries per package." in
let info = Cmd.info ~doc "package-entries" in
Cmd.v info term
;;

4
unikernel/duniverse/dune_/bin/describe/package_entries.mli Normal file
View file

@ -0,0 +1,4 @@
open Import
(** Dune command to print out information about the entries per package.*)
val command : unit Cmd.t

38
unikernel/duniverse/dune_/bin/diagnostics.ml Normal file
View file

@ -0,0 +1,38 @@
open Import
let exec () =
let open Fiber.O in
let where = Rpc_common.active_server_exn () in
let module Client = Dune_rpc_client.Client in
let+ errors =
let* connect = Client.Connection.connect_exn where in
Dune_rpc_impl.Client.client
connect
(Dune_rpc_private.Initialize.Request.create
~id:(Dune_rpc_private.Id.make (Sexp.Atom "diagnostics_cmd")))
~f:(fun cli ->
let* decl =
Client.Versioned.prepare_request cli Dune_rpc_private.Public.Request.diagnostics
in
match decl with
| Error e -> raise (Dune_rpc_private.Version_error.E e)
| Ok decl -> Client.request cli decl ())
in
match errors with
| Ok errors ->
List.iter errors ~f:(fun err ->
Console.print_user_message (Dune_rpc.Diagnostic.to_user_message err))
| Error e -> Rpc_common.raise_rpc_error e
;;
let info =
let doc = "Fetch and return errors from the current build." in
Cmd.info "diagnostics" ~doc
;;
let term =
let+ (builder : Common.Builder.t) = Common.Builder.term in
Rpc_common.client_term builder exec
;;
let command = Cmd.v info term

3
unikernel/duniverse/dune_/bin/diagnostics.mli Normal file
View file

@ -0,0 +1,3 @@
open Import
val command : unit Cmd.t

87
unikernel/duniverse/dune_/bin/dune Normal file
View file

@ -0,0 +1,87 @@
(include_subdirs unqualified)
(executable
(name main)
(public_name dune)
(package dune)
(enabled_if
(<> %{profile} dune-bootstrap))
(libraries
memo
promote
ocaml
ocaml_config
dune_lang
predicate_lang
fiber
fiber_event_bus
stdune
dune_console
unix
install
dune_findlib
dune_metrics
dune_digest
dune_cache
dune_cache_storage
dune_graph
dune_rules
dune_vcs
dune_engine
dune_targets
dune_util
dune_upgrader
dune_pkg
cmdliner
threads
; Kept to keep implicit_transitive_deps false working in 4.x
threads.posix
build_info
dune_config
dune_config_file
chrome_trace
dune_stats
csexp
csexp_rpc
dune_rpc_impl
dune_rules_rpc
dune_rpc_private
dune_rpc_client
dune_spawn
opam_format
source
xdg)
(bootstrap_info bootstrap-info))
; Installing the dune binary depends on the kind of build:
; - for bootstrap builds, dune.exe is copied from ../dune.exe
; and installed using a manual install stanza
; - for non-bootstrap builds (building dune with another dune),
; the executable stanza does everything (and attached it to the
; right package, which is important for build-info to succeed)
; but we still need to setup a dummy dune.exe so that profiles
; agree on the targets.
(rule
(enabled_if
(<> %{profile} dune-bootstrap))
(action
(with-stdout-to dune.exe (progn))))
(rule
(action
(copy ../_boot/dune.exe dune.exe))
(enabled_if
(= %{profile} dune-bootstrap)))
(install
(section bin)
(enabled_if
(= %{profile} dune-bootstrap))
(package dune)
(files
(dune.exe as dune)))
(deprecated_library_name
(old_public_name dune.configurator)
(new_public_name dune-configurator))

611
unikernel/duniverse/dune_/bin/dune_init.ml Normal file
View file

@ -0,0 +1,611 @@
open Import
(** Because the dune_init utility deals with the addition of stanzas and fields
to dune projects and files, we need to inspect and manipulate the concrete
syntax tree (CST) a good deal. *)
module Cst = Dune_lang.Cst
(** Abstractions around the kinds of files handled during initialization *)
module File = struct
type dune =
{ path : Path.t
; name : string
; content : Cst.t list
}
type text =
{ path : Path.t
; name : string
; content : string
}
type t =
| Dune of dune
| Text of text
let make_text path name content = Text { path; name; content }
let full_path = function
| Dune { path; name; _ } | Text { path; name; _ } -> Path.relative path name
;;
(** Inspection and manipulation of stanzas in a file *)
module Stanza = struct
let pp s =
match Cst.to_sexp s with
| None -> Pp.nop
| Some s -> Dune_lang.pp s
;;
let libraries_conflict (a : Library.t) (b : Library.t) = a.name = b.name
let executables_conflict (a : Dune_rules.Executables.t) (b : Dune_rules.Executables.t)
=
let a_names = String.Set.of_list_map ~f:snd (Nonempty_list.to_list a.names) in
let b_names = String.Set.of_list_map ~f:snd (Nonempty_list.to_list b.names) in
String.Set.inter a_names b_names |> String.Set.is_empty |> not
;;
let tests_conflict (a : Dune_rules.Tests.t) (b : Dune_rules.Tests.t) =
executables_conflict a.exes b.exes
;;
let stanzas_conflict (a : Stanza.t) (b : Stanza.t) =
match Stanza.repr a, Stanza.repr b with
| Dune_rules.Executables.T a, Dune_rules.Executables.T b -> executables_conflict a b
| Library.T a, Library.T b -> libraries_conflict a b
| Dune_rules.Tests.T a, Dune_rules.Tests.T b -> tests_conflict a b
(* NOTE No other stanza types currently supported *)
| _ -> false
;;
let csts_conflict project (a : Cst.t) (b : Cst.t) =
let of_ast = Dune_rules.Stanzas.of_ast project in
(let open Option.O in
let* a_ast = Cst.abstract a in
let+ b_ast = Cst.abstract b in
let a_asts = of_ast a_ast in
let b_asts = of_ast b_ast in
List.exists ~f:(fun x -> List.exists ~f:(stanzas_conflict x) a_asts) b_asts)
|> Option.value ~default:false
;;
(* TODO(shonfeder): replace with stanza merging *)
let find_conflicting project new_stanzas existing_stanzas =
let conflicting_stanza stanza =
match List.find ~f:(csts_conflict project stanza) existing_stanzas with
| Some conflict -> Some (stanza, conflict)
| None -> None
in
List.find_map ~f:conflicting_stanza new_stanzas
;;
let add (project : Dune_project.t) stanzas = function
| Text f -> Text f (* Adding a stanza to a text file isn't meaningful *)
| Dune f ->
(match find_conflicting project stanzas f.content with
| None -> Dune { f with content = f.content @ stanzas }
| Some (a, b) ->
User_error.raise
[ Pp.text "Updating existing stanzas is not yet supported."
; Pp.text "A preexisting dune stanza conflicts with a generated stanza:"
; Pp.nop
; Pp.text "Generated stanza:"
; pp a
; Pp.nop
; Pp.text "Pre-existing stanza:"
; pp b
])
;;
end
(* Stanza *)
let create_dir path =
try Path.mkdir_p path with
| Unix.Unix_error (EACCES, _, _) ->
User_error.raise
[ Pp.textf
"A project directory cannot be created or accessed: Lacking permissions \
needed to create directory %s"
(Path.to_string_maybe_quoted path)
]
;;
let load_dune_file ~path =
let name = "dune" in
let full_path = Path.relative path name in
let content =
if not (Path.exists full_path)
then []
else if Path.is_directory full_path
then
User_error.raise
[ Pp.textf
"\"%s\" already exists and is a directory"
(Path.to_absolute_filename full_path)
]
else (
match Io.with_lexbuf_from_file ~f:Dune_lang.Format.parse full_path with
| Dune_lang.Format.Sexps content -> content
| Dune_lang.Format.OCaml_syntax _ ->
User_error.raise
[ Pp.textf
"Cannot load dune file %s because it uses OCaml syntax"
(Path.to_string_maybe_quoted full_path)
])
in
Dune { path; name; content }
;;
let write_dune_file (dune_file : dune) =
let path = Path.relative dune_file.path dune_file.name in
let version =
Dune_lang.Syntax.greatest_supported_version_exn Dune_lang.Stanza.syntax
in
Io.with_file_out
~binary:true
(* Why do we pass [~binary:true] but not anywhere else when formatting? *)
path
~f:(fun oc ->
let fmt = Format.formatter_of_out_channel oc in
Format.fprintf
fmt
"%a%!"
Pp.to_fmt
(Dune_lang.Format.pp_top_sexps ~version dune_file.content))
;;
let write f =
let path = full_path f in
match f with
| Dune f -> Ok (write_dune_file f)
| Text f ->
if Path.exists path
then Error path
else Ok (Io.write_file ~binary:false path f.content)
;;
end
(** The context in which the initialization is executed *)
module Init_context = struct
open Dune_config_file
type t =
{ dir : Path.t
; project : Dune_project.t
; defaults : Dune_config.Project_defaults.t
}
let make path defaults =
let open Memo.O in
let+ project =
(* CR-someday rgrinberg: why not get the project from the source tree? *)
Dune_project.load
~dir:Path.Source.root
~files:Filename.Set.empty
~infer_from_opam_files:true
~load_opam_file_with_contents:Dune_pkg.Opam_file.load_opam_file_with_contents
>>| function
| Some p -> p
| None ->
Dune_project.anonymous
~dir:Path.Source.root
Package_info.empty
Package.Name.Map.empty
in
let dir =
match path with
| None -> Path.root
| Some p -> Path.of_string p
in
File.create_dir dir;
{ dir; project; defaults }
;;
end
let check_module_name name =
let s = Dune_lang.Atom.to_string name in
let (_ : Dune_rules.Module_name.t) =
Dune_rules.Module_name.of_string_user_error (Loc.none, s) |> User_error.ok_exn
in
()
;;
module Public_name = struct
include Lib_name
module Pkg = Dune_lang.Package_name.Opam_compatible
let is_opam_compatible l =
Lib_name.package_name l |> Dune_lang.Package_name.is_opam_compatible
;;
let of_string_user_error (loc, s) =
let open Result.O in
let* l = of_string_user_error (loc, s) in
if is_opam_compatible l
then Ok l
else
Error
(User_error.make
[ Pp.text
"Public names are composed of an opam package name and optional \
dot-separated string suffixes."
; Pkg.description_of_valid_string
])
;;
let of_name_exn name =
let s = Dune_lang.Atom.to_string name in
of_string_user_error (Loc.none, s) |> User_error.ok_exn
;;
end
module Component = struct
module Options = struct
module Common = struct
type t =
{ name : Dune_lang.Atom.t
; public : Public_name.t option
; libraries : Dune_lang.Atom.t list
; pps : Dune_lang.Atom.t list
}
let package_name common =
let name =
match common.public with
| None -> Dune_lang.Atom.to_string common.name
| Some public -> Public_name.to_string public
in
Package.Name.of_string name
;;
end
module Executable = struct
type t = unit
end
module Library = struct
type t = { inline_tests : bool }
end
module Project = struct
module Template = struct
type t =
| Exec
| Lib
let of_string = function
| "executable" -> Some Exec
| "library" -> Some Lib
| _ -> None
;;
let commands = [ "executable", Exec; "library", Lib ]
end
module Pkg = struct
type t =
| Opam
| Esy
let commands = [ "opam", Opam; "esy", Esy ]
end
type t =
{ template : Template.t
; inline_tests : bool
; pkg : Pkg.t
}
end
module Test = struct
type t = unit
end
type 'options t =
{ context : Init_context.t
; common : Common.t
; options : 'options
}
end
(* Options *)
type 'options t =
| Executable : Options.Executable.t Options.t -> Options.Executable.t t
| Library : Options.Library.t Options.t -> Options.Library.t t
| Project : Options.Project.t Options.t -> Options.Project.t t
| Test : Options.Test.t Options.t -> Options.Test.t t
(** Internal representation of the files comprising a component *)
type target =
{ dir : Path.t
; files : File.t list
}
(** Creates Dune language CST stanzas describing components *)
module Stanza_cst = struct
open Dune_lang
module Field = struct
let inline_tests = Encoder.field_b "inline_tests"
let pps_encoder pps = Encoder.list Encoder.string ("pps" :: pps)
let preprocess_field = function
| [] -> []
| pps -> [ Encoder.field "preprocess" pps_encoder pps ]
;;
let common (options : Options.Common.t) =
[ Encoder.field "name" Encoder.string (Atom.to_string options.name)
; Encoder.field_l
"libraries"
Encoder.string
(List.map ~f:Atom.to_string options.libraries)
]
@ preprocess_field (List.map ~f:Atom.to_string options.pps)
;;
end
(* Make CST representation of a stanza for the given `kind` *)
let make kind common_options fields =
Encoder.named_record_fields kind (fields @ Field.common common_options)
(* Convert to a CST *)
|> Dune_lang.Ast.add_loc ~loc:Loc.none
|> Cst.concrete
(* Package as a list CSTs *) |> List.singleton
;;
let add_to_list_set elem set =
if List.mem ~equal:Dune_lang.Atom.equal set elem then set else elem :: set
;;
let public_name_field = Encoder.field_o "public_name" Public_name.encode
let executable (common : Options.Common.t) (() : Options.Executable.t) =
make "executable" common [ public_name_field common.public ]
;;
let library (common : Options.Common.t) { Options.Library.inline_tests } =
check_module_name common.name;
let common =
if inline_tests
then (
let pps =
add_to_list_set (Dune_lang.Atom.of_string "ppx_inline_test") common.pps
in
{ common with pps })
else common
in
make
"library"
common
[ public_name_field common.public; Field.inline_tests inline_tests ]
;;
let test common (() : Options.Test.t) = make "test" common []
(* A list of CSTs for dune-project file content *)
let dune_project
~opam_file_gen
~(defaults : Dune_config_file.Dune_config.Project_defaults.t)
dir
(common : Options.Common.t)
=
let cst =
let package =
Package.create
~name:(Options.Common.package_name common)
~loc:Loc.none
~version:None
~conflicts:[]
~depopts:[]
~info:Package_info.empty
~sites:Site.Map.empty
~allow_empty:false
~deprecated_package_names:Package.Name.Map.empty
~has_opam_file:(Exists false)
~original_opam_file:None
~dir
~synopsis:(Some "A short synopsis")
~description:(Some "A longer description")
~tags:[ "add topics"; "to describe"; "your"; "project" ]
~depends:
[ { Package_dependency.name = Package.Name.of_string "ocaml"
; constraint_ = None
}
]
in
let packages = Package.Name.Map.singleton (Package.name package) package in
let info =
Package_info.example
~authors:defaults.authors
~maintainers:defaults.maintainers
~license:defaults.license
in
Dune_project.anonymous ~dir info packages
|> Dune_project.set_generate_opam_files opam_file_gen
|> Dune_project.encode
|> List.map ~f:(fun exp ->
exp |> Dune_lang.Ast.add_loc ~loc:Loc.none |> Cst.concrete)
in
List.append
cst
[ Cst.Comment
( Loc.none
, [ " See the complete stanza docs at \
https://dune.readthedocs.io/en/stable/reference/dune-project/index.html"
] )
]
;;
end
(* TODO Support for merging in changes to an existing stanza *)
let add_stanza_to_dune_file ~(project : Dune_project.t) ~dir stanza =
File.load_dune_file ~path:dir |> File.Stanza.add project stanza
;;
(* Functions to make the various components, represented as lists of files *)
module Make = struct
let bin ({ context; common; options } : Options.Executable.t Options.t) =
let dir = context.dir in
let bin_dune =
Stanza_cst.executable common options
|> add_stanza_to_dune_file ~project:context.project ~dir
in
let bin_ml =
let name = sprintf "%s.ml" (Dune_lang.Atom.to_string common.name) in
let content = sprintf "let () = print_endline \"Hello, World!\"\n" in
File.make_text dir name content
in
let files = [ bin_dune; bin_ml ] in
[ { dir; files } ]
;;
let src ({ context; common; options } : Options.Library.t Options.t) =
let dir = context.dir in
let lib_dune =
Stanza_cst.library common options
|> add_stanza_to_dune_file ~project:context.project ~dir
in
let files = [ lib_dune ] in
[ { dir; files } ]
;;
let test ({ context; common; options } : Options.Test.t Options.t) =
(* Marking the current absence of test-specific options *)
let dir = context.dir in
let test_dune =
Stanza_cst.test common options
|> add_stanza_to_dune_file ~project:context.project ~dir
in
let test_ml =
let name = sprintf "%s.ml" (Dune_lang.Atom.to_string common.name) in
let content = "" in
File.make_text dir name content
in
let files = [ test_dune; test_ml ] in
[ { dir; files } ]
;;
let dune_project_file dir ({ context; common; options } : Options.Project.t Options.t)
=
let opam_file_gen =
match options.pkg with
| Opam -> true
| Esy -> false
in
let content =
Stanza_cst.dune_project
~opam_file_gen
~defaults:context.defaults
Path.(as_in_source_tree_exn context.dir)
common
in
File.Dune { path = dir; content; name = "dune-project" }
;;
let proj_exec dir ({ context; common; options } : Options.Project.t Options.t) =
let lib_target =
src
{ context = { context with dir = Path.relative dir "lib" }
; options = { inline_tests = options.inline_tests }
; common = { common with public = None }
}
in
let test_target =
let test_name = "test_" ^ Dune_lang.Atom.to_string common.name in
test
{ context = { context with dir = Path.relative dir "test" }
; options = ()
; common = { common with name = Dune_lang.Atom.of_string test_name }
}
in
let bin_target =
(* Add the lib_target as a library to the executable*)
let libraries = Stanza_cst.add_to_list_set common.name common.libraries in
bin
{ context = { context with dir = Path.relative dir "bin" }
; options = ()
; common = { common with libraries; name = Dune_lang.Atom.of_string "main" }
}
in
bin_target @ lib_target @ test_target
;;
let proj_lib dir ({ context; common; options } : Options.Project.t Options.t) =
let lib_target =
src
{ context = { context with dir = Path.relative dir "lib" }
; options = { inline_tests = options.inline_tests }
; common
}
in
let test_target =
let test_name = "test_" ^ Dune_lang.Atom.to_string common.name in
test
{ context = { context with dir = Path.relative dir "test" }
; options = ()
; common = { common with name = Dune_lang.Atom.of_string test_name }
}
in
lib_target @ test_target
;;
let proj ({ common; options; _ } as opts : Options.Project.t Options.t) =
let ({ template; pkg; _ } : Options.Project.t) = options in
let dir = Path.Source.root in
let proj_target =
let package_files =
match (pkg : Options.Project.Pkg.t) with
| Opam ->
let name = Options.Common.package_name common in
let opam_file = Path.source @@ Package_name.file name ~dir in
[ File.make_text (Path.parent_exn opam_file) (Path.basename opam_file) "" ]
| Esy -> [ File.make_text (Path.source dir) "package.json" "" ]
in
let dir = Path.source dir in
{ dir; files = dune_project_file dir opts :: package_files }
in
let component_targets =
(match (template : Options.Project.Template.t) with
| Exec -> proj_exec
| Lib -> proj_lib)
(Path.source dir)
opts
in
proj_target :: component_targets
;;
end
let report_uncreated_file = function
| Ok _ -> ()
| Error path ->
let open Pp.O in
User_warning.emit
[ Pp.textf "File "
++ Pp.tag
User_message.Style.Kwd
(Pp.verbatim (Path.to_string_maybe_quoted path))
++ Pp.text " was not created because it already exists"
]
;;
(** Creates a component, writing the files to disk *)
let create target =
File.create_dir target.dir;
List.map ~f:File.write target.files
;;
let init (type options) (t : options t) =
let target =
match t with
| Executable params -> Make.bin params
| Library params -> Make.src params
| Project params -> Make.proj params
| Test params -> Make.test params
in
List.concat_map ~f:create target |> List.iter ~f:report_uncreated_file
;;
end

103
unikernel/duniverse/dune_/bin/dune_init.mli Normal file
View file

@ -0,0 +1,103 @@
(** Initialize dune components *)
open Import
(** The context in which the initialization is executed *)
module Init_context : sig
open Dune_config_file
type t =
{ dir : Path.t
; project : Dune_project.t
; defaults : Dune_config.Project_defaults.t
}
val make : string option -> Dune_config.Project_defaults.t -> t Memo.t
end
module Public_name : sig
type t
val to_string : t -> string
val of_string_user_error : Loc.t * string -> (t, User_message.t) result
val of_name_exn : Dune_lang.Atom.t -> t
end
(** A [Component.t] is a set of files that can be built or included as part of a
build. *)
module Component : sig
(** Options determining the details of a generated component *)
module Options : sig
(** The common options shared by all components *)
module Common : sig
type t =
{ name : Dune_lang.Atom.t
; public : Public_name.t option
; libraries : Dune_lang.Atom.t list
; pps : Dune_lang.Atom.t list
}
end
(** Options for executable components *)
module Executable : sig
(** NOTE: no options supported yet *)
type t = unit
end
(** Options for library components *)
module Library : sig
type t = { inline_tests : bool }
end
(** Options for test components *)
module Test : sig
(** NOTE: no options supported yet *)
type t = unit
end
(** Options for project components (which consist of several sub-components) *)
module Project : sig
(** Determines whether this is a library project or an executable project *)
module Template : sig
type t =
| Exec
| Lib
val of_string : string -> t option
val commands : (string * t) list
end
(** The package manager used for a project *)
module Pkg : sig
type t =
| Opam
| Esy
val commands : (string * t) list
end
type t =
{ template : Template.t
; inline_tests : bool
; pkg : Pkg.t
}
end
type 'a t =
{ context : Init_context.t
; common : Common.t
; options : 'a
}
end
(** All the the supported types of components *)
type 'options t =
| Executable : Options.Executable.t Options.t -> Options.Executable.t t
| Library : Options.Library.t Options.t -> Options.Library.t t
| Project : Options.Project.t Options.t -> Options.Project.t t
| Test : Options.Test.t Options.t -> Options.Test.t t
(** Create or update the component specified by the ['options t], where
['options] is *)
val init : 'options t -> unit
end

328
unikernel/duniverse/dune_/bin/exec.ml Normal file
View file

@ -0,0 +1,328 @@
open Import
let doc = "Execute a command in a similar environment as if installation was performed."
let man =
[ `S "DESCRIPTION"
; `P
{|$(b,dune exec -- COMMAND) should behave in the same way as if you
do:|}
; `Pre " \\$ dune install\n \\$ COMMAND"
; `P
{|In particular if you run $(b,dune exec ocaml), you will have
access to the libraries defined in the workspace using your usual
directives ($(b,#require) for instance)|}
; `P
{|When a leading / is present in the command (absolute path), then the
path is interpreted as an absolute path|}
; `P
{|When a / is present at any other position (relative path), then the
path is interpreted as relative to the build context + current
working directory (or the value of $(b,--root) when ran outside of
the project root)|}
; `Blocks Common.help_secs
; Common.examples
[ "Run the executable named `my_exec'", "dune exec my_exec"
; ( "Run the executable defined in `foo.ml' with the argument `arg'"
, "dune exec -- ./foo.exe arg" )
]
]
;;
let info = Cmd.info "exec" ~doc ~man
module Cmd_arg = struct
type t =
| Expandable of Dune_lang.String_with_vars.t * string
| Terminal of string
let parse s =
match Arg.conv_parser Arg.dep s with
| Ok (File sw) when Dune_lang.String_with_vars.has_pforms sw -> Expandable (sw, s)
| _ -> Terminal s
;;
let pp pps = function
| Expandable (_, s) -> Format.fprintf pps "%s" s
| Terminal s -> Format.fprintf pps "%s" s
;;
let expand t ~root ~sctx =
let open Memo.O in
match t with
| Terminal s -> Memo.return s
| Expandable (sw, _) ->
let+ path, _ =
Target.expand_path_from_root root sctx sw
|> Action_builder.evaluate_and_collect_facts
in
let context = Dune_rules.Super_context.context sctx in
(* TODO Why are we stringifying this path? *)
Path.to_string (Path.build (Path.Build.relative (Context.build_dir context) path))
;;
let conv = Arg.conv ((fun s -> Ok (parse s)), pp)
end
let not_found ~hints ~prog =
User_error.raise
~hints
[ Pp.concat
~sep:Pp.space
[ Pp.text "Program"; User_message.command prog; Pp.text "not found!" ]
]
;;
let not_found_with_suggestions ~dir ~prog =
let open Memo.O in
let+ hints =
(* Good candidates for the "./x.exe" instead of "x.exe" error are
executables present in the current directory. Note: we do not
check directory targets here; even if they do indeed include a
matching executable, they would be located in a subdirectory of
[dir], so it's unclear if that's what the user wanted. *)
let+ candidates =
let+ filename_set = Build_system.files_of ~dir:(Path.build dir) in
Filename_set.filenames filename_set
|> Filename.Set.to_list
|> List.filter ~f:(fun filename -> Filename.extension filename = ".exe")
|> List.map ~f:(fun filename -> "./" ^ filename)
in
User_message.did_you_mean prog ~candidates
in
not_found ~hints ~prog
;;
let program_not_built_yet prog =
User_error.raise
[ Pp.concat
~sep:Pp.space
[ Pp.text "Program"
; User_message.command prog
; Pp.text "isn't built yet. You need to build it first or remove the"
; User_message.command "--no-build"
; Pp.text "option."
]
]
;;
let build_prog ~no_rebuild ~prog p =
if no_rebuild
then if Path.exists p then Memo.return p else program_not_built_yet prog
else
let open Memo.O in
let+ () = Build_system.build_file p in
p
;;
let dir_of_context common sctx =
let context = Dune_rules.Super_context.context sctx in
Path.Build.relative (Context.build_dir context) (Common.prefix_target common "")
;;
let get_path common sctx ~prog =
let open Memo.O in
let dir = dir_of_context common sctx in
match Filename.analyze_program_name prog with
| In_path ->
Super_context.resolve_program_memo sctx ~dir ~loc:None prog
>>= (function
| Error (_ : Action.Prog.Not_found.t) -> not_found_with_suggestions ~dir ~prog
| Ok p -> Memo.return p)
| Relative_to_current_dir ->
let path = Path.relative_to_source_in_build_or_external ~dir prog in
Build_system.file_exists path
>>= (function
| true -> Memo.return path
| false -> not_found_with_suggestions ~dir ~prog)
| Absolute ->
(match
let prog = Path.of_string prog in
if Path.exists prog
then Some prog
else if not Sys.win32
then None
else (
let prog = Path.extend_basename prog ~suffix:Bin.exe in
Option.some_if (Path.exists prog) prog)
with
| Some prog -> Memo.return prog
| None -> not_found_with_suggestions ~dir ~prog)
;;
let get_path_and_build_if_necessary common sctx ~no_rebuild ~prog =
let open Memo.O in
let* path = get_path common sctx ~prog in
match Filename.analyze_program_name prog with
| In_path | Relative_to_current_dir -> build_prog ~no_rebuild ~prog path
| Absolute -> Memo.return path
;;
let step ~prog ~args ~common ~no_rebuild ~context ~on_exit () =
let open Memo.O in
let* sctx = Super_context.find_exn context in
let* path =
let* prog = Cmd_arg.expand ~root:(Common.root common) ~sctx prog in
get_path_and_build_if_necessary common sctx ~no_rebuild ~prog
and* args =
Memo.parallel_map args ~f:(Cmd_arg.expand ~root:(Common.root common) ~sctx)
in
let* env = Super_context.context_env sctx in
Memo.of_non_reproducible_fiber
@@ Dune_engine.Process.run_inherit_std_in_out
~dir:(Path.of_string Fpath.initial_cwd)
~env
path
args
>>| function
| 0 -> ()
| exit_code -> on_exit exit_code
;;
(* Similar to [get_path_and_build_if_necessary] but doesn't require the build
system (ie. it sequences with [Fiber] rather than with [Memo]) and builds
targets via an RPC server. Some functionality is not available but it can be
run concurrently while a second Dune process holds the global build
directory lock.
Returns the absolute path to the executable. *)
let build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog =
match Filename.analyze_program_name prog with
| In_path ->
(* This case is reached if [dune exec] is passed the name of an
executable (rather than a path to an executable). When dune is running
directly, dune will try to resolve the executbale name within the public
executables defined in the current project and its dependencies, and
only if no executable with the given name is found will dune then
resolve the name within the $PATH variable instead. Looking up an
executable's name within the current project requires running the
build system, but running the build system is not allowed while
another dune instance holds the global build directory lock. In this
case dune will only resolve the executable's name within $PATH.
Because this behaviour is different from the default, print a warning
so users are hopefully less surprised.
*)
User_warning.emit
[ Pp.textf
"As this is not the main instance of Dune it is unable to locate the \
executable %S within this project. Dune will attempt to resolve the \
executable's name within your PATH only."
prog
];
let path = Env_path.path Env.initial in
(match Bin.which ~path prog with
| None -> not_found ~hints:[] ~prog
| Some prog_path -> Fiber.return (Path.to_absolute_filename prog_path))
| Relative_to_current_dir ->
let open Fiber.O in
let path = Path.relative_to_source_in_build_or_external ~dir prog in
let+ () =
if no_rebuild
then if Path.exists path then Fiber.return () else program_not_built_yet prog
else (
let target =
Dune_lang.Dep_conf.File
(Dune_lang.String_with_vars.make_text Loc.none (Path.to_string path))
in
Build.build_via_rpc_server ~print_on_success:false ~targets:[ target ])
in
Path.to_absolute_filename path
| Absolute ->
if Path.exists (Path.of_string prog)
then Fiber.return prog
else not_found ~hints:[] ~prog
;;
let exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild =
let open Fiber.O in
let ensure_terminal v =
match (v : Cmd_arg.t) with
| Terminal s -> s
| Expandable (_, raw) ->
(* Variables cannot be expanded without running the build system. *)
User_error.raise
[ Pp.textf
"The term %S contains a variable but Dune is unable to expand variables when \
building via RPC."
raw
]
in
let context = Common.x common |> Option.value ~default:Context_name.default in
let dir = Context_name.build_dir context in
let prog = ensure_terminal prog in
let args = List.map args ~f:ensure_terminal in
let+ prog = build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog in
restore_cwd_and_execve (Common.root common) prog args Env.initial
;;
let exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild =
match Common.watch common with
| Yes Passive ->
User_error.raise [ Pp.textf "passive watch mode is unsupported by exec" ]
| Yes Eager ->
Scheduler.go_with_rpc_server_and_console_status_reporting ~common ~config
@@ fun () ->
let open Fiber.O in
let on_exit = Console.printf "Program exited with code [%d]" in
Scheduler.Run.poll
@@
let* () = Fiber.return @@ Scheduler.maybe_clear_screen ~details_hum:[] config in
build @@ step ~prog ~args ~common ~no_rebuild ~context ~on_exit
| No ->
Scheduler.go_with_rpc_server ~common ~config
@@ fun () ->
let open Fiber.O in
let* setup = Import.Main.setup () in
build_exn (fun () ->
let open Memo.O in
let* sctx = setup >>| Import.Main.find_scontext_exn ~name:context in
let* env = Super_context.context_env sctx
and* prog =
let* prog = Cmd_arg.expand ~root:(Common.root common) ~sctx prog in
get_path_and_build_if_necessary common sctx ~no_rebuild ~prog >>| Path.to_string
and* args =
Memo.parallel_map ~f:(Cmd_arg.expand ~root:(Common.root common) ~sctx) args
in
restore_cwd_and_execve (Common.root common) prog args env)
;;
let term : unit Term.t =
let+ builder = Common.Builder.term
and+ context = Common.context_arg ~doc:{|Run the command in this build context.|}
and+ prog = Arg.(required & pos 0 (some Cmd_arg.conv) None (Arg.info [] ~docv:"PROG"))
and+ no_rebuild =
Arg.(value & flag & info [ "no-build" ] ~doc:"don't rebuild target before executing")
and+ args = Arg.(value & pos_right 0 Cmd_arg.conv [] (Arg.info [] ~docv:"ARGS")) in
(* TODO we should make sure to finalize the current backend before exiting dune.
For watch mode, we should finalize the backend and then restart it in between
runs. *)
let common, config = Common.init builder in
match Dune_util.Global_lock.lock ~timeout:None with
| Error lock_held_by ->
(match Common.watch common with
| Yes _ ->
User_error.raise
[ Pp.textf
"Another instance of dune%s has locked the _build directory. Refusing to \
start a new watch server until no other instances of dune are running."
(match lock_held_by with
| Unknown -> ""
| Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
]
| No ->
if not (Common.Builder.equal builder Common.Builder.default)
then
User_warning.emit
[ Pp.textf
"Your build request is being forwarded to a running Dune instance%s. Note \
that certain command line arguments may be ignored."
(match lock_held_by with
| Unknown -> ""
| Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
];
Scheduler.go_without_rpc_server ~common ~config
@@ fun () -> exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild)
| Ok () -> exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild
;;
let command = Cmd.v info term

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